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