module BNFC.Backend.Haskell.Options where

import BNFC.Prelude

import Data.List (intercalate)

import Options.Applicative

data HaskellBackendOptions = HaskellOpts
  { HaskellBackendOptions -> Maybe String
nameSpace   :: Maybe String
  , HaskellBackendOptions -> Bool
inDir       :: Bool
  , HaskellBackendOptions -> TokenText
tokenText   :: TokenText
  , HaskellBackendOptions -> Bool
functor     :: Bool
  , HaskellBackendOptions -> Bool
generic     :: Bool
  , HaskellBackendOptions -> Bool
xml         :: Bool
  , HaskellBackendOptions -> Bool
xmlt        :: Bool
  , HaskellBackendOptions -> Bool
gadt        :: Bool
  }

haskellOptionsParser :: Parser HaskellBackendOptions
haskellOptionsParser :: Parser HaskellBackendOptions
haskellOptionsParser = Maybe String
-> Bool
-> TokenText
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> HaskellBackendOptions
HaskellOpts
    (Maybe String
 -> Bool
 -> TokenText
 -> Bool
 -> Bool
 -> Bool
 -> Bool
 -> Bool
 -> HaskellBackendOptions)
-> Parser (Maybe String)
-> Parser
     (Bool
      -> TokenText
      -> Bool
      -> Bool
      -> Bool
      -> Bool
      -> Bool
      -> HaskellBackendOptions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Maybe String)
oNameSpace
    Parser
  (Bool
   -> TokenText
   -> Bool
   -> Bool
   -> Bool
   -> Bool
   -> Bool
   -> HaskellBackendOptions)
-> Parser Bool
-> Parser
     (TokenText
      -> Bool -> Bool -> Bool -> Bool -> Bool -> HaskellBackendOptions)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
oInDir
    Parser
  (TokenText
   -> Bool -> Bool -> Bool -> Bool -> Bool -> HaskellBackendOptions)
-> Parser TokenText
-> Parser
     (Bool -> Bool -> Bool -> Bool -> Bool -> HaskellBackendOptions)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser TokenText
oTokenText
    Parser
  (Bool -> Bool -> Bool -> Bool -> Bool -> HaskellBackendOptions)
-> Parser Bool
-> Parser (Bool -> Bool -> Bool -> Bool -> HaskellBackendOptions)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
oFunctor
    Parser (Bool -> Bool -> Bool -> Bool -> HaskellBackendOptions)
-> Parser Bool
-> Parser (Bool -> Bool -> Bool -> HaskellBackendOptions)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
oGeneric
    Parser (Bool -> Bool -> Bool -> HaskellBackendOptions)
-> Parser Bool -> Parser (Bool -> Bool -> HaskellBackendOptions)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
oXml
    Parser (Bool -> Bool -> HaskellBackendOptions)
-> Parser Bool -> Parser (Bool -> HaskellBackendOptions)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
oXmlt
    Parser (Bool -> HaskellBackendOptions)
-> Parser Bool -> Parser HaskellBackendOptions
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
oGadt

  where

    -- name-space option
    oNameSpace :: Parser (Maybe String)
oNameSpace =
      Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser String -> Parser (Maybe String))
-> Parser String -> Parser (Maybe String)
forall a b. (a -> b) -> a -> b
$
      Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
          ( Char -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'p'
          Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"name-space"
          Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Prepend NAMESPACE to the package/module name"
          Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"NAMESPACE")

    -- inDir option
    oInDir :: Parser Bool
oInDir =
      Mod FlagFields Bool -> Parser Bool
