{- 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 , curry3, uncurry3 , singleton, mapHead, spanEnd , duplicatesOn , hasNumericSuffix , (+++), (++++), (+-+), (+.+) , pad, table , mkName, mkNames, NameStyle(..) , lowerCase, upperCase, mixedCase , camelCase, camelCase_ , snakeCase, snakeCase_ , replace , writeFileRep , cstring , getZonedTimeTruncatedToSeconds ) where import Control.Arrow ((&&&)) import Control.DeepSeq (rnf) import Data.Char import Data.List (intercalate) import Data.List.NonEmpty (pattern (:|), (<|)) 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 hiding ((<>)) 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 -- | 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 -- * 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 -- | 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] :[]) -- | 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 -- | 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@ 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) 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