1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188
|
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- 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 <http://www.gnu.org/licenses/>.
{-# 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
|