switch
          ( Char -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'd'
         Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Put Haskell code in modules LANG.* instead of LANG* (recommended)" )

    -- tokenText option
    oTokenText :: Parser TokenText
oTokenText =
      ReadM TokenText -> Mod OptionFields TokenText -> Parser TokenText
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM TokenText
tokenTextReader
          ( String -> Mod OptionFields TokenText
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"token-text"
         Mod OptionFields TokenText
-> Mod OptionFields TokenText -> Mod OptionFields TokenText
forall a. Semigroup a => a -> a -> a
<> TokenText -> Mod OptionFields TokenText
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value TokenText
StringToken
         Mod OptionFields TokenText
-> Mod OptionFields TokenText -> Mod OptionFields TokenText
forall a. Semigroup a => a -> a -> a
<> (TokenText -> String) -> Mod OptionFields TokenText
forall a (f :: * -> *). (a -> String) -> Mod f a
showDefaultWith TokenText -> String
showTokenText
         Mod OptionFields TokenText
-> Mod OptionFields TokenText -> Mod OptionFields TokenText
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields TokenText
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"TYPE"
         Mod OptionFields TokenText
-> Mod OptionFields TokenText -> Mod OptionFields TokenText
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields TokenText
forall (f :: * -> *) a. String -> Mod f a
help (String
"How to represent token content in the Haskell backend ("
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((TokenText -> String) -> [TokenText] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map TokenText -> String
showTokenText [TokenText
forall a. Bounded a => a
minBound..TokenText
forall a. Bounded a => a
maxBound]) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"))

    -- functor option
    oFunctor :: Parser Bool
oFunctor =
      Mod FlagFields Bool -> Parser Bool
switch
          ( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"functor"
         Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Make the AST a functor and use it to store the position of the nodes" )

    -- generic option
    oGeneric :: Parser Bool
oGeneric =
      Mod FlagFields Bool -> Parser Bool
switch
          ( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"generic"
         Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Derive Data, Generic, and Typeable instances for AST types" )

    -- xml option
    oXml :: Parser Bool
oXml =
      Mod FlagFields Bool -> Parser Bool
switch
          ( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"xml"
         Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Also generate a DTD and an XML printer" )

    -- xmlt option
    oXmlt :: Parser Bool
oXmlt =
      Mod FlagFields Bool -> Parser Bool
switch
          ( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"xmlt"
         Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"DTD and an XML printer, another encoding" )

    -- gadt option
    oGadt :: Parser Bool
oGadt =
      Mod FlagFields Bool -> Parser Bool
switch
          ( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"gadt"
         Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Output Haskell code which uses GADTs" )

tokenTextReader :: ReadM TokenText
tokenTextReader :: ReadM TokenText
tokenTextReader = (String -> Maybe TokenText) -> ReadM TokenText
forall a. (String -> Maybe a) -> ReadM a
maybeReader ((String -> Maybe TokenText) -> ReadM TokenText)
-> (String -> Maybe TokenText) -> ReadM TokenText
forall a b. (a -> b) -> a -> b
$ \case
  String
"string"     -> TokenText -> Maybe TokenText
forall a. a -> Maybe a
Just TokenText
StringToken
  String
"text"       -> TokenText -> Maybe TokenText
forall a. a -> Maybe a
Just TokenText
TextToken
  String
_            -> Maybe TokenText
forall a. Maybe a
Nothing

showTokenText :: TokenText -> String
showTokenText :: TokenText -> String
showTokenText = \case
  TokenText
StringToken     -> String
"string"
  TokenText
TextToken       -> String
"text"

-- | How to represent token content in the Haskell backend?

data TokenText
  = StringToken      -- ^ Represent strings as @String@.
  | TextToken        -- ^ Represent strings as @Data.Text@.
  deriving (TokenText
TokenText -> TokenText -> Bounded TokenText
forall a. a -> a -> Bounded a
maxBound :: TokenText
$cmaxBound :: TokenText
minBound :: TokenText
$cminBound :: TokenText
Bounded , Int -> TokenText
TokenText -> Int
TokenText -> [TokenText]
TokenText -> TokenText
TokenText -> TokenText -> [TokenText]
TokenText -> TokenText -> TokenText -> [TokenText]
(TokenText -> TokenText)
-> (TokenText -> TokenText)
-> (Int -> TokenText)
-> (TokenText -> Int)
-> (TokenText -> [TokenText])
-> (TokenText -> TokenText -> [TokenText])
-> (TokenText -> TokenText -> [TokenText])
-> (TokenText -> TokenText -> TokenText -> [TokenText])
-> Enum TokenText
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: TokenText -> TokenText -> TokenText -> [TokenText]
$cenumFromThenTo :: TokenText -> TokenText -> TokenText -> [TokenText]
enumFromTo :: TokenText -> TokenText -> [TokenText]
$cenumFromTo :: TokenText -> TokenText -> [TokenText]
enumFromThen :: TokenText -> TokenText -> [TokenText]
$cenumFromThen :: TokenText -> TokenText -> [TokenText]
enumFrom :: TokenText -> [TokenText]
$cenumFrom :: TokenText -> [TokenText]
fromEnum :: TokenText -> Int
$cfromEnum :: TokenText -> Int
toEnum :: Int -> TokenText
$ctoEnum :: Int -> TokenText
pred :: TokenText -> TokenText
$cpred :: TokenText -> TokenText
succ :: TokenText -> TokenText
$csucc :: TokenText -> TokenText
Enum, TokenText -> TokenText -> Bool
(TokenText -> TokenText -> Bool)
-> (TokenText -> TokenText -> Bool) -> Eq TokenText
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TokenText -> TokenText -> Bool
$c/= :: TokenText -> TokenText -> Bool
== :: TokenText -> TokenText -> Bool
$c== :: TokenText -> TokenText -> Bool
Eq, Eq TokenText
Eq TokenText
-> (TokenText -> TokenText -> Ordering)
-> (TokenText -> TokenText -> Bool)
-> (TokenText -> TokenText -> Bool)
-> (TokenText -> TokenText -> Bool)
-> (TokenText -> TokenText -> Bool)
-> (TokenText -> TokenText -> TokenText)
-> (TokenText -> TokenText -> TokenText)
-> Ord TokenText
TokenText -> TokenText -> Bool
TokenText -> TokenText -> Ordering
TokenText -> TokenText -> TokenText
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TokenText -> TokenText -> TokenText
$cmin :: TokenText -> TokenText -> TokenText
max :: TokenText -> TokenText -> TokenText
$cmax :: TokenText -> TokenText -> TokenText
>= :: TokenText -> TokenText -> Bool
$c>= :: TokenText -> TokenText -> Bool
> :: TokenText -> TokenText -> Bool
$c> :: TokenText -> TokenText -> Bool
<= :: TokenText -> TokenText -> Bool
$c<= :: TokenText -> TokenText -> Bool
< :: TokenText -> TokenText -> Bool
$c< :: TokenText -> TokenText -> Bool
compare :: TokenText -> TokenText -> Ordering
$ccompare :: TokenText -> TokenText -> Ordering
$cp1Ord :: Eq TokenText
Ord, Int -> TokenText -> String -> String
[TokenText] -> String -> String
TokenText -> String
(Int -> TokenText -> String -> String)
-> (TokenText -> String)
-> ([TokenText] -> String -> String)
-> Show TokenText
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [TokenText] -> String -> String
$cshowList :: [TokenText] -> String -> String
show :: TokenText -> String
$cshow :: TokenText -> String
showsPrec :: Int -> TokenText -> String -> String
$cshowsPrec :: Int -> TokenText -> String -> String
Show)

isStringToken :: TokenText -> Bool
isStringToken :: TokenText -> Bool
isStringToken = \case
  TokenText
StringToken -> Bool
True
  TokenText
TextToken   -> Bool
False

isTextToken :: TokenText -> Bool
isTextToken :: TokenText -> Bool
isTextToken = \case
  TokenText
StringToken -> Bool
False
  TokenText
TextToken   -> Bool
True

printHaskellOptions :: HaskellBackendOptions -> String
printHaskellOptions :: HaskellBackendOptions -> String
printHaskellOptions HaskellBackendOptions
opts = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
  [ String
nSpace, String
dir, String
tt, String
funct, String
gen, String
xml', String
xmlt', String
gadt' ]

  where

    nSpace :: String
nSpace = case HaskellBackendOptions -> Maybe String
nameSpace HaskellBackendOptions
opts of
      Just String
n -> String
"-p " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n
      Maybe String
Nothing -> String
""

    dir :: String
dir = if HaskellBackendOptions -> Bool
inDir HaskellBackendOptions
opts then String
"-d" else String
""

    tt :: String
tt = case HaskellBackendOptions -> TokenText
tokenText HaskellBackendOptions
opts of
      TokenText
StringToken -> String
""
      TokenText
TextToken -> String
"--token-text text"

    funct :: String
funct = if HaskellBackendOptions -> Bool
functor HaskellBackendOptions
opts then String
"--functor" else String
""

    gen :: String
gen = if HaskellBackendOptions -> Bool
generic HaskellBackendOptions
opts then String
"--generic" else String
""

    xml' :: String
xml' = if HaskellBackendOptions -> Bool
xml HaskellBackendOptions
opts then String
"--xml" else String
""

    xmlt' :: String
xmlt' = if HaskellBackendOptions -> Bool
xml HaskellBackendOptions
opts then String
"--xmlt" else String
""

    gadt' :: String
gadt' = if HaskellBackendOptions -> Bool
gadt HaskellBackendOptions
opts then String
"--gadt" else String
""