{-# LANGUAGE ViewPatterns #-}

-- |
--
-- Module:      Language.Egison.Pretty.Pattern.External
-- Description: Externally privided printers
-- Stability:   experimental
--
-- This module defines a set of combinators that access to externally provided printers

module Language.Egison.Pretty.Pattern.External
  ( name
  , varName
  , valueExpr
  )
where

import           Data.Text                      ( Text
                                                , unpack
                                                )

import           Language.Egison.Pretty.Pattern.Prim
                                                ( Doc
                                                , text
                                                , parens
                                                )
import           Language.Egison.Pretty.Pattern.Print
                                                ( Print
                                                , askMode
                                                )
import           Language.Egison.Pretty.Pattern.PrintMode
                                                ( PrintMode(..) )


-- | Check whether the string is surrounded by something.
--
-- >>> let parens = ('(', ')')
-- >>> surroundedBy parens "(Hello, World)"
-- True
--
-- >>> surroundedBy parens "Hello, World"
-- False
--
-- >>> surroundedBy parens "(Hello)(World)"
-- False
surroundedBy :: (Char, Char) -> String -> Bool
surroundedBy :: (Char, Char) -> String -> Bool
surroundedBy (Char
begin, Char
end) (Char
h : (String -> String
forall a. [a] -> [a]
reverse -> (Char
l : String
body)))
  | Char
h Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
begin Bool -> Bool -> Bool
&& Char
l Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
end = (Char -> Int -> Int) -> Int -> String -> Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> Int -> Int
go Int
0 String
body Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
 where
  go :: Char -> Int -> Int
  go :: Char -> Int -> Int
go Char
c | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
begin = Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
1
       | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
end   = (-) Int
1
       | Bool
otherwise  = Int -> Int
forall a. a -> a
id
surroundedBy (Char, Char)
_ String
_ = Bool
False

lexicalChunk :: Text -> Doc
lexicalChunk :: Text -> Doc
lexicalChunk Text
txt
  | String -> Bool
forall (t :: * -> *). Foldable t => t Char -> Bool
containsDelimiter String
str Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
checkSurrounding String
str) = Doc -> Doc
forall ann. Doc ann -> Doc ann
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Text -> Doc
text Text
txt
  | Bool
otherwise = Text -> Doc
text Text
txt
 where
  containsDelimiter :: t Char -> Bool
containsDelimiter t Char
x = Char -> t Char -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
' ' t Char
x Bool -> Bool -> Bool
|| Char -> t Char -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
',' t Char
x Bool -> Bool -> Bool
|| Char -> t Char -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
')' t Char
x Bool -> Bool -> Bool
|| Char -> t Char -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
']' t Char
x
  checkSurrounding :: String -> Bool
checkSurrounding String
x = (Char, Char) -> String -> Bool
surroundedBy (Char
'(', Char
')') String
x Bool -> Bool -> Bool
|| (Char, Char) -> String -> Bool
surroundedBy (Char
'[', Char
']') String
x
  str :: String
str = Text -> String
unpack Text
txt

varName :: v -> Print n v e Doc
varName :: v -> Print n v e Doc
varName v
v = do
  PrintMode { ExtPrinter v
$sel:varNamePrinter:PrintMode :: forall n v e. PrintMode n v e -> ExtPrinter v
varNamePrinter :: ExtPrinter v
varNamePrinter } <- Print n v e (PrintMode n v e)
forall n v e. Print n v e (PrintMode n v e)
askMode
  Doc -> Print n v e Doc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc -> Print n v e Doc)
-> (Text -> Doc) -> Text -> Print n v e Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc
lexicalChunk (Text -> Print n v e Doc) -> Text -> Print n v e Doc
forall a b. (a -> b) -> a -> b
$ ExtPrinter v
varNamePrinter v
v

name :: n -> Print n v e Doc
name :: n -> Print n v e Doc
name n
n = do
  PrintMode { ExtPrinter n
$sel:namePrinter:PrintMode :: forall n v e. PrintMode n v e -> ExtPrinter n
namePrinter :: ExtPrinter n
namePrinter } <- Print n v e (PrintMode n v e)
forall n v e. Print n v e (PrintMode n v e)
askMode
  Doc -> Print n v e Doc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc -> Print n v e Doc)
-> (Text -> Doc) -> Text -> Print n v e Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc
lexicalChunk (Text -> Print n v e Doc) -> Text -> Print n v e Doc
forall a b. (a -> b) -> a -> b
$ ExtPrinter n
namePrinter n
n

valueExpr :: e -> Print n v e Doc
valueExpr :: e -> Print n v e Doc
valueExpr e
e = do
  PrintMode { ExtPrinter e
$sel:valueExprPrinter:PrintMode :: forall n v e. PrintMode n v e -> ExtPrinter e
valueExprPrinter :: ExtPrinter e
valueExprPrinter } <- Print n v e (PrintMode n v e)
forall n v e. Print n v e (PrintMode n v e)
askMode
  Doc -> Print n v e Doc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc -> Print n v e Doc)
-> (Text -> Doc) -> Text -> Print n v e Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc
lexicalChunk (Text -> Print n v e Doc) -> Text -> Print n v e Doc
forall a b. (a -> b) -> a -> b
$ ExtPrinter e
valueExprPrinter e
e