{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}  -- ghc 7.10

module BNFC.Utils
    ( ModuleName
    , when, unless, unlessNull, unlessNull'
    , applyWhen, applyUnless
    , for, whenJust
    , caseMaybe, (>.>)
    , curry3, uncurry3
    , singleton, headWithDefault, mapHead, spanEnd
    , duplicatesOn, groupOn, uniqOn
    , hasNumericSuffix
    , (+++), (++++), (+-+), (+.+), parensIf
    , pad, table
    , mkName, mkNames, NameStyle(..)
    , lowerCase, upperCase, mixedCase
    , camelCase, camelCase_
    , snakeCase, snakeCase_
    , replace
    , writeFileRep
    , cstring
    , getZonedTimeTruncatedToSeconds
    , symbolToName
    ) where

import Control.Arrow   ((&&&))
import Control.DeepSeq (rnf)

import Data.Char
import Data.List          (intercalate)
import Data.List.NonEmpty (pattern (:|))
import Data.Map           (Map)
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup     (Semigroup(..))
#endif
import Data.Time

import qualified Data.Foldable      as Fold
import qualified Data.Map           as Map
import qualified Data.List.NonEmpty as List1

import System.IO       (IOMode(ReadMode),hClose,hGetContents,openFile)
import System.IO.Error (tryIOError)

import BNFC.PrettyPrint (Doc, text)

type List1 = List1.NonEmpty

-- | The name of a module, e.g. "Foo.Abs", "Foo.Print" etc.
type ModuleName = String

-- * Control flow.

-- ghc 7.10 misses the instance Monoid a => Monoid (IO a)

