{-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances, PatternSynonyms #-}
module GHC.Util.View (
fromParen
, View(..)
, Var_(Var_), PVar_(PVar_), PApp_(PApp_), App2(App2),LamConst1(LamConst1)
, pattern SimpleLambda
) where
import GHC.Hs
import SrcLoc
import BasicTypes
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
fromParen :: LHsExpr GhcPs -> LHsExpr GhcPs
fromParen (L _ (HsPar _ x)) = fromParen x
fromParen x = x
fromPParen :: LPat GhcPs -> LPat GhcPs
fromPParen (L _ (ParPat _ x)) = fromPParen x
fromPParen x = x
class View a b where
view :: a -> b
data Var_ = NoVar_ | Var_ String deriving Eq
data PVar_ = NoPVar_ | PVar_ String
data PApp_ = NoPApp_ | PApp_ String [LPat GhcPs]
data App2 = NoApp2 | App2 (LHsExpr GhcPs) (LHsExpr GhcPs) (LHsExpr GhcPs)
data LamConst1 = NoLamConst1 | LamConst1 (LHsExpr GhcPs)
instance View (LHsExpr GhcPs) LamConst1 where
view (fromParen -> (L _ (HsLam _ (MG _ (L _ [L _ (Match _ LambdaExpr [L _ WildPat {}]
(GRHSs _ [L _ (GRHS _ [] x)] (L _ (EmptyLocalBinds _))))]) FromSource)))) = LamConst1 x
view _ = NoLamConst1
instance View (LHsExpr GhcPs) Var_ where
view (fromParen -> (L _ (HsVar _ (rdrNameStr -> x)))) = Var_ x
view _ = NoVar_
instance View (LHsExpr GhcPs) App2 where
view (fromParen -> L _ (OpApp _ lhs op rhs)) = App2 op lhs rhs
view (fromParen -> L _ (HsApp _ (L _ (HsApp _ f x)) y)) = App2 f x y
view _ = NoApp2
instance View (Located (Pat GhcPs)) PVar_ where
view (fromPParen -> L _ (VarPat _ (L _ x))) = PVar_ $ occNameStr x
view _ = NoPVar_
instance View (Located (Pat GhcPs)) PApp_ where
view (fromPParen -> L _ (ConPatIn (L _ x) (PrefixCon args))) =
PApp_ (occNameStr x) args
view (fromPParen -> L _ (ConPatIn (L _ x) (InfixCon lhs rhs))) =
PApp_ (occNameStr x) [lhs, rhs]
view _ = NoPApp_
pattern SimpleLambda :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
pattern SimpleLambda vs body <- L _ (HsLam _ (MG _ (L _ [L _ (Match _ _ vs (GRHSs _ [L _ (GRHS _ [] body)] (L _ (EmptyLocalBinds _))))]) _))