Delete leftover NotCPP file
This commit is contained in:
Daniel Gröber
parent
d16e0ade07
commit
07dcabdbb3
@ -1,188 +0,0 @@
|
|||||||
-- ghc-mod: Happy Haskell Hacking
|
|
||||||
-- 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
|
|
||||||
Loading…
Reference in New Issue
Block a user