#if __GLASGOW_HASKELL__ <= 710
instance {-# OVERLAPPING #-} Semigroup (IO ()) where
  (<>) = (>>)

instance {-# OVERLAPPING #-} Monoid (IO ()) where
  mempty  = return ()
  mappend = (<>)
  mconcat = sequence_
#endif

-- | Generalization of 'Control.Monad.when'.
when :: Monoid m => Bool -> m -> m
when :: Bool -> m -> m
when Bool
True  m
m = m
m
when Bool
False m
_ = m
forall a. Monoid a => a
mempty

-- | Generalization of 'Control.Monad.unless'.
unless :: Monoid m => Bool -> m -> m
unless :: Bool -> m -> m
unless Bool
False m
m = m
m
unless Bool
True  m
_ = m
forall a. Monoid a => a
mempty

-- | 'when' for the monoid of endofunctions 'a -> a'.
applyWhen :: Bool -> (a -> a) -> a -> a
applyWhen :: Bool -> (a -> a) -> a -> a
applyWhen Bool
True  a -> a
f = a -> a
f
applyWhen Bool
False a -> a
_ = a -> a
forall a. a -> a
id

-- | 'unless' for the monoid of endofunctions 'a -> a'.
applyUnless :: Bool -> (a -> a) -> a -> a
applyUnless :: Bool -> (a -> a) -> a -> a
applyUnless Bool
False a -> a
f = a -> a
f
applyUnless Bool
True  a -> a
_ = a -> a
forall a. a -> a
id

-- | Invoke continuation for non-empty list.
unlessNull :: Monoid m => [a] -> ([a] -> m) -> m
unlessNull :: [a] -> ([a] -> m) -> m
unlessNull [a]
l [a] -> m
k = case [a]
l of
  [] -> m
forall a. Monoid a => a
mempty
  [a]
as -> [a] -> m
k [a]
as

-- | Invoke continuation for non-empty list.
unlessNull' :: Monoid m => [a] -> (a -> [a] -> m) -> m
unlessNull' :: [a] -> (a -> [a] -> m) -> m
unlessNull' [a]
l a -> [a] -> m
k = case [a]
l of
  []     -> m
forall a. Monoid a => a
mempty
  (a
a:[a]
as) -> a -> [a] -> m
k a
a [a]
as

-- * Flipped versions of standard functions.

infixr 8 >.>

-- | Diagrammatic composition.
(>.>) :: (a -> b) -> (b -> c) -> a -> c
a -> b
g >.> :: (a -> b) -> (b -> c) -> a -> c
>.> b -> c
f = b -> c
f (b -> c) -> (a -> b) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
g

-- | Non-monadic 'forM'.
for :: [a] -> (a -> b) -> [b]
for :: [a] -> (a -> b) -> [b]
for = ((a -> b) -> [a] -> [b]) -> [a] -> (a -> b) -> [b]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map

-- | Generalization of 'forM' to 'Monoid'.
whenJust :: Monoid m => Maybe a -> (a -> m) -> m
whenJust :: Maybe a -> (a -> m) -> m
whenJust = ((a -> m) -> Maybe a -> m) -> Maybe a -> (a -> m) -> m
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap

-- | Rotation of 'maybe'.
caseMaybe :: Maybe a -> b -> (a -> b) -> b
caseMaybe :: Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe a
ma b
b a -> b
f = b -> (a -> b) -> Maybe a -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
b a -> b
f Maybe a
ma

-- * Tuple utilities.

-- From https://hackage.haskell.org/package/extra-1.6.18/docs/Data-Tuple-Extra.html

-- | Converts an uncurried function to a curried function.
curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d
curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d
curry3 (a, b, c) -> d
f a
a b
b c
c = (a, b, c) -> d
f (a
a,b
b,c
c)

-- | Converts a curried function to a function on a triple.
uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d)
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 a -> b -> c -> d
f ~(a
a,b
b,c
c) = a -> b -> c -> d
f a
a b
b c
c

-- * String operations for printing.

infixr 5 +++, ++++, +-+, +.+

-- | Concatenate strings by a space.
(+++) :: String -> String -> String
String
a +++ :: String -> String -> String
+++ String
b   = String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b

-- | Concatenate strings by a newline.
(++++) :: String -> String -> String
String
a ++++ :: String -> String -> String
++++ String
b  = String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b

-- | Concatenate strings by an underscore.
(+-+) :: String -> String -> String
String
a +-+ :: String -> String -> String
+-+ String
b   = String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_"    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b

-- | Concatenate strings by a dot.
(+.+) :: String -> String -> String
String
a +.+ :: String -> String -> String
+.+ String
b   = String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b

-- | Wrap in parentheses if condition holds.
parensIf :: Bool -> String -> String
parensIf :: Bool -> String -> String
parensIf = \case
  Bool
True  -> (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
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
  Bool
False -> String -> String
forall a. a -> a
id

-- | Pad a string on the right by spaces to reach the desired length.
pad :: Int -> String -> String
pad :: Int -> String -> String
pad Int
n String
s = String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' ')

-- | Make a list of rows with left-aligned columns from a matrix.
table :: String -> [[String]] -> [String]
table :: String -> [[String]] -> [String]
table String
sep [[String]]
m = ([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
sep ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> String -> String) -> [Int] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> String -> String
pad [Int]
widths) [[String]]
m
  where
  -- Column widths.
  widths :: [Int]
  widths :: [Int]
widths = ([Int] -> Int) -> [[Int]] -> [Int]
forall a b. ([a] -> b) -> [[a]] -> [b]
columns [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([[Int]] -> [Int]) -> [[Int]] -> [Int]
forall a b. (a -> b) -> a -> b
$ ([String] -> [Int]) -> [[String]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) [[String]]
m
  -- Aggregate columns (works even for a ragged matrix with rows of different length).
  columns :: ([a] -> b) -> [[a]] -> [b]
  columns :: ([a] -> b) -> [[a]] -> [b]
columns [a] -> b
f [[a]]
rows =
    -- Take the values of the first column
    case [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
1) [[a]]
rows) of
      -- Matrix was empty:
      [] -> []
      -- Matrix was non-empty:
      [a]
col -> [a] -> b
f [a]
col b -> [b] -> [b]
forall a. a -> [a] -> [a]
: ([a] -> b) -> [[a]] -> [b]
forall a b. ([a] -> b) -> [[a]] -> [b]
columns [a] -> b
f (([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
1) [[a]]
rows)

-- * List utilities

-- | Give a telling name to the electric monkey.
singleton :: a -> [a]
singleton :: a -> [a]
singleton = (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[])

-- | Get the first element of a list, fallback for empty list.
headWithDefault :: a -> [a] -> a
headWithDefault :: a -> [a] -> a
headWithDefault a
a []    = a
a
headWithDefault a
_ (a
a:[a]
_) = a
a

-- | Apply a function to the head of a list.
mapHead :: (a -> a) -> [a] -> [a]
mapHead :: (a -> a) -> [a] -> [a]
mapHead a -> a
f = \case
 []   -> []
 a
a:[a]
as -> a -> a
f a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as

-- | @spanEnd p l == reverse (span p (reverse l))@.
--
-- Invariant: @l == front ++ end where (end, front) = spanEnd p l@
--
-- (From package ghc, module Util.)
spanEnd :: (a -> Bool) -> [a] -> ([a], [a])
spanEnd :: (a -> Bool) -> [a] -> ([a], [a])
spanEnd a -> Bool
p [a]
l = [a] -> [a] -> [a] -> [a] -> ([a], [a])
go [a]
l [] [] [a]
l
  where
  go :: [a] -> [a] -> [a] -> [a] -> ([a], [a])
go [a]
yes [a]
_        [a]
rev_no [] = ([a]
yes, [a] -> [a]
forall a. [a] -> [a]
reverse [a]
rev_no)
  go [a]
yes [a]
rev_yes  [a]
rev_no (a
x:[a]
xs)
    | a -> Bool
p a
x       = [a] -> [a] -> [a] -> [a] -> ([a], [a])
go [a]
yes (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
rev_yes) [a]
rev_no                  [a]
xs
    | Bool
otherwise = [a] -> [a] -> [a] -> [a] -> ([a], [a])
go [a]
xs  []            (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
rev_yes [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
rev_no) [a]
xs


-- | Replace all occurences of a value by another value
replace :: Eq a =>
           a -- ^ Value to replace
        -> a -- ^ Value to replace it with
        -> [a] -> [a]
replace :: a -> a -> [a] -> [a]
replace a
x a
y [a]
xs = [ if a
z a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x then a
y else a
z | a
z <- [a]
xs]

-- | Returns lists of elements whose normal form appears more than once.
--
-- >>> duplicatesOn id  [5,1,2,5,1]
-- [1 :| [1],5 :| [5]]
-- >>> duplicatesOn abs [5,-5,1]
-- [5 :| [-5]]
duplicatesOn :: (Foldable t, Ord b) => (a -> b) -> t a -> [List1 a]
duplicatesOn :: (a -> b) -> t a -> [List1 a]
duplicatesOn a -> b
nf
    -- Keep groups of size >= 2.
  = (List1 a -> Bool) -> [List1 a] -> [List1 a]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int
2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=) (Int -> Bool) -> (List1 a -> Int) -> List1 a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. List1 a -> Int
forall a. NonEmpty a -> Int
List1.length)
    -- Turn into a list of listss: elements grouped by their normal form.
  ([List1 a] -> [List1 a]) -> (t a -> [List1 a]) -> t a -> [List1 a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map b (List1 a) -> [List1 a]
forall k a. Map k a -> [a]
Map.elems
    -- Partition elements by their normal form.
  (Map b (List1 a) -> [List1 a])
-> (t a -> Map b (List1 a)) -> t a -> [List1 a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Map b (List1 a) -> Map b (List1 a))
-> Map b (List1 a) -> t a -> Map b (List1 a)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
Fold.foldr (\ a
a -> (List1 a -> List1 a -> List1 a)
-> b -> List1 a -> Map b (List1 a) -> Map b (List1 a)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith List1 a -> List1 a -> List1 a
forall a. Semigroup a => a -> a -> a
(<>) (a -> b
nf a
a) (a
a a -> [a] -> List1 a
forall a. a -> [a] -> NonEmpty a
:| [])) Map b (List1 a)
forall k a. Map k a
Map.empty

-- | Group consecutive elements that have the same normalform.
groupOn :: Eq b => (a -> b) -> [a] -> [List1 a]
groupOn :: (a -> b) -> [a] -> [List1 a]
groupOn a -> b
nf = [a] -> [List1 a]
loop
  where
  loop :: [a] -> [List1 a]
loop = \case
    []   -> []
    a
a:[a]
xs | let ([a]
as, [a]
rest) = (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((a -> b
nf a
a b -> b -> Bool
forall a. Eq a => a -> a -> Bool
==) (b -> Bool) -> (a -> b) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
nf) [a]
xs
         -> (a
a a -> [a] -> List1 a
forall a. a -> [a] -> NonEmpty a
:| [a]
as) List1 a -> [List1 a] -> [List1 a]
forall a. a -> [a] -> [a]
: [a] -> [List1 a]
loop [a]
rest

-- | Keep only the first of consecutive elements that have the same normalform.
uniqOn :: Eq b => (a -> b) -> [a] -> [a]
uniqOn :: (a -> b) -> [a] -> [a]
uniqOn a -> b
nf = (NonEmpty a -> a) -> [NonEmpty a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map NonEmpty a -> a
forall a. NonEmpty a -> a
List1.head ([NonEmpty a] -> [a]) -> ([a] -> [NonEmpty a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> [a] -> [NonEmpty a]
forall b a. Eq b => (a -> b) -> [a] -> [List1 a]
groupOn a -> b
nf

-- | Get a numeric suffix if it exists.
--
-- >>> hasNumericSuffix "hello world"
-- Nothing
-- >>> hasNumericSuffix "a1b2"
-- Just ("a1b",2)
-- >>> hasNumericSuffix "1234"
-- Just ("",1234)

hasNumericSuffix :: String -> Maybe (String, Integer)
hasNumericSuffix :: String -> Maybe (String, Integer)
hasNumericSuffix String
s = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
spanEnd Char -> Bool
isDigit String
s of
  ([], String
_) -> Maybe (String, Integer)
forall a. Maybe a
Nothing
  (String
num, String
front) -> (String, Integer) -> Maybe (String, Integer)
forall a. a -> Maybe a
Just (String
front, String -> Integer
forall a. Read a => String -> a
read String
num)

-- * Time utilities

-- | Cut away fractions of a second in time.

truncateZonedTimeToSeconds :: ZonedTime -> ZonedTime
truncateZonedTimeToSeconds :: ZonedTime -> ZonedTime
truncateZonedTimeToSeconds (ZonedTime (LocalTime Day
day (TimeOfDay Int
h Int
m Pico
s)) TimeZone
zone) =
  LocalTime -> TimeZone -> ZonedTime
ZonedTime (Day -> TimeOfDay -> LocalTime
LocalTime Day
day (Int -> Int -> Pico -> TimeOfDay
TimeOfDay Int
h Int
m (Pico -> TimeOfDay) -> Pico -> TimeOfDay
forall a b. (a -> b) -> a -> b
$ Int -> Pico
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sec)) TimeZone
zone
  where
  sec :: Int
  sec :: Int
sec = Pico -> Int
forall a b. (RealFrac a, Integral b) => a -> b
truncate Pico
s

getZonedTimeTruncatedToSeconds :: IO ZonedTime
getZonedTimeTruncatedToSeconds :: IO ZonedTime
getZonedTimeTruncatedToSeconds = ZonedTime -> ZonedTime
truncateZonedTimeToSeconds (ZonedTime -> ZonedTime) -> IO ZonedTime -> IO ZonedTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ZonedTime
getZonedTime

-- * File utilities

-- | Write a file, after making a backup of an existing file with the same name.
-- If an old version of the file exist and the new version is the same,
-- keep the old file and don't create a .bak file.
-- / New version by TH, 2010-09-23

writeFileRep :: FilePath -> String -> IO ()
writeFileRep :: String -> String -> IO ()
writeFileRep String
path String
s =
    (IOError -> IO ())
-> (String -> IO ()) -> Either IOError String -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either IOError -> IO ()
forall p. p -> IO ()
newFile String -> IO ()
updateFile (Either IOError String -> IO ())
-> IO (Either IOError String) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String -> IO (Either IOError String)
forall a. IO a -> IO (Either IOError a)
tryIOError (String -> IO String
readFile' String
path)
  where
    -- Case: file does not exist yet.
    newFile :: p -> IO ()
newFile p
_ = do
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"writing new file " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path
      String -> String -> IO ()
writeFile String
path String
s

    -- Case: file exists with content @old@.
    updateFile :: String -> IO ()
updateFile String
old = do
      -- Write new content.
      String -> String -> IO ()
writeFile String
path String
s
      if String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
old  -- test is O(1) space, O(n) time
         then do
           String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"refreshing unchanged file " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path
         else do
           let bak :: String
bak = String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".bak"
           String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"writing file " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (saving old file as " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
bak String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
           String -> String -> IO ()
writeFile String
bak String
old

    -- Force reading of contents of files to achieve compatibility with
    -- Windows IO handling, as combining lazy IO with `readFile` and
    -- 2x `renameFile` on the open `path` file complains with:
    --
    -- "bnfc.exe: Makefile: MoveFileEx "Makefile" "Makefile.bak": permission
    -- denied (The process cannot access the file because it is being used
    -- by another process.)"
    readFile' :: FilePath -> IO String
    readFile' :: String -> IO String
readFile' String
path' = do
      Handle
inFile   <- String -> IOMode -> IO Handle
openFile String
path' IOMode
ReadMode
      String
contents <- Handle -> IO String
hGetContents Handle
inFile
      String -> ()
forall a. NFData a => a -> ()
rnf String
contents () -> IO () -> IO ()
`seq` Handle -> IO ()
hClose Handle
inFile
      String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
contents

-- *** Naming ***
-- Because naming is hard (http://blog.codinghorror.com/i-shall-call-it-somethingmanager/)

-- | Different case style
data NameStyle
  = LowerCase  -- ^ e.g. @lowercase@
  | UpperCase  -- ^ e.g. @UPPERCASE@
  | SnakeCase  -- ^ e.g. @snake_case@
  | CamelCase  -- ^ e.g. @CamelCase@
  | MixedCase  -- ^ e.g. @mixedCase@
  | OrigCase   -- ^ Keep original capitalization and form.
  deriving (Int -> NameStyle -> String -> String
[NameStyle] -> String -> String
NameStyle -> String
(Int -> NameStyle -> String -> String)
-> (NameStyle -> String)
-> ([NameStyle] -> String -> String)
-> Show NameStyle
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [NameStyle] -> String -> String
$cshowList :: [NameStyle] -> String -> String
show :: NameStyle -> String
$cshow :: NameStyle -> String
showsPrec :: Int -> NameStyle -> String -> String
$cshowsPrec :: Int -> NameStyle -> String -> String
Show, NameStyle -> NameStyle -> Bool
(NameStyle -> NameStyle -> Bool)
-> (NameStyle -> NameStyle -> Bool) -> Eq NameStyle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NameStyle -> NameStyle -> Bool
$c/= :: NameStyle -> NameStyle -> Bool
== :: NameStyle -> NameStyle -> Bool
$c== :: NameStyle -> NameStyle -> Bool
Eq)

-- | Generate a name in the given case style taking into account the reserved
-- word of the language. Note that despite the fact that those name are mainly
-- to be used in code rendering (type Doc), we return a String here to allow
-- further manipulation of the name (like disambiguation) which is not possible
-- in the Doc type.
--
-- Examples:
--
-- >>> mkName [] LowerCase "FooBAR"
-- "foobar"
--
-- >>> mkName [] UpperCase "FooBAR"
-- "FOOBAR"
--
-- >>> mkName [] SnakeCase "FooBAR"
-- "foo_bar"
--
-- >>> mkName [] CamelCase "FooBAR"
-- "FooBAR"
--
-- >>> mkName [] CamelCase "Foo_bar"
-- "FooBar"
--
-- >>> mkName [] MixedCase "FooBAR"
-- "fooBAR"
--
-- >>> mkName ["foobar"] LowerCase "FooBAR"
-- "foobar_"
--
-- >>> mkName ["foobar", "foobar_"] LowerCase "FooBAR"
-- "foobar__"

mkName :: [String] -> NameStyle -> String -> String
mkName :: [String] -> NameStyle -> String -> String
mkName [String]
reserved NameStyle
style String
s = String -> String
notReserved String
name'
  where
    notReserved :: String -> String
notReserved String
name
      | String
name String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
reserved = String -> String
notReserved (String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_")
      | Bool
otherwise = String
name
    tokens :: [String]
tokens = String -> [String]
parseIdent String
s
    name' :: String
name' = case NameStyle
style of
        NameStyle
LowerCase -> (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
tokens
        NameStyle
UpperCase -> (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
tokens
        NameStyle
CamelCase -> (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> String
capitalize [String]
tokens
        NameStyle
MixedCase -> (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
mapHead Char -> Char
toLower (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> String
capitalize [String]
tokens
        NameStyle
SnakeCase -> (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"_" [String]
tokens
        NameStyle
OrigCase  -> String
s
    capitalize :: String -> String
capitalize = (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
mapHead Char -> Char
toUpper

-- | Same as above but accept a list as argument and make sure that the
-- names generated are uniques.
--
-- >>> mkNames ["c"] LowerCase ["A", "b_", "a_", "c"]
-- ["a1","b","a2","c_"]

mkNames :: [String] -> NameStyle -> [String] -> [String]
mkNames :: [String] -> NameStyle -> [String] -> [String]
mkNames [String]
reserved NameStyle
style = [String] -> [String]
disambiguateNames ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> NameStyle -> String -> String
mkName [String]
reserved NameStyle
style)

-- | This one takes a list of names and makes sure each is unique, appending
-- numerical suffix if needed.
--
-- >>> disambiguateNames ["a", "b", "a", "c"]
-- ["a1","b","a2","c"]

disambiguateNames :: [String] -> [String]
disambiguateNames :: [String] -> [String]
disambiguateNames = [String] -> [String] -> [String]
disamb []
  where
    disamb :: [String] -> [String] -> [String]
disamb [String]
ns1 (String
n:[String]
ns2)
      | String
n String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([String]
ns1 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ns2) = let i :: Int
i = [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
n) [String]
ns1) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                                in (String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String] -> [String]
disamb (String
nString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
ns1) [String]
ns2
      | Bool
otherwise = String
n String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String] -> [String]
disamb (String
nString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
ns1) [String]
ns2
    disamb [String]
_ [] = []

-- | Heuristic to "parse" an identifier into separate components.
--
-- >>> parseIdent "abc"
-- ["abc"]
--
-- >>> parseIdent "Abc"
-- ["Abc"]
--
-- >>> parseIdent "WhySoSerious"
-- ["Why","So","Serious"]
--
-- >>> parseIdent "why_so_serious"
-- ["why","so","serious"]
--
-- >>> parseIdent "why-so-serious"
-- ["why","so","serious"]
--
-- Some corner cases:
--
-- >>> parseIdent "LBNFParser"
-- ["LBNF","Parser"]
--
-- >>> parseIdent "aLBNFParser"
-- ["a","LBNF","Parser"]
--
-- >>> parseIdent "ILoveNY"
-- ["I","Love","NY"]

parseIdent :: String -> [String]
parseIdent :: String -> [String]
parseIdent = String -> [(CharClass, Char)] -> [String]
p [] ([(CharClass, Char)] -> [String])
-> (String -> [(CharClass, Char)]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> (CharClass, Char)) -> String -> [(CharClass, Char)]
forall a b. (a -> b) -> [a] -> [b]
map (Char -> CharClass
classify (Char -> CharClass) -> (Char -> Char) -> Char -> (CharClass, Char)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Char -> Char
forall a. a -> a
id)
  where
    classify :: Char -> CharClass
    classify :: Char -> CharClass
classify Char
c
        | Char -> Bool
isUpper Char
c = CharClass
U
        | Char -> Bool
isLower Char
c = CharClass
L
        | Bool
otherwise = CharClass
O

    p :: String -> [(CharClass,Char)] -> [String]
    -- Done:
    p :: String -> [(CharClass, Char)] -> [String]
p String
acc []                       = String -> [String] -> [String]
emit String
acc []

    -- Continue if consecutive characters have same case.
    p String
acc ((CharClass
L,Char
c) : cs :: [(CharClass, Char)]
cs@((CharClass
L,Char
_) : [(CharClass, Char)]
_)) = String -> [(CharClass, Char)] -> [String]
p (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) [(CharClass, Char)]
cs
    p String
acc ((CharClass
U,Char
c) : cs :: [(CharClass, Char)]
cs@((CharClass
U,Char
_) : [(CharClass, Char)]
_)) = String -> [(CharClass, Char)] -> [String]
p (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) [(CharClass, Char)]
cs

    -- Break if consecutive characters have different case.
    p String
acc ((CharClass
U,Char
c) : cs :: [(CharClass, Char)]
cs@((CharClass
L,Char
_) : [(CharClass, Char)]
_)) = String -> [String] -> [String]
emit String
acc     ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [(CharClass, Char)] -> [String]
p [Char
c] [(CharClass, Char)]
cs
    p String
acc ((CharClass
L,Char
c) : cs :: [(CharClass, Char)]
cs@((CharClass
U,Char
_) : [(CharClass, Char)]
_)) = String -> [String] -> [String]
emit (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [(CharClass, Char)] -> [String]
p [] [(CharClass, Char)]
cs

    -- Discard "other" characters, and break to next component.
    p String
acc ((CharClass
U,Char
c) :     (CharClass
O,Char
_) : [(CharClass, Char)]
cs) = String -> [String] -> [String]
emit (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [(CharClass, Char)] -> [String]
p [] [(CharClass, Char)]
cs
    p String
acc ((CharClass
L,Char
c) :     (CharClass
O,Char
_) : [(CharClass, Char)]
cs) = String -> [String] -> [String]
emit (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [(CharClass, Char)] -> [String]
p [] [(CharClass, Char)]
cs
    p String
acc ((CharClass
O,Char
_) : [(CharClass, Char)]
cs)             = String -> [String] -> [String]
emit String
acc     ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [(CharClass, Char)] -> [String]
p [] [(CharClass, Char)]
cs

    p String
acc [(CharClass
_,Char
c)]                  = String -> [(CharClass, Char)] -> [String]
p (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) []

    emit :: String -> [String] -> [String]
    emit :: String -> [String] -> [String]
emit []  [String]
rest = [String]
rest
    emit String
acc [String]
rest = String -> String
forall a. [a] -> [a]
reverse String
acc String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
rest

data CharClass = U | L | O

-- | Ident to lower case.
-- >>> lowerCase "MyIdent"
-- myident

lowerCase :: String -> Doc
lowerCase :: String -> Doc
lowerCase = String -> Doc
text (String -> Doc) -> (String -> String) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> NameStyle -> String -> String
mkName [] NameStyle
LowerCase

-- | Ident to upper case.
-- >>> upperCase "MyIdent"
-- MYIDENT

upperCase :: String -> Doc
upperCase :: String -> Doc
upperCase = String -> Doc
text (String -> Doc) -> (String -> String) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> NameStyle -> String -> String
mkName [] NameStyle
UpperCase

-- | Ident to camel case.
-- >>> camelCase "my_ident"
-- MyIdent

camelCase :: String -> Doc
camelCase :: String -> Doc
camelCase = String -> Doc
text (String -> Doc) -> (String -> String) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
camelCase_

camelCase_ :: String -> String
camelCase_ :: String -> String
camelCase_ = [String] -> NameStyle -> String -> String
mkName [] NameStyle
CamelCase

-- | To mixed case.
-- >>> mixedCase "my_ident"
-- myIdent

mixedCase :: String -> Doc
mixedCase :: String -> Doc
mixedCase = String -> Doc
text (String -> Doc) -> (String -> String) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> NameStyle -> String -> String
mkName [] NameStyle
MixedCase

-- | To snake case.
-- >>> snakeCase "MyIdent"
-- my_ident

snakeCase :: String -> Doc
snakeCase :: String -> Doc
snakeCase = String -> Doc
text (String -> Doc) -> (String -> String) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
snakeCase_

snakeCase_ :: String -> String
snakeCase_ :: String -> String
snakeCase_ = [String] -> NameStyle -> String -> String
mkName [] NameStyle
SnakeCase

-- ESCAPING

-- | A function that renders a c-like string with escaped characters.
-- Note that although it's called cstring, this can be used with most (all)
-- backend as they seem to mostly share escaping conventions.
-- The c in the name is barely an homage for C being the oldest language in
-- the lot.
--
-- >>> cstring "foobar"
-- "foobar"
--
-- >>> cstring "foobar\""
-- "foobar\""
cstring :: String -> Doc
cstring :: String -> Doc
cstring = String -> Doc
text (String -> Doc) -> (String -> String) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show

-- * Symbols

-- | Print a symbol as typical token name, like "(" as "LPAREN".

symbolToName :: String -> Maybe String
symbolToName :: String -> Maybe String
symbolToName = (String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map String String
symbolTokenMap)

-- | Map from symbol to token name.

symbolTokenMap :: Map String String
symbolTokenMap :: Map String String
symbolTokenMap = [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String, String)]
symbolTokenList

-- | Association list from symbol to token name.

symbolTokenList :: [(String, String)]
symbolTokenList :: [(String, String)]
symbolTokenList =
  [ (String
"{"  , String
"LBRACE")
  , (String
"}"  , String
"RBRACE")
  , (String
"("  , String
"LPAREN")
  , (String
")"  , String
"RPAREN")
  , (String
"["  , String
"LBRACK")
  , (String
"]"  , String
"RBRACK")
  , (String
"[]" , String
"EMPTYBRACK")
  , (String
"."  , String
"DOT")
  , (String
".." , String
"DDOT")
  , (String
"...", String
"ELLIPSIS")
  , (String
","  , String
"COMMA")
  , (String
",," , String
"DCOMMA")
  , (String
";"  , String
"SEMI")
  , (String
";;" , String
"DSEMI")
  , (String
":"  , String
"COLON")
  , (String
"::" , String
"DCOLON")
  , (String
":=" , String
"COLONEQ")
  , (String
"::=", String
"DCOLONEQ")
  , (String
":-" , String
"COLONMINUS")
  , (String
"::-", String
"DCOLONMINUS")
  , (String
":--", String
"COLONDMINUS")
  , (String
"+"  , String
"PLUS")
  , (String
"++" , String
"DPLUS")
  , (String
"+=" , String
"PLUSEQ")
  , (String
"+-" , String
"PLUSMINUS")
  , (String
"-"  , String
"MINUS")
  , (String
"--" , String
"DMINUS")
  , (String
"-=" , String
"MINUSEQ")
  , (String
"-+" , String
"MINUSPLUS")
  , (String
"-*" , String
"MINUSSTAR")
  , (String
"*"  , String
"STAR")
  , (String
"**" , String
"DSTAR")
  , (String
"*=" , String
"STAREQ")
  , (String
"*-" , String
"STARMINUS")
  , (String
"/"  , String
"SLASH")
  , (String
"//" , String
"DSLASH")
  , (String
"/=" , String
"SLASHEQ")
  , (String
"\\" , String
"BACKSLASH")
  , (String
"\\\\",String
"DBACKSLASH")
  , (String
"/\\", String
"WEDGE")
  , (String
"\\/", String
"VEE")
  , (String
"&"  , String
"AMP")
  , (String
"&&" , String
"DAMP")
  , (String
"&=" , String
"AMPEQ")
  , (String
"|"  , String
"BAR")
  , (String
"||" , String
"DBAR")
  , (String
"|=" , String
"BAREQ")
  , (String
"<"  , String
"LT")
  , (String
"<<" , String
"DLT")
  , (String
"<<<", String
"TLT")
  , (String
"<=" , String
"LTEQ")
  , (String
"<<=", String
"DLTEQ")
  , (String
"<<<=",String
"TLTEQ")
  , (String
">"  , String
"GT")
  , (String
">>" , String
"DGT")
  , (String
">>>", String
"TGT")
  , (String
">=" , String
"GTEQ")
  , (String
">>=", String
"DGTEQ")
  , (String
">>>=",String
"TGTEQ")
  , (String
"<>" , String
"LTGT")
  , (String
"="  , String
"EQ")
  , (String
"==" , String
"DEQ")
  , (String
"_"  , String
"UNDERSCORE")
  , (String
"!"  , String
"BANG")
  , (String
"!=" , String
"BANGEQ")
  , (String
"?"  , String
"QUESTION")
  , (String
"?=" , String
"QUESTIONEQ")
  , (String
"#"  , String
"HASH")
  , (String
"##" , String
"DHASH")
  , (String
"###", String
"THASH")
  , (String
"@"  , String
"AT")
  , (String
"@@" , String
"DAT")
  , (String
"@=" , String
"ATEQ")
  , (String
"$"  , String
"DOLLAR")
  , (String
"$$" , String
"DDOLLAR")
  , (String
"%"  , String
"PERCENT")
  , (String
"%%" , String
"DPERCENT")
  , (String
"%=" , String
"PERCENTEQ")
  , (String
"^"  , String
"CARET")
  , (String
"^^" , String
"DCARET")
  , (String
"^=" , String
"CARETEQ")
  , (String
"~"  , String
"TILDE")
  , (String
"~~" , String
"DTILDE")
  , (String
"~=" , String
"TILDEEQ")
  , (String
"'"  , String
"APOSTROPHE")
  , (String
"''" , String
"DAPOSTROPHE")
  , (String
"'''", String
"TAPOSTROPHE")
  , (String
"<-" , String
"LARROW")
  , (String
"->" , String
"RARROW")
  , (String
"<=" , String
"LDARROW")
  , (String
"=>" , String
"RDARROW")
  , (String
"|->", String
"MAPSTO")
  ]