{-# LANGUAGE PatternGuards #-}
module Lambdabot.Plugin.Haskell.Pl.PrettyPrinter (Expr) where

-- Dummy export to make ghc -Wall happy

import Lambdabot.Plugin.Haskell.Pl.Common

instance Show Decl where
  show :: Decl -> String
show (Define String
f Expr
e) = String
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
e
  showList :: [Decl] -> ShowS
showList [Decl]
ds = String -> ShowS
forall a. [a] -> [a] -> [a]
(++) (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"; " ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Decl -> String) -> [Decl] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Decl -> String
forall a. Show a => a -> String
show [Decl]
ds

instance Show TopLevel where
  showsPrec :: Int -> TopLevel -> ShowS
showsPrec Int
p (TLE Expr
e) = Int -> Expr -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p Expr
e
  showsPrec Int
p (TLD Bool
_ Decl
d) = Int -> Decl -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p Decl
d

-- | Expression with syntactic sugar
data SExpr
  = SVar !String
  | SLambda ![Pattern] !SExpr
  | SLet ![Decl] !SExpr
  | SApp !SExpr !SExpr
  | SInfix !String !SExpr !SExpr
  | LeftSection !String !SExpr  -- (x +)
  | RightSection !String !SExpr -- (+ x)
  | List ![SExpr]
  | Tuple ![SExpr]
  | Enum !Expr !(Maybe Expr) !(Maybe Expr)

{-# INLINE toSExprHead #-}
toSExprHead :: String -> [Expr] -> Maybe SExpr
toSExprHead :: String -> [Expr] -> Maybe SExpr
toSExprHead String
hd [Expr]
tl
  | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
',') String
hd, String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
hdInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Expr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
tl
  = SExpr -> Maybe SExpr
forall a. a -> Maybe a
Just (SExpr -> Maybe SExpr)
-> ([SExpr] -> SExpr) -> [SExpr] -> Maybe SExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SExpr] -> SExpr
Tuple ([SExpr] -> SExpr) -> ([SExpr] -> [SExpr]) -> [SExpr] -> SExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SExpr] -> [SExpr]
forall a. [a] -> [a]
reverse ([SExpr] -> Maybe SExpr) -> [SExpr] -> Maybe SExpr
forall a b. (a -> b) -> a -> b
$ (Expr -> SExpr) -> [Expr] -> [SExpr]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> SExpr
toSExpr [Expr]
tl
  | Bool
