{-# LANGUAGE PatternGuards #-}
module Plugin.Pl.PrettyPrinter (
  prettyDecl,
  prettyExpr,
  prettyTopLevel,
 ) where

import Plugin.Pl.Common

import Data.Char
import Data.List (intercalate)

prettyDecl :: Decl -> String
prettyDecl :: Decl -> String
prettyDecl (Define String
f Expr
e) = String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
prettyExpr Expr
e

prettyDecls :: [Decl] -> String
prettyDecls :: [Decl] -> String
prettyDecls = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"; " ([String] -> String) -> ([Decl] -> [String]) -> [Decl] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Decl -> String) -> [Decl] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Decl -> String
prettyDecl

prettyExpr :: Expr -> String
prettyExpr :: Expr -> String
prettyExpr = SExpr -> String
forall a. Show a => a -> String
show (SExpr -> String) -> (Expr -> SExpr) -> Expr -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> SExpr
toSExpr

prettyTopLevel :: TopLevel -> String
prettyTopLevel :: TopLevel -> String
prettyTopLevel (TLE Expr
e) = Expr -> String
prettyExpr Expr
e
prettyTopLevel (TLD Bool
_ Decl
d) = Decl -> String
prettyDecl Decl
d

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, (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
',') String
v -> 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 SExpr where
  showsPrec :: Int -> SExpr -> String -> String
showsPrec Int
_ (SVar String
v) = (String -> String
getPrefName String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++)
  showsPrec Int
p (SLambda [Pattern]
vs SExpr
e) = Bool -> (String -> String) -> String -> String
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
minPrec) ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 
    ((String -> String) -> (String -> String) -> String -> String)
-> (String -> String) -> [String -> String] -> String -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) String -> String
forall a. a -> a
id ((String -> String) -> [String -> String] -> [String -> String]
forall a. a -> [a] -> [a]
intersperse (Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:) ((Pattern -> String -> String) -> [Pattern] -> [String -> String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Pattern -> String -> String
prettyPrecPattern (Int -> Pattern -> String -> String)
-> Int -> Pattern -> String -> String
forall a b. (a -> b) -> a -> b
$ Int
maxPrecInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Pattern]
vs)) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (String
" -> "String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> SExpr -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
minPrec SExpr
e
  showsPrec Int
p (SApp SExpr
e1 SExpr
e2) = Bool -> (String -> String) -> String -> String
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxPrec) ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
    Int -> SExpr -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
maxPrec SExpr
e1 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> SExpr -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec (Int
maxPrecInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) SExpr
e2
  showsPrec Int
_ (LeftSection String
fx SExpr
e) = Bool -> (String -> String) -> String -> String
showParen Bool
True ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ 
    Int -> SExpr -> String -> String
forall a. Show a => Int -> a -> String -> String
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 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String
getInfName String
fxString -> String -> String
forall a. [a] -> [a] -> [a]
++)
  showsPrec Int
_ (RightSection String
fx SExpr
e) = Bool -> (String -> String) -> String -> String
showParen Bool
True ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ 
    (String -> String
getInfName String
fxString -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> SExpr -> String -> String
forall a. Show a => Int -> a -> String -> String
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 -> (String -> String) -> String -> String
showParen Bool
True ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
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 -> String -> String
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. Read a => String -> Maybe 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 -> String -> String
forall a. Show a => a -> String -> String
shows (String
cs::String)
    | Bool
otherwise = (Char
'['Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (String -> String) -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
']'Char -> String -> String
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 -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString (Expr -> String
prettyExpr Expr
fr) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 
    Maybe String -> String -> String
forall a. Maybe [a] -> [a] -> [a]
showsMaybe (((Char
','Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (Expr -> String) -> Expr -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> String
prettyExpr) (Expr -> String) -> Maybe Expr -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Maybe Expr
tn) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
".."String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 
    Maybe String -> String -> String
forall a. Maybe [a] -> [a] -> [a]
showsMaybe (Expr -> String
prettyExpr (Expr -> String) -> Maybe Expr -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Maybe Expr
to) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
']'Char -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString ([Decl] -> String
prettyDecls [Decl]
ds String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in ") (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SExpr -> String -> String
forall a. Show a => a -> String -> String
shows SExpr
e


  showsPrec Int
p (SInfix String
fx SExpr
e1 SExpr
e2) = Bool -> (String -> String) -> String -> String
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
fixity) ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
    Int -> SExpr -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
f1 SExpr
e1 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String
getInfName String
fxString -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 
    Int -> SExpr -> String -> String
forall a. Show a => Int -> a -> String -> String
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
        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 ()
forall l. l -> Assoc l
AssocLeft ()) Int
fixity)
        AssocLeft ()
_ -> (Int
fixity Int -> Int -> Int
forall a. Num a => a -> a -> a
+ SExpr -> Assoc () -> Int -> Int
infixSafe SExpr
e1 (() -> Assoc ()
forall l. l -> Assoc l
AssocRight ()) Int
fixity, Int
fixityInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        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

prettyPrecPattern :: Int -> Pattern -> ShowS
prettyPrecPattern :: Int -> Pattern -> String -> String
prettyPrecPattern Int
_ (PVar String
v) = String -> String -> String
showString String
v
prettyPrecPattern Int
_ (PTuple Pattern
p1 Pattern
p2) = Bool -> (String -> String) -> String -> String
showParen Bool
True ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
  Int -> Pattern -> String -> String
prettyPrecPattern Int
0 Pattern
p1 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
", "String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Pattern -> String -> String
prettyPrecPattern Int
0 Pattern
p2
prettyPrecPattern Int
p (PCons Pattern
p1 Pattern
p2) = Bool -> (String -> String) -> String -> String
showParen (Int
pInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
5) ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
  Int -> Pattern -> String -> String
prettyPrecPattern Int
6 Pattern
p1 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
':'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Pattern -> String -> String
prettyPrecPattern Int
5 Pattern
p2
  
isOperator :: String -> Bool
isOperator :: String -> Bool
isOperator String
s =
  case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') String
s of
    (String
_, String
"") -> String -> Bool
isUnqualOp String
s
    (String
before, Char
_dot : String
rest)
      | String -> Bool
isUnqualOp String
before -> String -> Bool
isUnqualOp String
rest
      | String -> Bool
isModule String
before -> String -> Bool
isOperator String
rest
      | Bool
otherwise -> Bool
False
  where
    isModule :: String -> Bool
isModule String
"" = Bool
False
    isModule (Char
c : String
cs) = Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'\'', Char
'_']) String
cs
    isUnqualOp :: String -> Bool
isUnqualOp String
s = String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"()" Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Char
c -> Char -> Bool
isSymbol Char
c Bool -> Bool -> Bool
|| Char -> Bool
isPunctuation Char
c) String
s

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

getPrefName :: String -> String
getPrefName :: String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++String
strString -> String -> String
forall a. [a] -> [a] -> [a]
++String
")" else String
str

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