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
|
||||
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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user