{-# 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 RdrName
import OccName
import BasicTypes
import GHC.Util.RdrName (rdrNameStr')
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_' $ occNameString (rdrNameOcc x)
view' _ = NoPVar_'
instance View' (Located (Pat GhcPs)) PApp_' where
view' (fromPParen' -> L _ (ConPatIn (L _ x) (PrefixCon args))) =
PApp_' (occNameString . rdrNameOcc $ x) args
view' (fromPParen' -> L _ (ConPatIn (L _ x) (InfixCon lhs rhs))) =
PApp_' (occNameString . rdrNameOcc $ 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 _))))]) _))