{-
    BNF Converter: Abstract syntax
    Copyright (C) 2004  Author:  Aarne Ranta

-}

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

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)
import Data.Semigroup     (Semigroup(..))
import Data.Time

import qualified Data.Foldable      as Fold
import qualified Data.Map           as Map
import qualified Data.Set           as Set
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 :: forall m. Monoid m => 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 :: forall m. Monoid m => 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 :: forall a. 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 :: forall a. 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 :: forall m a. Monoid m => [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' :: forall m a. Monoid m => [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 >.> :: forall a b c. (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 :: forall a b. [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 :: forall m a. Monoid m => 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 :: forall a b. 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 :: forall a b c d. ((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 :: forall a b c d. (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 :: forall a b. ([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 :: forall a. 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 :: forall a. 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 :: forall a. (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 :: forall a. (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 :: forall a. Eq a => 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 :: forall (t :: * -> *) b a.
(Foldable t, Ord b) =>
(a -> b) -> t a -> [List1 a]
duplicatesOn a -> b
nf
    -- Keep groups of size >= 2.
  = (NonEmpty a -> Bool) -> [NonEmpty a] -> [NonEmpty a]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int
2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=) (Int -> Bool) -> (NonEmpty a -> Int) -> NonEmpty a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty a -> Int
forall a. NonEmpty a -> Int
List1.length)
    -- Turn into a list of listss: elements grouped by their normal form.
  ([NonEmpty a] -> [NonEmpty a])
-> (t a -> [NonEmpty a]) -> t a -> [NonEmpty a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map b (NonEmpty a) -> [NonEmpty a]
forall k a. Map k a -> [a]
Map.elems
    -- Partition elements by their normal form.
  (Map b (NonEmpty a) -> [NonEmpty a])
-> (t a -> Map b (NonEmpty a)) -> t a -> [NonEmpty a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Map b (NonEmpty a) -> Map b (NonEmpty a))
-> Map b (NonEmpty a) -> t a -> Map b (NonEmpty a)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
Fold.foldr (\ a
a -> (NonEmpty a -> NonEmpty a -> NonEmpty a)
-> b -> NonEmpty a -> Map b (NonEmpty a) -> Map b (NonEmpty a)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith NonEmpty a -> NonEmpty a -> NonEmpty a
forall a. Semigroup a => a -> a -> a
(<>) (a -> b
nf a
a) (a
a a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [])) Map b (NonEmpty 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 :: forall b a. Eq b => (a -> b) -> [a] -> [List1 a]
groupOn a -> b
nf = [a] -> [NonEmpty a]
loop
  where
  loop :: [a] -> [NonEmpty 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] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
as) NonEmpty a -> [NonEmpty a] -> [NonEmpty a]
forall a. a -> [a] -> [a]
: [a] -> [NonEmpty a]
loop [a]
rest

-- | Keep only the first of consecutive elements that have the same normalform.
uniqOn :: Eq b => (a -> b) -> [a] -> [a]
uniqOn :: forall b a. Eq b => (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
s')) TimeZone
zone
  where s' :: Pico
s' = Integer -> Pico
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Pico) -> Integer -> Pico
forall a b. (a -> b) -> a -> b
$ Pico -> Integer
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
s
      | String
s String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
reserved = String -> String
notReserved (String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_")
      | Bool
otherwise = String
s
    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
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
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 -> case (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> String
capitalize [String]
tokens of
                         String
"" -> String
""
                         Char
c:String
cs -> Char -> Char
toLower Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
cs
        NameStyle
SnakeCase -> (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"_" [String]
tokens)
        NameStyle
OrigCase  -> String
s
    capitalize :: String -> String
capitalize [] = []
    capitalize (Char
c:String
cs) = Char -> Char
toUpper Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
cs

-- | 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")
  ]