Remove NotCPP code (not used by Setup.hs anymore)
This commit is contained in:
Daniel Gröber
parent
26730126ca
commit
3f98bdfb31
@ -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.
|
|
||||||
@ -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 [])
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
@ -29,10 +29,7 @@ Cabal-Version: >= 1.18
|
|||||||
Build-Type: Custom
|
Build-Type: Custom
|
||||||
Data-Files: elisp/Makefile
|
Data-Files: elisp/Makefile
|
||||||
elisp/*.el
|
elisp/*.el
|
||||||
Data-Files: LICENSE COPYING.BSD3 COPYING.AGPL3
|
|
||||||
Extra-Source-Files: ChangeLog
|
Extra-Source-Files: ChangeLog
|
||||||
NotCPP/*.hs
|
|
||||||
NotCPP/COPYING
|
|
||||||
core/Language/Haskell/GhcMod/Monad/Compat.hs_h
|
core/Language/Haskell/GhcMod/Monad/Compat.hs_h
|
||||||
test/data/annotations/*.hs
|
test/data/annotations/*.hs
|
||||||
test/data/broken-cabal/*.cabal
|
test/data/broken-cabal/*.cabal
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user