1-- Copyright 2019 Google LLC
2--
3-- Use of this source code is governed by a BSD-style
4-- license that can be found in the LICENSE file or at
5-- https://developers.google.com/open-source/licenses/bsd
6
7-- | This module provides combinators for constructing Haskell declarations.
8module GHC.SourceGen.Binds
9    (  -- * Bindings
10      HsBind'
11    , HasValBind
12      -- * Type signatures
13    , typeSig
14    , typeSigs
15      -- * Functions
16    , funBind
17    , funBinds
18    , funBindsWithFixity
19      -- * Values
20    , valBind
21    , valBindGRHSs
22    -- ** Patterns
23    , HasPatBind
24    , patBind
25    , patBindGRHSs
26    -- * Matches
27    -- $rawMatch
28    , RawMatch
29    , match
30    , matchGRHSs
31    -- * Right-hand sides
32    , RawGRHSs
33    , rhs
34    -- ** Guards
35    , guardedRhs
36    , GuardedExpr
37    , GRHS'
38    , guards
39    , guard
40    -- ** Where clauses
41    , where'
42    , RawValBind
43    -- * Statements
44    , stmt
45    , (<--)
46    ) where
47
48import BasicTypes (LexicalFixity(..))
49import Data.Bool (bool)
50import Data.Maybe (fromMaybe)
51import GHC.Hs.Binds
52import GHC.Hs.Expr
53import GHC.Hs.Types
54import GhcPlugins (isSymOcc)
55import TcEvidence (HsWrapper(WpHole))
56
57import GHC.SourceGen.Binds.Internal
58import GHC.SourceGen.Name
59import GHC.SourceGen.Name.Internal
60import GHC.SourceGen.Syntax.Internal
61import GHC.SourceGen.Type.Internal (sigWcType)
62
63-- | Declares the type of multiple functions or values.
64--
65-- > f, g :: A
66-- > =====
67-- > typeSigs ["f", "g"] (var "A")
68typeSigs :: HasValBind t => [OccNameStr] -> HsType' -> t
69typeSigs names t =
70    sigB $ noExt TypeSig (map (typeRdrName . unqual) names)
71        $ sigWcType t
72
73-- | Declares the type of a single function or value.
74--
75-- > f :: A
76-- > =====
77-- > typeSig "f" (var "A")
78typeSig :: HasValBind t => OccNameStr -> HsType' -> t
79typeSig n = typeSigs [n]
80
81-- | Defines a function or value, with an explicit fixity. When given
82-- 'Nothing', use infix notation iff the given name is symbolic.
83--
84-- > id x = x
85-- > =====
86-- > funBindsWithFixity (Just Prefix) "id" [match [var "x"] (var "x")]
87--
88-- > True && True = True
89-- > True && False = False
90-- > =====
91-- > funBindsWithFixity Nothing "not"
92-- >   [ match [conP "True" []] (var "False")
93-- >   , match [conP "False" []] (var "True")
94-- >   ]
95funBindsWithFixity :: HasValBind t => Maybe LexicalFixity -> OccNameStr -> [RawMatch] -> t
96funBindsWithFixity fixity name matches = bindB $ withPlaceHolder
97        (noExt FunBind name'
98            (matchGroup context matches) WpHole)
99        []
100  where
101    name' = valueRdrName $ unqual name
102    occ = valueOccName name
103    fixity' = fromMaybe (bool Prefix Infix $ isSymOcc occ) fixity
104    context = FunRhs name' fixity' NoSrcStrict
105
106-- | Defines a function or value.
107--
108-- > f = x
109-- > =====
110-- > funBinds "f" [match [] "x"]
111--
112-- > id x = x
113-- > =====
114-- > funBinds "id" [match [var "x"] (var "x")]
115--
116-- > not True = False
117-- > not False = True
118-- > =====
119-- > funBinds "not"
120-- >   [ match [conP "True" []] (var "False")
121-- >   , match [conP "False" []] (var "True")
122-- >   ]
123funBinds :: HasValBind t => OccNameStr -> [RawMatch] -> t
124funBinds = funBindsWithFixity (Just Prefix)
125
126-- | Defines a function that has a single case.
127--
128-- > f = x
129-- > =====
130-- > funBind "f" (match [] "x")
131--
132-- > id x = x
133-- > =====
134-- > funBind "id" $ match [bvar "x"] (var "x")
135--
136funBind :: HasValBind t => OccNameStr -> RawMatch -> t
137funBind name m = funBinds name [m]
138
139-- | Defines a value consisting of multiple guards.
140--
141-- The resulting syntax is the same as a function with no arguments.
142--
143-- > x
144-- >   | test = 1
145-- >   | otherwise = 2
146-- > =====
147-- > valBindGRHSs "x"
148-- >   $ guardedRhs
149-- >       [ var "test" `guard` int 1
150-- >       , var "otherwise" `guard` int 2
151-- >       ]
152valBindGRHSs :: HasValBind t => OccNameStr -> RawGRHSs -> t
153valBindGRHSs name = funBind name . matchGRHSs []
154
155-- | Defines a value without any guards.
156--
157-- The resulting syntax is the same as a function with no arguments.
158--
159-- > x = y
160-- > =====
161-- > valBind "x" $ var "y"
162valBind :: HasValBind t => OccNameStr -> HsExpr' -> t
163valBind name = valBindGRHSs name . rhs
164
165-- | Defines a pattern binding consisting of multiple guards.
166--
167-- > (x, y)
168-- >   | test = (1, 2)
169-- >   | otherwise = (2, 3)
170-- > =====
171-- > patBindGrhs (tuple [bvar "x", bvar "y"])
172-- >   $ guardedRhs
173-- >       [ var "test" `guard` tuple [int 1, int 2]
174-- >       , var "otherwise" `guard` [int 2, int 3]
175-- >       ]
176patBindGRHSs :: HasPatBind t => Pat' -> RawGRHSs -> t
177patBindGRHSs p g =
178    bindB
179        $ withPlaceHolder
180            (withPlaceHolder
181                (noExt PatBind (builtPat p) (mkGRHSs g)))
182        $ ([],[])
183
184-- | Defines a pattern binding without any guards.
185--
186-- > (x, y) = e
187-- > =====
188-- > patBind (tuple [bvar "x", bvar "y"]) e
189patBind :: HasPatBind t => Pat' -> HsExpr' -> t
190patBind p = patBindGRHSs p . rhs
191
192{- $rawMatch
193
194A function definition is made up of one or more 'RawMatch' terms.  Each
195'RawMatch' corresponds to a single pattern match.  For example, to define the
196"not" function:
197
198> not True = False
199> not False = True
200
201We could using a list of two 'RawMatch'es:
202
203> funBinds "not"
204>   [ match [conP "True" []] (var "False")
205>   , match [conP "False" [] (var "True")
206>   ]
207
208A match may consist of one or more guarded expressions.  For example, to
209define the function as:
210
211> not x
212>   | x = False
213>   | otherwise = True
214
215We would say:
216
217> funBind "not"
218>      $ matchGRHSs [bvar "x"] $ guardedRhs
219>          [ guard (var "x") (var "False")
220>          , guard (var "otherwise") (var "True")
221>          ]
222-}
223
224-- | A function match consisting of multiple guards.
225matchGRHSs :: [Pat'] -> RawGRHSs -> RawMatch
226matchGRHSs = RawMatch
227
228-- | A function match with a single case.
229match :: [Pat'] -> HsExpr' -> RawMatch
230match ps = matchGRHSs ps . rhs
231
232-- | Adds a "where" clause to an existing 'RawGRHSs'.
233--
234-- > f x = y
235-- >   where y = x
236-- > =====
237-- > funBind "x"
238-- >   $ matchGRHSs [bvar "x"]
239-- >   $ rhs (var "y")
240-- >      `where` [valBind "y" $ var "x']
241where' :: RawGRHSs -> [RawValBind] -> RawGRHSs
242where' r vbs = r { rawGRHSWhere = rawGRHSWhere r ++ vbs }
243
244-- | A right-hand side of a match, with no guards.
245rhs :: HsExpr' -> RawGRHSs
246rhs e = guardedRhs [guards [] e]
247
248-- | A guarded right-hand side of a match.
249--
250-- >   | x = False
251-- >   | otherwise = True
252-- > =====
253-- > guardedRhs
254-- >   [ guard (var "x") (var "False")
255-- >   , guard (var "otherwise") (var "True")
256-- >   ]
257guardedRhs :: [GuardedExpr] -> RawGRHSs
258guardedRhs ss = RawGRHSs ss []
259
260-- | An expression guarded by a single boolean statement.
261--
262-- >   | otherwise = ()
263-- > =====
264-- > guard (var "otherwise") unit
265guard :: HsExpr' -> HsExpr' -> GuardedExpr
266guard s = guards [stmt s]
267
268-- | An expression guarded by multiple statements, using the @PatternGuards@ extension.
269--
270-- >   | Just y <- x, y = ()
271-- > =====
272-- > guards [conP "Just" (bvar "x") <-- var "y", bvar "x"] unit
273guards :: [Stmt'] -> HsExpr' -> GuardedExpr
274guards stmts e = noExt GRHS (map builtLoc stmts) (builtLoc e)
275
276-- | An expression statement.  May be used in a do expression (with 'do'') or in a
277-- match (with 'guard').
278--
279-- TODO: also allow using statements in list comprehensions.
280stmt :: HsExpr' -> Stmt'
281-- For now, don't worry about rebindable syntax.
282stmt e =
283    withPlaceHolder $ noExt BodyStmt (builtLoc e) noSyntaxExpr noSyntaxExpr
284
285-- | A statement that binds a pattern.
286--
287-- > x <- act
288-- > =====
289-- > bvar "x" <-- var "act"
290(<--) :: Pat' -> HsExpr' -> Stmt'
291p <-- e = withPlaceHolder $ noExt BindStmt (builtPat p) (builtLoc e) noSyntaxExpr noSyntaxExpr
292infixl 1 <--
293
294-- | Syntax types which can declare/define pattern bindings.
295-- For example: declarations at the top-level or in let/where clauses.
296--
297-- Note: this class is more restrictive than 'HasValBind' since pattern
298-- bindings cannot be used in class or instance declarations.
299class HasValBind t => HasPatBind t where
300
301instance HasPatBind RawValBind where
302instance HasPatBind HsDecl' where
303