{-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances, PatternSynonyms #-}

module GHC.Util.View (
   fromParen
  , View(..)
  , RdrName_(RdrName_), Var_(Var_), PVar_(PVar_), PApp_(PApp_), App2(App2),LamConst1(LamConst1)
  , pattern SimpleLambda
) where

import GHC.Hs
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Types.Basic
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
import GHC.Util.Brackets

fromParen :: LHsExpr GhcPs -> LHsExpr GhcPs
fromParen x = maybe x fromParen $ remParen x

fromPParen :: LPat GhcPs -> LPat GhcPs
fromPParen (L _ (ParPat _ x)) = fromPParen x
fromPParen x = x

class View a b where
  view :: a -> b

data RdrName_ = NoRdrName_ | RdrName_ (Located RdrName)
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) RdrName_ where
    view (fromParen -> (L _ (HsVar _ name))) = RdrName_ name
    view _ = NoRdrName_

instance View (LHsExpr GhcPs) Var_ where
    view (view -> RdrName_ name) = Var_ (rdrNameStr name)
    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 _ (ConPat _ (L _ x) (PrefixCon args))) =
    PApp_ (occNameStr x) args
  view (fromPParen -> L _ (ConPat _ (L _ x) (InfixCon lhs rhs))) =
    PApp_ (occNameStr x) [lhs, rhs]
  view _ = NoPApp_

-- A lambda with no guards and no where clauses
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 _))))]) _))