{-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances #-}
module HSE.Match(
View(..), Named(..),
(~=), isSym,
App2(App2), PVar_(PVar_), Var_(Var_)
) where
import Data.Char
import HSE.Type
import HSE.Util
class View a b where
view :: a -> b
data App2 = NoApp2 | App2 Exp_ Exp_ Exp_ deriving Int -> App2 -> ShowS
[App2] -> ShowS
App2 -> String
(Int -> App2 -> ShowS)
-> (App2 -> String) -> ([App2] -> ShowS) -> Show App2
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [App2] -> ShowS
$cshowList :: [App2] -> ShowS
show :: App2 -> String
$cshow :: App2 -> String
showsPrec :: Int -> App2 -> ShowS
$cshowsPrec :: Int -> App2 -> ShowS
Show
instance View Exp_ App2 where
view :: Exp_ -> App2
view (Exp_ -> Exp_
fromParen -> InfixApp _ lhs :: Exp_
lhs op :: QOp S
op rhs :: Exp_
rhs) = Exp_ -> Exp_ -> Exp_ -> App2
App2 (QOp S -> Exp_
opExp QOp S
op) Exp_
lhs Exp_
rhs
view (Exp_ -> Exp_
fromParen -> App _ (Exp_ -> Exp_
fromParen -> App _ f :: Exp_
f x :: Exp_
x) y :: Exp_
y) = Exp_ -> Exp_ -> Exp_ -> App2
App2 Exp_
f Exp_
x Exp_
y
view _ = App2
NoApp2
data App1 = NoApp1 | App1 Exp_ Exp_ deriving Int -> App1 -> ShowS
[App1] -> ShowS
App1 -> String
(Int -> App1 -> ShowS)
-> (App1 -> String) -> ([App1] -> ShowS) -> Show App1
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [App1] -> ShowS
$cshowList :: [App1] -> ShowS
show :: App1 -> String
$cshow :: App1 -> String
showsPrec :: Int -> App1 -> ShowS
$cshowsPrec :: Int -> App1 -> ShowS
Show
instance View Exp_ App1 where
view :: Exp_ -> App1
view (Exp_ -> Exp_
fromParen -> App _ f :: Exp_
f x :: Exp_
x) = Exp_ -> Exp_ -> App1
App1 Exp_
f Exp_
x
view _ = App1
NoApp1
data PVar_ = NoPVar_ | PVar_ String
instance View Pat_ PVar_ where
view :: Pat_ -> PVar_
view (Pat_ -> Pat_
forall s. Pat s -> Pat s
fromPParen -> PVar _ x :: Name S
x) = String -> PVar_
PVar_ (String -> PVar_) -> String -> PVar_
forall a b. (a -> b) -> a -> b
$ Name S -> String
forall a. Named a => a -> String
fromNamed Name S
x
view _ = PVar_
NoPVar_
data Var_ = NoVar_ | Var_ String deriving Var_ -> Var_ -> Bool
(Var_ -> Var_ -> Bool) -> (Var_ -> Var_ -> Bool) -> Eq Var_
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Var_ -> Var_ -> Bool
$c/= :: Var_ -> Var_ -> Bool
== :: Var_ -> Var_ -> Bool
$c== :: Var_ -> Var_ -> Bool
Eq
instance View Exp_ Var_ where
view :: Exp_ -> Var_
view (Exp_ -> Exp_
fromParen -> Var _ (UnQual _ x :: Name S
x)) = String -> Var_
Var_ (String -> Var_) -> String -> Var_
forall a b. (a -> b) -> a -> b
$ Name S -> String
forall a. Named a => a -> String
fromNamed Name S
x
view _ = Var_
NoVar_
(~=) :: Named a => a -> String -> Bool
~= :: a -> String -> Bool
(~=) = String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==) (String -> String -> Bool) -> (a -> String) -> a -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Named a => a -> String
fromNamed
class Named a where
toNamed :: String -> a
fromNamed :: a -> String
isCtor :: String -> Bool
isCtor (x :: Char
x:_) = Char -> Bool
isUpper Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ':'
isCtor _ = Bool
False
isSym :: String -> Bool
isSym (x :: Char
x:_) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isAlpha Char
x Bool -> Bool -> Bool
|| Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` "_'"
isSym _ = Bool
False
instance Named (Exp S) where
fromNamed :: Exp_ -> String
fromNamed (Var _ x :: QName S
x) = QName S -> String
forall a. Named a => a -> String
fromNamed QName S
x
fromNamed (Con _ x :: QName S
x) = QName S -> String
forall a. Named a => a -> String
fromNamed QName S
x
fromNamed (List _ []) = "[]"
fromNamed _ = ""
toNamed :: String -> Exp_
toNamed "[]" = S -> [Exp_] -> Exp_
forall l. l -> [Exp l] -> Exp l
List S
an []
toNamed x :: String
x | String -> Bool
isCtor String
x = S -> QName S -> Exp_
forall l. l -> QName l -> Exp l
Con S
an (QName S -> Exp_) -> QName S -> Exp_
forall a b. (a -> b) -> a -> b
$ String -> QName S
forall a. Named a => String -> a
toNamed String
x
| Bool
otherwise = S -> QName S -> Exp_
forall l. l -> QName l -> Exp l
Var S
an (QName S -> Exp_) -> QName S -> Exp_
forall a b. (a -> b) -> a -> b
$ String -> QName S
forall a. Named a => String -> a
toNamed String
x
instance Named (QName S) where
fromNamed :: QName S -> String
fromNamed (Special _ Cons{}) = ":"
fromNamed (Special _ UnitCon{}) = "()"
fromNamed (UnQual _ x :: Name S
x) = Name S -> String
forall a. Named a => a -> String
fromNamed Name S
x
fromNamed _ = ""
toNamed :: String -> QName S
toNamed ":" = S -> SpecialCon S -> QName S
forall l. l -> SpecialCon l -> QName l
Special S
an (SpecialCon S -> QName S) -> SpecialCon S -> QName S
forall a b. (a -> b) -> a -> b
$ S -> SpecialCon S
forall l. l -> SpecialCon l
Cons S
an
toNamed x :: String
x = S -> Name S -> QName S
forall l. l -> Name l -> QName l
UnQual S
an (Name S -> QName S) -> Name S -> QName S
forall a b. (a -> b) -> a -> b
$ String -> Name S
forall a. Named a => String -> a
toNamed String
x
instance Named (Name S) where
fromNamed :: Name S -> String
fromNamed (Ident _ x :: String
x) = String
x
fromNamed (Symbol _ x :: String
x) = String
x
toNamed :: String -> Name S
toNamed x :: String
x | String -> Bool
isSym String
x = S -> String -> Name S
forall l. l -> String -> Name l
Symbol S
an String
x
| Bool
otherwise = S -> String -> Name S
forall l. l -> String -> Name l
Ident S
an String
x
instance Named (ModuleName S) where
fromNamed :: ModuleName S -> String
fromNamed (ModuleName _ x :: String
x) = String
x
toNamed :: String -> ModuleName S
toNamed = S -> String -> ModuleName S
forall l. l -> String -> ModuleName l
ModuleName S
an
instance Named (Pat S) where
fromNamed :: Pat_ -> String
fromNamed (PVar _ x :: Name S
x) = Name S -> String
forall a. Named a => a -> String
fromNamed Name S
x
fromNamed (PApp _ x :: QName S
x []) = QName S -> String
forall a. Named a => a -> String
fromNamed QName S
x
fromNamed (PList _ []) = "[]"
fromNamed _ = ""
toNamed :: String -> Pat_
toNamed x :: String
x | String -> Bool
isCtor String
x = S -> QName S -> [Pat_] -> Pat_
forall l. l -> QName l -> [Pat l] -> Pat l
PApp S
an (String -> QName S
forall a. Named a => String -> a
toNamed String
x) []
| Bool
otherwise = S -> Name S -> Pat_
forall l. l -> Name l -> Pat l
PVar S
an (Name S -> Pat_) -> Name S -> Pat_
forall a b. (a -> b) -> a -> b
$ String -> Name S
forall a. Named a => String -> a
toNamed String
x
instance Named (TyVarBind S) where
fromNamed :: TyVarBind S -> String
fromNamed (KindedVar _ x :: Name S
x _) = Name S -> String
forall a. Named a => a -> String
fromNamed Name S
x
fromNamed (UnkindedVar _ x :: Name S
x) = Name S -> String
forall a. Named a => a -> String
fromNamed Name S
x
toNamed :: String -> TyVarBind S
toNamed x :: String
x = S -> Name S -> TyVarBind S
forall l. l -> Name l -> TyVarBind l
UnkindedVar S
an (String -> Name S
forall a. Named a => String -> a
toNamed String
x)
instance Named (QOp S) where
fromNamed :: QOp S -> String
fromNamed (QVarOp _ x :: QName S
x) = QName S -> String
forall a. Named a => a -> String
fromNamed QName S
x
fromNamed (QConOp _ x :: QName S
x) = QName S -> String
forall a. Named a => a -> String
fromNamed QName S
x
toNamed :: String -> QOp S
toNamed x :: String
x | String -> Bool
isCtor String
x = S -> QName S -> QOp S
forall l. l -> QName l -> QOp l
QConOp S
an (QName S -> QOp S) -> QName S -> QOp S
forall a b. (a -> b) -> a -> b
$ String -> QName S
forall a. Named a => String -> a
toNamed String
x
| Bool
otherwise = S -> QName S -> QOp S
forall l. l -> QName l -> QOp l
QVarOp S
an (QName S -> QOp S) -> QName S -> QOp S
forall a b. (a -> b) -> a -> b
$ String -> QName S
forall a. Named a => String -> a
toNamed String
x
instance Named (Match S) where
fromNamed :: Match S -> String
fromNamed (Match _ x :: Name S
x _ _ _) = Name S -> String
forall a. Named a => a -> String
fromNamed Name S
x
fromNamed (InfixMatch _ _ x :: Name S
x _ _ _) = Name S -> String
forall a. Named a => a -> String
fromNamed Name S
x
toNamed :: String -> Match S
toNamed = String -> String -> Match S
forall a. HasCallStack => String -> a
error "No toNamed for Match"
instance Named (DeclHead S) where
fromNamed :: DeclHead S -> String
fromNamed (DHead _ x :: Name S
x) = Name S -> String
forall a. Named a => a -> String
fromNamed Name S
x
fromNamed (DHInfix _ _ x :: Name S
x) = Name S -> String
forall a. Named a => a -> String
fromNamed Name S
x
fromNamed (DHParen _ x :: DeclHead S
x) = DeclHead S -> String
forall a. Named a => a -> String
fromNamed DeclHead S
x
fromNamed (DHApp _ x :: DeclHead S
x _) = DeclHead S -> String
forall a. Named a => a -> String
fromNamed DeclHead S
x
toNamed :: String -> DeclHead S
toNamed = String -> String -> DeclHead S
forall a. HasCallStack => String -> a
error "No toNamed for DeclHead"
instance Named (Decl S) where
fromNamed :: Decl S -> String
fromNamed (TypeDecl _ name :: DeclHead S
name _) = DeclHead S -> String
forall a. Named a => a -> String
fromNamed DeclHead S
name
fromNamed (DataDecl _ _ _ name :: DeclHead S
name _ _) = DeclHead S -> String
forall a. Named a => a -> String
fromNamed DeclHead S
name
fromNamed (GDataDecl _ _ _ name :: DeclHead S
name _ _ _) = DeclHead S -> String
forall a. Named a => a -> String
fromNamed DeclHead S
name
fromNamed (TypeFamDecl _ name :: DeclHead S
name _ _) = DeclHead S -> String
forall a. Named a => a -> String
fromNamed DeclHead S
name
fromNamed (DataFamDecl _ _ name :: DeclHead S
name _) = DeclHead S -> String
forall a. Named a => a -> String
fromNamed DeclHead S
name
fromNamed (ClassDecl _ _ name :: DeclHead S
name _ _) = DeclHead S -> String
forall a. Named a => a -> String
fromNamed DeclHead S
name
fromNamed (PatBind _ (PVar _ name :: Name S
name) _ _) = Name S -> String
forall a. Named a => a -> String
fromNamed Name S
name
fromNamed (FunBind _ (name :: Match S
name:_)) = Match S -> String
forall a. Named a => a -> String
fromNamed Match S
name
fromNamed (ForImp _ _ _ _ name :: Name S
name _) = Name S -> String
forall a. Named a => a -> String
fromNamed Name S
name
fromNamed (ForExp _ _ _ name :: Name S
name _) = Name S -> String
forall a. Named a => a -> String
fromNamed Name S
name
fromNamed (TypeSig _ (name :: Name S
name:_) _) = Name S -> String
forall a. Named a => a -> String
fromNamed Name S
name
fromNamed _ = ""
toNamed :: String -> Decl S
toNamed = String -> String -> Decl S
forall a. HasCallStack => String -> a
error "No toNamed for Decl"