File: Declarations.hs

package info (click to toggle)
ghc-mod 5.6.0.0-2
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 1,216 kB
  • ctags: 240
  • sloc: haskell: 8,323; lisp: 1,557; makefile: 40; sh: 34
file content (188 lines) | stat: -rw-r--r-- 6,010 bytes parent folder | download
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