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