otherwise = case (String
hd,[Expr] -> [Expr]
forall a. [a] -> [a]
reverse [Expr]
tl) of
      (String
"enumFrom", [Expr
e])              -> SExpr -> Maybe SExpr
forall a. a -> Maybe a
Just (SExpr -> Maybe SExpr) -> SExpr -> Maybe SExpr
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe Expr -> Maybe Expr -> SExpr
Enum Expr
e Maybe Expr
forall a. Maybe a
Nothing   Maybe Expr
forall a. Maybe a
Nothing
      (String
"enumFromThen", [Expr
e,Expr
e'])       -> SExpr -> Maybe SExpr
forall a. a -> Maybe a
Just (SExpr -> Maybe SExpr) -> SExpr -> Maybe SExpr
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe Expr -> Maybe Expr -> SExpr
Enum Expr
e (Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
e') Maybe Expr
forall a. Maybe a
Nothing
      (String
"enumFromTo", [Expr
e,Expr
e'])         -> SExpr -> Maybe SExpr
forall a. a -> Maybe a
Just (SExpr -> Maybe SExpr) -> SExpr -> Maybe SExpr
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe Expr -> Maybe Expr -> SExpr
Enum Expr
e Maybe Expr
forall a. Maybe a
Nothing   (Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
e')
      (String
"enumFromThenTo", [Expr
e,Expr
e',Expr
e'']) -> SExpr -> Maybe SExpr
forall a. a -> Maybe a
Just (SExpr -> Maybe SExpr) -> SExpr -> Maybe SExpr
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe Expr -> Maybe Expr -> SExpr
Enum Expr
e (Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
e') (Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
e'')
      (String, [Expr])
_                              -> Maybe SExpr
forall a. Maybe a
Nothing

toSExpr :: Expr -> SExpr
toSExpr :: Expr -> SExpr
toSExpr (Var Fixity
_ String
v) = String -> SExpr
SVar String
v
toSExpr (Lambda Pattern
v Expr
e) = case Expr -> SExpr
toSExpr Expr
e of
  (SLambda [Pattern]
vs SExpr
e') -> [Pattern] -> SExpr -> SExpr
SLambda (Pattern
vPattern -> [Pattern] -> [Pattern]
forall a. a -> [a] -> [a]
:[Pattern]
vs) SExpr
e'
  SExpr
e'              -> [Pattern] -> SExpr -> SExpr
SLambda [Pattern
v] SExpr
e'
toSExpr (Let [Decl]
ds Expr
e) = [Decl] -> SExpr -> SExpr
SLet [Decl]
ds (SExpr -> SExpr) -> SExpr -> SExpr
forall a b. (a -> b) -> a -> b
$ Expr -> SExpr
toSExpr Expr
e
toSExpr Expr
e | Just (String
hd,[Expr]
tl) <- Expr -> Maybe (String, [Expr])
getHead Expr
e, Just SExpr
se <- String -> [Expr] -> Maybe SExpr
toSExprHead String
hd [Expr]
tl = SExpr
se
toSExpr Expr
e | ([Expr]
ls, Expr
tl) <- Expr -> ([Expr], Expr)
getList Expr
e, Expr
tl Expr -> Expr -> Bool
forall a. Eq a => a -> a -> Bool
== Expr
nil
  = [SExpr] -> SExpr
List ([SExpr] -> SExpr) -> [SExpr] -> SExpr
forall a b. (a -> b) -> a -> b
$ (Expr -> SExpr) -> [Expr] -> [SExpr]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> SExpr
toSExpr [Expr]
ls
toSExpr (App Expr
e1 Expr
e2) = case Expr
e1 of
  App (Var Fixity
Inf String
v) Expr
e0
    -> String -> SExpr -> SExpr -> SExpr
SInfix String
v (Expr -> SExpr
toSExpr Expr
e0) (Expr -> SExpr
toSExpr Expr
e2)
  Var Fixity
Inf String
v | String
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"-"
    -> String -> SExpr -> SExpr
LeftSection String
v (Expr -> SExpr
toSExpr Expr
e2)

  Var Fixity
_ String
"flip" | Var Fixity
Inf String
v <- Expr
e2, String
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"-" -> Expr -> SExpr
toSExpr (Expr -> SExpr) -> Expr -> SExpr
forall a b. (a -> b) -> a -> b
$ Fixity -> String -> Expr
Var Fixity
Pref String
"subtract"

  App (Var Fixity
_ String
"flip") (Var Fixity
pr String
v)
    | String
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"-"  -> Expr -> SExpr
toSExpr (Expr -> SExpr) -> Expr -> SExpr
forall a b. (a -> b) -> a -> b
$ Fixity -> String -> Expr
Var Fixity
Pref String
"subtract" Expr -> Expr -> Expr
`App` Expr
e2
    | String
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"id" -> String -> SExpr -> SExpr
RightSection String
"$" (Expr -> SExpr
toSExpr Expr
e2)
    | Fixity
Inf <- Fixity
pr -> String -> SExpr -> SExpr
RightSection String
v (Expr -> SExpr
toSExpr Expr
e2)
  Expr
_ -> SExpr -> SExpr -> SExpr
SApp (Expr -> SExpr
toSExpr Expr
e1) (Expr -> SExpr
toSExpr Expr
e2)

getHead :: Expr -> Maybe (String, [Expr])
getHead :: Expr -> Maybe (String, [Expr])
getHead (Var Fixity
_ String
v) = (String, [Expr]) -> Maybe (String, [Expr])
forall a. a -> Maybe a
Just (String
v, [])
getHead (App Expr
e1 Expr
e2) = ([Expr] -> [Expr]) -> (String, [Expr]) -> (String, [Expr])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Expr
e2Expr -> [Expr] -> [Expr]
forall a. a -> [a] -> [a]
:) ((String, [Expr]) -> (String, [Expr]))
-> Maybe (String, [Expr]) -> Maybe (String, [Expr])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Expr -> Maybe (String, [Expr])
getHead Expr
e1
getHead Expr
_ = Maybe (String, [Expr])
forall a. Maybe a
Nothing

instance Show Expr where
  showsPrec :: Int -> Expr -> ShowS
showsPrec Int
p = Int -> SExpr -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p (SExpr -> ShowS) -> (Expr -> SExpr) -> Expr -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> SExpr
toSExpr

instance Show SExpr where
  showsPrec :: Int -> SExpr -> ShowS
showsPrec Int
_ (SVar String
v) = (ShowS
getPrefName String
v String -> ShowS
forall a. [a] -> [a] -> [a]
++)
  showsPrec Int
p (SLambda [Pattern]
vs SExpr
e) = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
minPrec) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ShowS
forall a. a -> a
id (ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
intersperse (Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) ((Pattern -> ShowS) -> [Pattern] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Pattern -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Int -> Pattern -> ShowS) -> Int -> Pattern -> ShowS
forall a b. (a -> b) -> a -> b
$ Int
maxPrecInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Pattern]
vs)) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (String
" -> "String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> SExpr -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
minPrec SExpr
e
  showsPrec Int
p (SApp SExpr
e1 SExpr
e2) = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxPrec) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    Int -> SExpr -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
maxPrec SExpr
e1 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> SExpr -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Int
maxPrecInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) SExpr
e2
  showsPrec Int
_ (LeftSection String
fx SExpr
e) = Bool -> ShowS -> ShowS
showParen Bool
True (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    Int -> SExpr -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec ((Assoc, Int) -> Int
forall a b. (a, b) -> b
snd (String -> (Assoc, Int)
lookupFix String
fx) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) SExpr
e ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowS
getInfName String
fxString -> ShowS
forall a. [a] -> [a] -> [a]
++)
  showsPrec Int
_ (RightSection String
fx SExpr
e) = Bool -> ShowS -> ShowS
showParen Bool
True (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    (ShowS
getInfName String
fxString -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> SExpr -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec ((Assoc, Int) -> Int
forall a b. (a, b) -> b
snd (String -> (Assoc, Int)
lookupFix String
fx) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) SExpr
e
  showsPrec Int
_ (Tuple [SExpr]
es) = Bool -> ShowS -> ShowS
showParen Bool
True (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a. a -> a
`id` String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
", " ((SExpr -> String) -> [SExpr] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SExpr -> String
forall a. Show a => a -> String
show [SExpr]
es) String -> ShowS
forall a. [a] -> [a] -> [a]
++)

  showsPrec Int
_ (List [SExpr]
es)
    | Just String
cs <- (SExpr -> Maybe Char) -> [SExpr] -> Maybe String
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((String -> Maybe Char) -> Maybe String -> Maybe Char
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
(=<<) String -> Maybe Char
forall a (m :: * -> *). (Read a, Alternative m) => String -> m a
readM (Maybe String -> Maybe Char)
-> (SExpr -> Maybe String) -> SExpr -> Maybe Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SExpr -> Maybe String
fromSVar) [SExpr]
es = String -> ShowS
forall a. Show a => a -> ShowS
shows (String
cs::String)
    | Bool
otherwise = (Char
'['Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a. a -> a
`id` String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
", " ((SExpr -> String) -> [SExpr] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SExpr -> String
forall a. Show a => a -> String
show [SExpr]
es) String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
']'Char -> ShowS
forall a. a -> [a] -> [a]
:)
    where fromSVar :: SExpr -> Maybe String
fromSVar (SVar String
str) = String -> Maybe String
forall a. a -> Maybe a
Just String
str
          fromSVar SExpr
_          = Maybe String
forall a. Maybe a
Nothing
  showsPrec Int
_ (Enum Expr
fr Maybe Expr
tn Maybe Expr
to) = (Char
'['Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> ShowS
forall a. Show a => a -> ShowS
shows Expr
fr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Maybe String -> ShowS
forall a. Maybe [a] -> [a] -> [a]
showsMaybe (((Char
','Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> (Expr -> String) -> Expr -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> String
forall a. Show a => a -> String
show) (Expr -> String) -> Maybe Expr -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Maybe Expr
tn) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
".."String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Maybe String -> ShowS
forall a. Maybe [a] -> [a] -> [a]
showsMaybe (Expr -> String
forall a. Show a => a -> String
show (Expr -> String) -> Maybe Expr -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Maybe Expr
to) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
']'Char -> ShowS
forall a. a -> [a] -> [a]
:)
      where showsMaybe :: Maybe [a] -> [a] -> [a]
showsMaybe = ([a] -> [a]) -> ([a] -> [a] -> [a]) -> Maybe [a] -> [a] -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [a] -> [a]
forall a. a -> a
id [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++)
  showsPrec Int
_ (SLet [Decl]
ds SExpr
e) = (String
"let "String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Decl] -> ShowS
forall a. Show a => a -> ShowS
shows [Decl]
ds ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
" in "String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SExpr -> ShowS
forall a. Show a => a -> ShowS
shows SExpr
e


  showsPrec Int
p (SInfix String
fx SExpr
e1 SExpr
e2) = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
fixity) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    Int -> SExpr -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
f1 SExpr
e1 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowS
getInfName String
fxString -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Int -> SExpr -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
f2 SExpr
e2 where
      fixity :: Int
fixity = (Assoc, Int) -> Int
forall a b. (a, b) -> b
snd ((Assoc, Int) -> Int) -> (Assoc, Int) -> Int
forall a b. (a -> b) -> a -> b
$ String -> (Assoc, Int)
lookupFix String
fx
      (Int
f1, Int
f2) = case (Assoc, Int) -> Assoc
forall a b. (a, b) -> a
fst ((Assoc, Int) -> Assoc) -> (Assoc, Int) -> Assoc
forall a b. (a -> b) -> a -> b
$ String -> (Assoc, Int)
lookupFix String
fx of
        Assoc
AssocRight -> (Int
fixityInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Int
fixity Int -> Int -> Int
forall a. Num a => a -> a -> a
+ SExpr -> Assoc -> Int -> Int
infixSafe SExpr
e2 Assoc
AssocLeft Int
fixity)
        Assoc
AssocLeft  -> (Int
fixity Int -> Int -> Int
forall a. Num a => a -> a -> a
+ SExpr -> Assoc -> Int -> Int
infixSafe SExpr
e1 Assoc
AssocRight Int
fixity, Int
fixityInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        Assoc
AssocNone  -> (Int
fixityInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Int
fixityInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

      -- This is a little bit awkward, but at least seems to produce no false
      -- results anymore
      infixSafe :: SExpr -> Assoc -> Int -> Int
      infixSafe :: SExpr -> Assoc -> Int -> Int
infixSafe (SInfix String
fx'' SExpr
_ SExpr
_) Assoc
assoc Int
fx'
        | String -> (Assoc, Int)
lookupFix String
fx'' (Assoc, Int) -> (Assoc, Int) -> Bool
forall a. Eq a => a -> a -> Bool
== (Assoc
assoc, Int
fx') = Int
1
        | Bool
otherwise = Int
0
      infixSafe SExpr
_ Assoc
_ Int
_ = Int
0 -- doesn't matter

instance Show Pattern where
  showsPrec :: Int -> Pattern -> ShowS
showsPrec Int
_ (PVar String
v) = (String
vString -> ShowS
forall a. [a] -> [a] -> [a]
++)
  showsPrec Int
_ (PTuple Pattern
p1 Pattern
p2) = Bool -> ShowS -> ShowS
showParen Bool
True (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    Int -> Pattern -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
0 Pattern
p1 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
", "String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Pattern -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
0 Pattern
p2
  showsPrec Int
p (PCons Pattern
p1 Pattern
p2) = Bool -> ShowS -> ShowS
showParen (Int
pInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
5) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    Int -> Pattern -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
6 Pattern
p1 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
':'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Pattern -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
5 Pattern
p2

isOperator :: String -> Bool
isOperator :: String -> Bool
isOperator String
str = String -> Char
forall a. [a] -> a
last String
str Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
opchars

getInfName :: String -> String
getInfName :: ShowS
getInfName String
str = if String -> Bool
isOperator String
str then String
str else String
"`"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
strString -> ShowS
forall a. [a] -> [a] -> [a]
++String
"`"

getPrefName :: String -> String
getPrefName :: ShowS
getPrefName String
str = if String -> Bool
isOperator String
str Bool -> Bool -> Bool
|| Char
',' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
str then String
"("String -> ShowS
forall a. [a] -> [a] -> [a]
++String
strString -> ShowS
forall a. [a] -> [a] -> [a]
++String
")" else String
str

instance Eq Assoc where
  Assoc
AssocLeft  == :: Assoc -> Assoc -> Bool
== Assoc
AssocLeft  = Bool
True
  Assoc
AssocRight == Assoc
AssocRight = Bool
True
  Assoc
AssocNone  == Assoc
AssocNone  = Bool
True
  Assoc
_          == Assoc
_          = Bool
False

{-
instance Show Assoc where
  show AssocLeft  = "AssocLeft"
  show AssocRight = "AssocRight"
  show AssocNone  = "AssocNone"

instance Ord Assoc where
  AssocNone <= _ = True
  _ <= AssocNone = False
  AssocLeft <= _ = True
  _ <= AssocLeft = False
  _ <= _ = True
-}