{-# 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


-- | fromNamed will return \"\" when it cannot be represented
--   toNamed may crash on \"\"
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"