{-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances #-} module HSE.Match where import Data.Char import HSE.Type import HSE.Util import qualified Language.Haskell.Exts as HSE_ class View a b where view :: a -> b data App2 = NoApp2 | App2 Exp_ Exp_ Exp_ deriving Show instance View Exp_ App2 where view (fromParen -> InfixApp _ lhs op rhs) = App2 (opExp op) lhs rhs view (fromParen -> App _ (fromParen -> App _ f x) y) = App2 f x y view _ = NoApp2 data App1 = NoApp1 | App1 Exp_ Exp_ deriving Show instance View Exp_ App1 where view (fromParen -> App _ f x) = App1 f x view _ = NoApp1 data PVar_ = NoPVar_ | PVar_ String instance View Pat_ PVar_ where view (fromPParen -> PVar _ x) = PVar_ $ fromNamed x view _ = NoPVar_ data Var_ = NoVar_ | Var_ String deriving Eq instance View Exp_ Var_ where view (fromParen -> Var _ (UnQual _ x)) = Var_ $ fromNamed x view _ = NoVar_ (~=) :: Named a => a -> String -> Bool (~=) = (==) . fromNamed -- | fromNamed will return \"\" when it cannot be represented -- toNamed may crash on \"\" class Named a where toNamed :: String -> a fromNamed :: a -> String isCtor (x:_) = isUpper x || x == ':' isCtor _ = False isSym (x:_) = not $ isAlpha x || x `elem` "_'" isSym _ = False instance Named (Exp S) where fromNamed (Var _ x) = fromNamed x fromNamed (Con _ x) = fromNamed x fromNamed (List _ []) = "[]" fromNamed _ = "" toNamed "[]" = List an [] toNamed x | isCtor x = Con an $ toNamed x | otherwise = Var an $ toNamed x instance Named (QName S) where fromNamed (Special _ Cons{}) = ":" fromNamed (Special _ UnitCon{}) = "()" fromNamed (UnQual _ x) = fromNamed x fromNamed _ = "" toNamed ":" = Special an $ Cons an toNamed x = UnQual an $ toNamed x instance Named HSE_.QName where fromNamed (HSE_.Special HSE_.Cons) = ":" fromNamed (HSE_.Special HSE_.UnitCon) = "()" fromNamed (HSE_.UnQual x) = fromNamed x fromNamed _ = "" toNamed ":" = HSE_.Special HSE_.Cons toNamed x = HSE_.UnQual $ toNamed x instance Named (Name S) where fromNamed (Ident _ x) = x fromNamed (Symbol _ x) = x toNamed x | isSym x = Symbol an x | otherwise = Ident an x instance Named HSE_.Name where fromNamed (HSE_.Ident x) = x fromNamed (HSE_.Symbol x) = x toNamed x | isSym x = HSE_.Symbol x | otherwise = HSE_.Ident x instance Named (ModuleName S) where fromNamed (ModuleName _ x) = x toNamed = ModuleName an instance Named (Pat S) where fromNamed (PVar _ x) = fromNamed x fromNamed (PApp _ x []) = fromNamed x fromNamed _ = "" toNamed x | isCtor x = PApp an (toNamed x) [] | otherwise = PVar an $ toNamed x instance Named (TyVarBind S) where fromNamed (KindedVar _ x _) = fromNamed x fromNamed (UnkindedVar _ x) = fromNamed x toNamed x = UnkindedVar an (toNamed x) instance Named (QOp S) where fromNamed (QVarOp _ x) = fromNamed x fromNamed (QConOp _ x) = fromNamed x toNamed x | isCtor x = QConOp an $ toNamed x | otherwise = QVarOp an $ toNamed x instance Named (Match S) where fromNamed (Match _ x _ _ _) = fromNamed x fromNamed (InfixMatch _ _ x _ _ _) = fromNamed x toNamed = error "No toNamed for Match" instance Named (DeclHead S) where fromNamed (DHead _ x _) = fromNamed x fromNamed (DHInfix _ _ x _) = fromNamed x fromNamed (DHParen _ x) = fromNamed x toNamed = error "No toNamed for DeclHead" instance Named (Decl S) where fromNamed (TypeDecl _ name _) = fromNamed name fromNamed (DataDecl _ _ _ name _ _) = fromNamed name fromNamed (GDataDecl _ _ _ name _ _ _) = fromNamed name fromNamed (TypeFamDecl _ name _) = fromNamed name fromNamed (DataFamDecl _ _ name _) = fromNamed name fromNamed (ClassDecl _ _ name _ _) = fromNamed name fromNamed (PatBind _ (PVar _ name) _ _ _) = fromNamed name fromNamed (FunBind _ (name:_)) = fromNamed name fromNamed (ForImp _ _ _ _ name _) = fromNamed name fromNamed (ForExp _ _ _ name _) = fromNamed name fromNamed (TypeSig _ (name:_) _) = fromNamed name fromNamed _ = "" toNamed = error "No toNamed for Decl"