From 82a51e6c72e961a85e6ed43a462b676a5e6957c9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Thu, 19 Jan 2017 21:10:29 +0100 Subject: [PATCH] Remove NotCPP code (not used by Setup.hs anymore) --- NotCPP/COPYING | 30 ------ NotCPP/Declarations.hs | 188 -------------------------------------- NotCPP/LookupValueName.hs | 44 --------- NotCPP/OrphanEvasion.hs | 114 ----------------------- NotCPP/ScopeLookup.hs | 65 ------------- NotCPP/Utils.hs | 35 ------- ghc-mod.cabal | 3 - 7 files changed, 479 deletions(-) delete mode 100644 NotCPP/COPYING delete mode 100644 NotCPP/Declarations.hs delete mode 100644 NotCPP/LookupValueName.hs delete mode 100644 NotCPP/OrphanEvasion.hs delete mode 100644 NotCPP/ScopeLookup.hs delete mode 100644 NotCPP/Utils.hs diff --git a/NotCPP/COPYING b/NotCPP/COPYING deleted file mode 100644 index 9eb8e8189..000000000 --- a/NotCPP/COPYING +++ /dev/null @@ -1,30 +0,0 @@ -Copyright Ben Millwood 2012 - -All rights reserved. - -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. - - * Neither the name of Ben Millwood nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"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 -OWNER OR CONTRIBUTORS 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/NotCPP/Declarations.hs b/NotCPP/Declarations.hs deleted file mode 100644 index 9567689ec..000000000 --- a/NotCPP/Declarations.hs +++ /dev/null @@ -1,188 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# LANGUAGE CPP #-} --- Using CPP so you don't have to :) -module NotCPP.Declarations where - -import Control.Arrow -import Control.Applicative -import Data.Maybe -import Language.Haskell.TH.Syntax - -import NotCPP.LookupValueName - -nT :: Monad m => String -> m Type -cT :: Monad m => String -> m Type -nE :: Monad m => String -> m Exp -nP :: Monad m => String -> m Pat - -nT str = return $ VarT (mkName str) -cT str = return $ ConT (mkName str) -nE str = return $ VarE (mkName str) -nP str = return $ VarP (mkName str) -recUpdE' :: Q Exp -> Name -> Exp -> Q Exp -recUpdE' ex name assign = do - RecUpdE <$> ex <*> pure [(name, assign)] - -lookupName' :: (NameSpace, String) -> Q (Maybe Name) -lookupName' (VarName, n) = lookupValueName n -lookupName' (DataName, n) = lookupValueName n -lookupName' (TcClsName, n) = lookupTypeName n - --- Does this even make sense? -ifelseD :: Q [Dec] -> Q [Dec] -> Q [Dec] -ifelseD if_decls' else_decls = do - if_decls <- if_decls' - alreadyDefined <- definedNames (boundNames `concatMap` if_decls) - case alreadyDefined of - [] -> if_decls' - _ -> else_decls - -ifdefelseD, ifelsedefD :: String -> Q [Dec] -> Q [Dec] -> Q [Dec] -ifelsedefD = ifdefelseD -ifdefelseD ident if_decls else_decls = do - exists <- isJust <$> lookupValueName ident - if exists - then if_decls - else else_decls - -ifdefD :: String -> Q [Dec] -> Q [Dec] -ifdefD ident decls = ifdefelseD ident decls (return []) - -ifndefD :: String -> Q [Dec] -> Q [Dec] -ifndefD ident decls = ifdefelseD ident (return []) decls - --- | Each of the given declarations is only spliced if the identifier it defines --- is not defined yet. --- --- For example: --- --- @$(ifD [[d| someFunctionThatShouldExist x = x+1 |]]@ --- --- If @someFunctionThatShouldExist@ doesn't actually exist the definition given --- in the splice will be the result of the splice otherwise nothing will be --- spliced. --- --- Currently this only works for function declarations but it can be easily --- extended to other kinds of declarations. -ifD :: Q [Dec] -> Q [Dec] -ifD decls' = do - decls <- decls' - concat <$> flip mapM decls (\decl -> do - alreadyDefined <- definedNames (boundNames decl) - case alreadyDefined of - [] -> return [decl] - _ -> return []) - -definedNames :: [(NameSpace, Name)] -> Q [Name] -definedNames ns = catMaybes <$> (lookupName' . second nameBase) `mapM` ns - -boundNames :: Dec -> [(NameSpace, Name)] -boundNames decl = - case decl of - SigD n _ -> [(VarName, n)] - FunD n _cls -> [(VarName, n)] -#if __GLASGOW_HASKELL__ >= 706 - InfixD _ n -> [(VarName, n)] -#endif - ValD p _ _ -> map ((,) VarName) $ patNames p - - TySynD n _ _ -> [(TcClsName, n)] - ClassD _ n _ _ _ -> [(TcClsName, n)] - -#if __GLASGOW_HASKELL__ >= 800 - DataD _ n _ _ ctors _ -> -#else - DataD _ n _ ctors _ -> -#endif - [(TcClsName, n)] ++ map ((,) TcClsName) (conNames `concatMap` ctors) - -#if __GLASGOW_HASKELL__ >= 800 - NewtypeD _ n _ _ ctor _ -> -#else - NewtypeD _ n _ ctor _ -> -#endif - [(TcClsName, n)] ++ map ((,) TcClsName) (conNames ctor) - -#if __GLASGOW_HASKELL__ >= 800 - DataInstD _ _n _ _ ctors _ -> -#else - DataInstD _ _n _ ctors _ -> -#endif - map ((,) TcClsName) (conNames `concatMap` ctors) - -#if __GLASGOW_HASKELL__ >= 800 - NewtypeInstD _ _n _ _ ctor _ -> -#else - NewtypeInstD _ _n _ ctor _ -> -#endif - map ((,) TcClsName) (conNames ctor) - - InstanceD {} -> -- _ _ty _ - error "notcpp: Instance declarations are not supported yet" - ForeignD _ -> - error "notcpp: Foreign declarations are not supported yet" - PragmaD _pragma -> error "notcpp: pragmas are not supported yet" - -#if __GLASGOW_HASKELL__ >= 708 - TySynInstD _n _ -> error "notcpp: TySynInstD not supported yet" -#else - TySynInstD _n _ _ -> error "notcpp: TySynInstD not supported yet" -#endif - -#if __GLASGOW_HASKELL__ >= 708 - RoleAnnotD _n _ -> error "notcpp: RoleAnnotD not supported yet" -#endif - -#if __GLASGOW_HASKELL__ >= 704 && __GLASGOW_HASKELL__ < 800 - FamilyD _ n _ _ -> [(TcClsName, n)] -#elif __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 800 - ClosedTypeFamilyD n _ _ _ -> [(TcClsName, n)] -#else - OpenTypeFamilyD (TypeFamilyHead n _ _ _) -> [(TcClsName, n)] - ClosedTypeFamilyD (TypeFamilyHead n _ _ _) _ -> [(TcClsName, n)] - -#endif - -conNames :: Con -> [Name] -conNames con = - case con of - NormalC n _ -> [n] - RecC n _ -> [n] - InfixC _ n _ -> [n] - ForallC _ _ c -> conNames c - -patNames :: Pat -> [Name] -patNames p'' = - case p'' of - LitP _ -> [] - VarP n -> [n] - TupP ps -> patNames `concatMap` ps - UnboxedTupP ps -> patNames `concatMap` ps - ConP _ ps -> patNames `concatMap` ps - InfixP p _ p' -> patNames `concatMap` [p,p'] - UInfixP p _ p' -> patNames `concatMap` [p,p'] - ParensP p -> patNames p - TildeP p -> patNames p - BangP p -> patNames p - AsP n p -> n:(patNames p) - WildP -> [] - RecP _ fps -> patNames `concatMap` map snd fps - ListP ps -> patNames `concatMap` ps - SigP p _ -> patNames p - ViewP _ p -> patNames p diff --git a/NotCPP/LookupValueName.hs b/NotCPP/LookupValueName.hs deleted file mode 100644 index b12d08fc7..000000000 --- a/NotCPP/LookupValueName.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} --- | This module uses scope lookup techniques to either export --- 'lookupValueName' from @Language.Haskell.TH@, or define --- its own 'lookupValueName', which attempts to do the --- same job with just 'reify'. This will sometimes fail, but if it --- succeeds it will give the answer that the real function would have --- given. --- --- The idea is that if you use lookupValueName from this module, --- your client code will automatically use the best available name --- lookup mechanism. This means that e.g. 'scopeLookup' can work --- very well on recent GHCs and less well but still somewhat --- usefully on older GHCs. -module NotCPP.LookupValueName ( - lookupValueName - ) where - -import Language.Haskell.TH - -import NotCPP.Utils - -bestValueGuess :: String -> Q (Maybe Name) -bestValueGuess s = do - mi <- maybeReify (mkName s) - case mi of - Nothing -> no - Just i -> case i of -#if __GLASGOW_HASKELL__ >= 800 - VarI n _ _ -> yes n - DataConI n _ _ -> yes n -#else - VarI n _ _ _ -> yes n - DataConI n _ _ _ -> yes n -#endif - _ -> err ["unexpected info:", show i] - where - no = return Nothing - yes = return . Just - err = fail . showString "NotCPP.bestValueGuess: " . unwords - -$(recover [d| lookupValueName = bestValueGuess |] $ do - VarI{} <- reify (mkName "lookupValueName") - return []) diff --git a/NotCPP/OrphanEvasion.hs b/NotCPP/OrphanEvasion.hs deleted file mode 100644 index d666d7bc0..000000000 --- a/NotCPP/OrphanEvasion.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE EmptyDataDecls, TemplateHaskell #-} --- | --- The orphan instance problem is well-known in Haskell. This module --- by no means purports to solve the problem, but provides a workaround --- that may be significantly less awful than the status quo in some --- cases. --- --- Say I think that the 'Name' type should have an 'IsString' instance. --- But I don't control either the class or the type, so if I define the --- instance, and then the template-haskell package defines one, my code --- is going to break. --- --- 'safeInstance' can help me to solve this problem: --- --- > safeInstance ''IsString [t| Name |] [d| --- > fromString = mkName |] --- --- This will declare an instance only if one doesn't already exist. --- Now anyone importing your module is guaranteed to get an instance --- one way or the other. --- --- This module is still highly experimental. The example given above --- does work, but anything involving type variables or complex method --- bodies may be less fortunate. The names of the methods are mangled --- a bit, so using recursion to define them may not work. Define the --- method outside the code and then use a simple binding as above. --- --- If you use this code (successfully or unsuccessfully!), go fetch --- the maintainer address from the cabal file and let me know! -module NotCPP.OrphanEvasion ( - MultiParams, - safeInstance, - safeInstance', - ) where - -import Control.Applicative - -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - -import NotCPP.ScopeLookup - --- | An empty type used only to signify a multiparameter typeclass in --- 'safeInstance'. -data MultiParams a - --- | Given @(forall ts. Cxt => t)@, return @(Cxt, [t])@. --- Given @(forall ts. Cxt => 'MultiParams' (t1, t2, t3))@, return --- @(Cxt, [t1, t2, t3])@. --- --- This is used in 'safeInstance' to allow types to be specified more --- easily with TH typequotes. -fromTuple :: Type -> (Cxt, [Type]) -fromTuple ty = unTuple <$> case ty of - ForallT _ cxt ty' -> (cxt, ty') - _ -> ([], ty) - where - unTuple :: Type -> [Type] - unTuple (AppT (ConT n) ta) - | n == ''MultiParams = case unrollAppT ta of - (TupleT{}, ts) -> ts - _ -> [ty] - unTuple t = [t] - --- | A helper function to unwind type application. --- Given @TyCon t1 t2 t3@, returns @(TyCon, [t1,t2,t3])@ -unrollAppT :: Type -> (Type, [Type]) -unrollAppT = go [] - where - go acc (AppT tc ta) = go (ta : acc) tc - go acc ty = (ty, reverse acc) - --- | Left inverse to unrollAppT, equal to @'foldl' 'AppT'@ -rollAppT :: Type -> [Type] -> Type -rollAppT = foldl AppT - --- | @'safeInstance'' className cxt types methods@ produces an instance --- of the given class if and only if one doesn't already exist. --- --- See 'safeInstance' for a simple way to construct the 'Cxt' and --- @['Type']@ parameters. -safeInstance' :: Name -> Cxt -> [Type] -> Q [Dec] -> Q [Dec] -safeInstance' cl cxt tys inst = do - b <- $(scopeLookups ["isInstance", "isClassInstance"]) cl tys - if b - then return [] - else do - ds <- map fixInst <$> inst - return [InstanceD cxt (rollAppT (ConT cl) tys) ds] - where - fixInst (FunD n cls) = FunD (fixName n) cls - fixInst (ValD (VarP n) rhs wh) = ValD (VarP (fixName n)) rhs wh - fixInst d = d - fixName (Name n _) = Name n NameS - --- | 'safeInstance' is a more convenient version of 'safeInstance'' --- that takes the context and type from a @'Q' 'Type'@ with the intention --- that it be supplied using a type-quote. --- --- To define an instance @Show a => Show (Wrapper a)@, you'd use: --- --- > safeInstance ''Show [t| Show a => Wrapper a |] --- > [d| show _ = "stuff" |] --- --- To define an instance of a multi-param type class, use the --- 'MultiParams' type constructor with a tuple: --- --- > safeInstance ''MonadState --- > [t| MonadState s m => MultiParams (s, MaybeT m) |] --- > [d| put = ... |] -safeInstance :: Name -> Q Type -> Q [Dec] -> Q [Dec] -safeInstance n qty inst = do - (cxt, tys) <- fromTuple <$> qty - safeInstance' n cxt tys inst diff --git a/NotCPP/ScopeLookup.hs b/NotCPP/ScopeLookup.hs deleted file mode 100644 index 5fb6415c2..000000000 --- a/NotCPP/ScopeLookup.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --- | --- This module exports 'scopeLookup', which will find a variable or --- value constructor for you and present it for your use. E.g. at some --- point in the history of the acid-state package, 'openAcidState' was --- renamed 'openLocalState'; for compatibility with both, you could --- use: --- --- > openState :: IO (AcidState st) --- > openState = case $(scopeLookup "openLocalState") of --- > Just open -> open defaultState --- > Nothing -> case $(scopeLookup "openAcidState") of --- > Just open -> open defaultState --- > Nothing -> error --- > "openState: runtime name resolution has its drawbacks :/" --- --- Or, for this specific case, you can use 'scopeLookups': --- --- > openState :: IO (AcidState st) --- > openState = open defaultState --- > where --- > open = $(scopeLookups ["openLocalState","openAcidState"]) --- --- Now if neither of the names are found then TH will throw a --- compile-time error. -module NotCPP.ScopeLookup ( - scopeLookup, - scopeLookups, - scopeLookup', - liftMaybe, - recoverMaybe, - maybeReify, - infoToExp, - ) where - -import Control.Applicative ((<$>)) - -import Language.Haskell.TH (Q, Exp, recover, reify) - -import NotCPP.LookupValueName -import NotCPP.Utils - --- | Produces a spliceable expression which expands to @'Just' val@ if --- the given string refers to a value @val@ in scope, or 'Nothing' --- otherwise. --- --- @scopeLookup = 'fmap' 'liftMaybe' . 'scopeLookup''@ -scopeLookup :: String -> Q Exp -scopeLookup = fmap liftMaybe . scopeLookup' - --- | Finds the first string in the list that names a value, and produces --- a spliceable expression of that value, or reports a compile error if --- it fails. -scopeLookups :: [String] -> Q Exp -scopeLookups xs = foldr - (\s r -> maybe r return =<< scopeLookup' s) - (fail ("scopeLookups: none found: " ++ show xs)) - xs - --- | Produces @'Just' x@ if the given string names the value @x@, --- or 'Nothing' otherwise. -scopeLookup' :: String -> Q (Maybe Exp) -scopeLookup' s = recover (return Nothing) $ do - Just n <- lookupValueName s - infoToExp <$> reify n diff --git a/NotCPP/Utils.hs b/NotCPP/Utils.hs deleted file mode 100644 index d25b63767..000000000 --- a/NotCPP/Utils.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -module NotCPP.Utils where - -import Control.Applicative ((<$>)) -import Language.Haskell.TH - --- | Turns 'Nothing' into an expression representing 'Nothing', and --- @'Just' x@ into an expression representing 'Just' applied to the --- expression in @x@. -liftMaybe :: Maybe Exp -> Exp -liftMaybe = maybe (ConE 'Nothing) (AppE (ConE 'Just)) - --- | A useful variant of 'reify' that returns 'Nothing' instead of --- halting compilation when an error occurs (e.g. because the given --- name was not in scope). -maybeReify :: Name -> Q (Maybe Info) -maybeReify = recoverMaybe . reify - --- | Turns a possibly-failing 'Q' action into one returning a 'Maybe' --- value. -recoverMaybe :: Q a -> Q (Maybe a) -recoverMaybe q = recover (return Nothing) (Just <$> q) - --- | Returns @'Just' ('VarE' n)@ if the info relates to a value called --- @n@, or 'Nothing' if it relates to a different sort of thing. -infoToExp :: Info -> Maybe Exp -#if __GLASGOW_HASKELL__ >= 800 -infoToExp (VarI n _ _) = Just (VarE n) -infoToExp (DataConI n _ _) = Just (ConE n) -#else -infoToExp (VarI n _ _ _) = Just (VarE n) -infoToExp (DataConI n _ _ _) = Just (ConE n) -#endif -infoToExp _ = Nothing diff --git a/ghc-mod.cabal b/ghc-mod.cabal index c47641c8f..915d2c18f 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -29,10 +29,7 @@ Cabal-Version: >= 1.18 Build-Type: Custom Data-Files: elisp/Makefile elisp/*.el -Data-Files: LICENSE COPYING.BSD3 COPYING.AGPL3 Extra-Source-Files: ChangeLog - NotCPP/*.hs - NotCPP/COPYING core/Language/Haskell/GhcMod/Monad/Compat.hs_h test/data/annotations/*.hs test/data/broken-cabal/*.cabal