{-
    BNF Converter: Happy Generator
    Copyright (C) 2004  Author:  Markus Forsberg, Aarne Ranta

-}

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module BNFC.Backend.Haskell.CFtoHappy (cf2Happy, convert) where

import Prelude hiding ((<>))

import Data.Foldable (toList)
import Data.List (intersperse)

import BNFC.CF
import BNFC.Backend.Common.StrUtils (escapeChars)
import BNFC.Backend.Haskell.Utils
import BNFC.Options (HappyMode(..), TokenText(..))
import BNFC.PrettyPrint
import BNFC.Utils

-- Type declarations

type Rules       = [(NonTerminal,[(Pattern,Action)])]
type Pattern     = String
type Action      = String
type MetaVar     = String

-- default naming

tokenName :: String
tokenName   = String
"Token"

-- | Generate a happy parser file from a grammar.

cf2Happy
  :: ModuleName -- ^ This module's name.
  -> ModuleName -- ^ Abstract syntax module name.
  -> ModuleName -- ^ Lexer module name.
  -> HappyMode  -- ^ Happy mode.
  -> TokenText  -- ^ Use @ByteString@ or @Text@?
  -> Bool       -- ^ AST is a functor?
  -> CF         -- ^ Grammar.
  -> String     -- ^ Generated code.
cf2Happy :: String
-> String
-> String
-> HappyMode
-> TokenText
-> Bool
-> CF
-> String
cf2Happy String
name String
absName String
lexName HappyMode
mode TokenText
tokenText Bool
functor CF
cf = [String] -> String
unlines
  [ String -> String -> String -> TokenText -> [Cat] -> String
header String
name String
absName String
lexName TokenText
tokenText [Cat]
eps
  , Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ HappyMode -> Bool -> [Cat] -> Doc
declarations HappyMode
mode Bool
functor [Cat]
eps
  , Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ CF -> Bool -> Doc
tokens CF
cf Bool
functor
  , String
delimiter
  , String -> Bool -> TokenText -> CF -> String
specialRules String
absName Bool
functor TokenText
tokenText CF
cf
  , Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Rules -> Doc
prRules String
absName Bool
functor (String -> Bool -> CF -> Rules
rulesForHappy String
absName Bool
functor CF
cf)
  , String
""
  , String -> TokenText -> Bool -> [Cat] -> CF -> String
footer String
absName TokenText
tokenText Bool
functor [Cat]
eps CF
cf
  ]
  where
  eps :: [Cat]
eps = NonEmpty Cat -> [Cat]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty Cat -> [Cat]) -> NonEmpty Cat -> [Cat]
forall a b. (a -> b) -> a -> b
$ CF -> NonEmpty Cat
forall f. CFG f -> NonEmpty Cat
allEntryPoints CF
cf

-- | Construct the header.
header :: ModuleName -> ModuleName -> ModuleName -> TokenText -> [Cat] -> String
header :: String -> String -> String -> TokenText -> [Cat] -> String
header String
modName String
absName String
lexName TokenText
tokenText [Cat]
eps = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ String
"-- This Happy file was machine-generated by the BNF converter"
    , String
"{"
    , String
"{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}"
    , String
"{-# LANGUAGE PatternSynonyms #-}"
    , String
""
    , String
"module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
modName
    , String
"  ( happyError"
    , String
"  , myLexer"
    ]
  , (Cat -> String) -> [Cat] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"  , " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Cat -> String) -> Cat -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
render (Doc -> String) -> (Cat -> Doc) -> Cat -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> Doc
parserName) [Cat]
eps
  , [ String
"  ) where"
    , String
""
    , String
"import Prelude"
    , String
""
    , String
"import qualified " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
absName
    , String
"import " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lexName
    ]
  , TokenText -> [String]
tokenTextImport TokenText
tokenText
  , [ String
""
    , String
"}"
    ]
  ]

-- | The declarations of a happy file.
-- >>> declarations Standard False [Cat "A", Cat "B", ListCat (Cat "B")]
-- %name pA A
-- %name pB B
-- %name pListB ListB
-- -- no lexer declaration
-- %monad { Err } { (>>=) } { return }
-- %tokentype {Token}
--
-- >>> declarations Standard True [Cat "A", Cat "B", ListCat (Cat "B")]
-- %name pA_internal A
-- %name pB_internal B
-- %name pListB_internal ListB
-- -- no lexer declaration
-- %monad { Err } { (>>=) } { return }
-- %tokentype {Token}
declarations :: HappyMode -> Bool -> [Cat] -> Doc
declarations :: HappyMode -> Bool -> [Cat] -> Doc
declarations HappyMode
mode Bool
functor [Cat]
ns = [Doc] -> Doc
vcat
    [ [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Cat -> Doc) -> [Cat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> Doc
generateP [Cat]
ns
    , case HappyMode
mode of
        HappyMode
Standard -> Doc
"-- no lexer declaration"
        HappyMode
GLR      -> Doc
"%lexer { myLexer } { Err _ }",
      Doc
"%monad { Err } { (>>=) } { return }",
      Doc
"%tokentype" Doc -> Doc -> Doc
<+> Doc -> Doc
braces (String -> Doc
text String
tokenName)
    ]
  where
  generateP :: Cat -> Doc
generateP Cat
n = Doc
"%name" Doc -> Doc -> Doc
<+> Cat -> Doc
parserName Cat
n Doc -> Doc -> Doc
<> (if Bool
functor then Doc
"_internal" else Doc
"") Doc -> Doc -> Doc
<+> String -> Doc
text (Cat -> String
identCat Cat
n)

-- The useless delimiter symbol.
delimiter :: String
delimiter :: String
delimiter = String
"\n%%\n"

-- | Generate the list of tokens and their identifiers.
tokens :: CF -> Bool -> Doc
tokens :: CF -> Bool -> Doc
tokens CF
cf Bool
functor
  -- Andreas, 2019-01-02: "%token" followed by nothing is a Happy parse error.
  -- Thus, if we have no tokens, do not output anything.
  | [[String]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[String]]
ts   = Doc
empty
  | Bool
otherwise = Doc
"%token" Doc -> Doc -> Doc
$$ (Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text ([String] -> [Doc]) -> [String] -> [Doc]
forall a b. (a -> b) -> a -> b
$ String -> [[String]] -> [String]
table String
" " [[String]]
ts)
  where
    ts :: [[String]]
ts            = ((String, Int) -> [String]) -> [(String, Int)] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map (String, Int) -> [String]
forall {a}. Show a => (String, a) -> [String]
prToken (CF -> [(String, Int)]
forall f. CFG f -> [(String, Int)]
cfTokens CF
cf) [[String]] -> [[String]] -> [[String]]
forall a. [a] -> [a] -> [a]
++ CF -> Bool -> [[String]]
specialToks CF
cf Bool
functor
    prToken :: (String, a) -> [String]
prToken (String
t,a
k) = [ Doc -> String
render (String -> Doc
convert String
t), String
"{ PT _ (TS _ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")", String
"}" ]

-- Happy doesn't allow characters such as åäö to occur in the happy file. This
-- is however not a restriction, just a naming paradigm in the happy source file.
convert :: String -> Doc
convert :: String -> Doc
convert = Doc -> Doc
quotes (Doc -> Doc) -> (String -> Doc) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text (String -> Doc) -> (String -> String) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
escapeChars

rulesForHappy :: ModuleName -> Bool -> CF -> Rules
rulesForHappy :: String -> Bool -> CF -> Rules
rulesForHappy String
absM Bool
functor CF
cf = [(Cat, [Rule])]
-> ((Cat, [Rule]) -> (Cat, [(String, String)])) -> Rules
forall a b. [a] -> (a -> b) -> [b]
for (CF -> [(Cat, [Rule])]
ruleGroups CF
cf) (((Cat, [Rule]) -> (Cat, [(String, String)])) -> Rules)
-> ((Cat, [Rule]) -> (Cat, [(String, String)])) -> Rules
forall a b. (a -> b) -> a -> b
$ \ (Cat
cat, [Rule]
rules) ->
  (Cat
cat, (Rule -> (String, String)) -> [Rule] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Bool -> Rule -> (String, String)
forall f. IsFun f => String -> Bool -> Rul f -> (String, String)
constructRule String
absM Bool
functor) [Rule]
rules)

-- | For every non-terminal, we construct a set of rules. A rule is a sequence
-- of terminals and non-terminals, and an action to be performed.
--
-- >>> constructRule "Foo" False (npRule "EPlus" (Cat "Exp") [Left (Cat "Exp"), Right "+", Left (Cat "Exp")] Parsable)
-- ("Exp '+' Exp","Foo.EPlus $1 $3")
--
-- If we're using functors, it adds position value:
--
-- >>> constructRule "Foo" True (npRule "EPlus" (Cat "Exp") [Left (Cat "Exp"), Right "+", Left (Cat "Exp")] Parsable)
-- ("Exp '+' Exp","(fst $1, Foo.EPlus (fst $1) (snd $1) (snd $3))")
--
-- List constructors should not be prefixed by the abstract module name:
--
-- >>> constructRule "Foo" False (npRule "(:)" (ListCat (Cat "A")) [Left (Cat "A"), Right",", Left (ListCat (Cat "A"))] Parsable)
-- ("A ',' ListA","(:) $1 $3")
--
-- >>> constructRule "Foo" False (npRule "(:[])" (ListCat (Cat "A")) [Left (Cat "A")] Parsable)
-- ("A","(:[]) $1")
--
-- Coercion are much simpler:
--
-- >>> constructRule "Foo" True (npRule "_" (Cat "Exp") [Right "(", Left (Cat "Exp"), Right ")"] Parsable)
-- ("'(' Exp ')'","(uncurry Foo.BNFC'Position (tokenLineCol $1), (snd $2))")
--
constructRule :: IsFun f => String -> Bool -> Rul f -> (Pattern, Action)
constructRule :: forall f. IsFun f => String -> Bool -> Rul f -> (String, String)
constructRule String
absName Bool
functor (Rule f
fun0 RCat
_cat SentForm
rhs InternalRule
Parsable) = (String
pat, String
action)
  where
    fun :: String
fun = f -> String
forall a. IsFun a => a -> String
funName f
fun0
    (String
pat, [String]
metavars) = Bool -> SentForm -> (String, [String])
generatePatterns Bool
functor SentForm
rhs
    action :: String
action
      | Bool
functor   = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String) -> String
actionPos String -> String
forall a. a -> a
id String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
actionValue String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
      | Bool
otherwise = String
actionValue
    actionPos :: (String -> String) -> String
actionPos String -> String
paren = case SentForm
rhs of
      []          -> String -> String
qualify String
forall a. IsString a => a
noPosConstr
      (Left Cat
_:SentForm
_)  -> String -> String
paren String
"fst $1"
      (Right String
_:SentForm
_) -> String -> String
paren (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [ String
"uncurry", String -> String
qualify String
forall a. IsString a => a
posConstr , String
"(tokenLineCol $1)" ]
    actionValue :: String
actionValue
      | String -> Bool
forall a. IsFun a => a -> Bool
isCoercion String
fun = [String] -> String
unwords [String]
metavars
      | String -> Bool
forall a. IsFun a => a -> Bool
isNilCons  String
fun = [String] -> String
unwords (String -> String
qualify String
fun String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
metavars)
      | Bool
functor        = [String] -> String
unwords (String -> String
qualify String
fun String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String) -> String
actionPos (\ String
x -> String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
metavars)
      | Bool
otherwise      = [String] -> String
unwords (String -> String
qualify String
fun String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
metavars)
    qualify :: String -> String
qualify String
f
      | String -> Bool
forall a. IsFun a => a -> Bool
isConsFun String
f Bool -> Bool -> Bool
|| String -> Bool
forall a. IsFun a => a -> Bool
isNilCons String
f = String
f
      | String -> Bool
forall a. IsFun a => a -> Bool
isDefinedRule String
f = String
absName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. IsFun a => a -> String
mkDefName String
f
      | Bool
otherwise       = String
absName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f
constructRule String
_ Bool
_ (Rule f
_ RCat
_ SentForm
_ InternalRule
Internal) = (String, String)
forall a. HasCallStack => a
undefined -- impossible


-- | Generate patterns and a set of metavariables (de Bruijn indices) indicating
--   where in the pattern the non-terminal are locate.
--
-- >>> generatePatterns False [ Left (Cat "Exp"), Right "+", Left (Cat "Exp") ]
-- ("Exp '+' Exp",["$1","$3"])
--
-- >>> generatePatterns True [ Left (Cat "Exp"), Right "+", Left (Cat "Exp") ]
-- ("Exp '+' Exp",["(snd $1)","(snd $3)"])
--
generatePatterns :: Bool -> SentForm -> (Pattern, [MetaVar])
generatePatterns :: Bool -> SentForm -> (String, [String])
generatePatterns Bool
_       []  = (String
"{- empty -}", [])
generatePatterns Bool
functor SentForm
its =
  ( [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ SentForm -> (Either Cat String -> String) -> [String]
forall a b. [a] -> (a -> b) -> [b]
for SentForm
its ((Either Cat String -> String) -> [String])
-> (Either Cat String -> String) -> [String]
forall a b. (a -> b) -> a -> b
$ (Cat -> String)
-> (String -> String) -> Either Cat String -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either {-non-term:-} Cat -> String
identCat {-term:-} (Doc -> String
render (Doc -> String) -> (String -> Doc) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
convert)
  , [ if Bool
functor then String
"(snd $" 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
")" else (Char
'$' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
i) | (Int
i, Left{}) <- [Int] -> SentForm -> [(Int, Either Cat String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] SentForm
its ]
  )

-- We have now constructed the patterns and actions,
-- so the only thing left is to merge them into one string.

-- |
-- >>> prRules "Foo" False [(Cat "Expr", [("Integer", "Foo.EInt $1"), ("Expr '+' Expr", "Foo.EPlus $1 $3")])]
-- Expr :: { Foo.Expr }
-- Expr : Integer { Foo.EInt $1 } | Expr '+' Expr { Foo.EPlus $1 $3 }
--
-- if there's a lot of cases, print on several lines:
-- >>> prRules "" False [(Cat "Expr", [("Abcd", "Action"), ("P2", "A2"), ("P3", "A3"), ("P4", "A4"), ("P5","A5"), ("P6", "A6"), ("P7", "A7"), ("P8", "A8"), ("P9","A9")])]
-- Expr :: { Expr }
-- Expr
--   : Abcd { Action }
--   | P2 { A2 }
--   | P3 { A3 }
--   | P4 { A4 }
--   | P5 { A5 }
--   | P6 { A6 }
--   | P7 { A7 }
--   | P8 { A8 }
--   | P9 { A9 }
--
-- >>> prRules "" False [(Cat "Internal", [])] -- nt has only internal use
-- <BLANKLINE>
--
-- The functor case:
-- >>> prRules "" True [(Cat "Expr", [("Integer", "EInt () $1"), ("Expr '+' Expr", "EPlus () $1 $3")])]
-- Expr :: { (BNFC'Position, Expr) }
-- Expr : Integer { EInt () $1 } | Expr '+' Expr { EPlus () $1 $3 }
--
-- A list with coercion: in the type signature we need to get rid of the
-- coercion.
--
-- >>> prRules "" True [(ListCat (CoercCat "Exp" 2), [("Exp2", "(:[]) $1"), ("Exp2 ',' ListExp2","(:) $1 $3")])]
-- ListExp2 :: { (BNFC'Position, [Exp]) }
-- ListExp2 : Exp2 { (:[]) $1 } | Exp2 ',' ListExp2 { (:) $1 $3 }
--
prRules :: ModuleName -> Bool -> Rules -> Doc
prRules :: String -> Bool -> Rules -> Doc
prRules String
absM Bool
functor = [Doc] -> Doc
vsep ([Doc] -> Doc) -> (Rules -> [Doc]) -> Rules -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Cat, [(String, String)]) -> Doc) -> Rules -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Cat, [(String, String)]) -> Doc
prOne
  where
    prOne :: (Cat, [(String, String)]) -> Doc
prOne (Cat
_ , []      ) = Doc
empty -- nt has only internal use
    prOne (Cat
nt, (String
p,String
a):[(String, String)]
ls) = [Doc] -> Doc
vcat
        [ [Doc] -> Doc
hsep [ Doc
nt', Doc
"::", Doc
"{", if Bool
functor then Cat -> Doc
functorType' Cat
nt else Cat -> Doc
type' Cat
nt, Doc
"}" ]
        , Doc -> Int -> Doc -> Doc
hang Doc
nt' Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep (Doc -> (String, String) -> Doc
pr Doc
":" (String
p, String
a) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: ((String, String) -> Doc) -> [(String, String)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> (String, String) -> Doc
pr Doc
"|") [(String, String)]
ls)
        ]
      where
        nt' :: Doc
nt'          = String -> Doc
text (Cat -> String
identCat Cat
nt)
        pr :: Doc -> (String, String) -> Doc
pr Doc
pre (String
p,String
a) = [Doc] -> Doc
hsep [Doc
pre, String -> Doc
text String
p, Doc
"{", String -> Doc
text String
a , Doc
"}"]
    type' :: Cat -> Doc
type'            = (Doc -> Doc) -> Doc -> Cat -> Doc
catToType Doc -> Doc
qualify Doc
empty
    functorType' :: Cat -> Doc
functorType' Cat
nt  = [Doc] -> Doc
hcat [Doc
"(", Doc -> Doc
qualify Doc
forall a. IsString a => a
posType, Doc
", ", Cat -> Doc
type' Cat
nt, Doc
")"]
    qualify :: Doc -> Doc
qualify
      | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
absM = Doc -> Doc
forall a. a -> a
id
      | Bool
otherwise = ((String -> Doc
text String
absM Doc -> Doc -> Doc
<> Doc
".") Doc -> Doc -> Doc
<>)

-- Finally, some haskell code.

footer :: ModuleName -> TokenText -> Bool -> [Cat] -> CF -> String
footer :: String -> TokenText -> Bool -> [Cat] -> CF -> String
footer String
absName TokenText
tokenText Bool
functor [Cat]
eps CF
cf = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ String
"{"
    , String
""
    , String
"type Err = Either String"
    , String
""
    , String
"happyError :: [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tokenName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"] -> Err a"
    , String
"happyError ts = Left $"
    , String
"  \"syntax error at \" ++ tokenPos ts ++ "
    , String
"  case ts of"
    , String
"    []      -> []"
    , String
"    [Err _] -> \" due to lexer error\""
    , [String] -> String
unwords
      [ String
"    t:_     -> \" before `\" ++"
      , String
"(prToken t)"
      -- , tokenTextUnpack tokenText "(prToken t)"
      , String
"++ \"'\""
      ]
    , String
""
    , String
"myLexer :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TokenText -> String
tokenTextType TokenText
tokenText String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tokenName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
    , String
"myLexer = tokens"
    , String
""
    ]
  , Bool -> [String] -> [String]
forall m. Monoid m => Bool -> m -> m
when Bool
functor
    [ String
"-- Entrypoints"
    , String
""
    , Doc -> String
render (Doc -> String) -> ([Doc] -> Doc) -> [Doc] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
vsep ([Doc] -> String) -> [Doc] -> String
forall a b. (a -> b) -> a -> b
$ (Cat -> Doc) -> [Cat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> Doc
mkParserFun [Cat]
eps
    ]
  , [ String
"}" ]
  ]
  where
    mkParserFun :: Cat -> Doc
mkParserFun Cat
cat = [Doc] -> Doc
vcat
      [ Cat -> Doc
parserName Cat
cat Doc -> Doc -> Doc
<+> Doc
"::" Doc -> Doc -> Doc
<+> Doc -> Doc
brackets (String -> Doc
text String
tokenName) Doc -> Doc -> Doc
<+> Doc
"-> Err" Doc -> Doc -> Doc
<+> (Doc -> Doc) -> Doc -> Cat -> Doc
catToType Doc -> Doc
qualify Doc
empty Cat
cat
      , Cat -> Doc
parserName Cat
cat Doc -> Doc -> Doc
<+> Doc
"=" Doc -> Doc -> Doc
<+>  Doc
"fmap snd" Doc -> Doc -> Doc
<+> Doc
"." Doc -> Doc -> Doc
<+> Cat -> Doc
parserName Cat
cat Doc -> Doc -> Doc
<> Doc
"_internal"
      ]
    qualify :: Doc -> Doc
qualify
      | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
absName = Doc -> Doc
forall a. a -> a
id
      | Bool
otherwise    = ((String -> Doc
text String
absName Doc -> Doc -> Doc
<> Doc
".") Doc -> Doc -> Doc
<>)

-- | GF literals.
specialToks :: CF -> Bool -> [[String]]  -- ^ A table with three columns (last is "}").
specialToks :: CF -> Bool -> [[String]]
specialToks CF
cf Bool
functor = ((String -> [String]) -> [String] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
`map` CF -> [String]
forall f. CFG f -> [String]
literals CF
cf) ((String -> [String]) -> [[String]])
-> (String -> [String]) -> [[String]]
forall a b. (a -> b) -> a -> b
$ \String
t -> case String
t of
  String
"Ident"   -> [ String
"L_Ident" , String
"{ PT _ (TV " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall {p}. IsString p => String -> p
posn String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")", String
"}" ]
  String
"String"  -> [ String
"L_quoted", String
"{ PT _ (TL " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall {p}. IsString p => String -> p
posn String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")", String
"}" ]
  String
"Integer" -> [ String
"L_integ ", String
"{ PT _ (TI " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall {p}. IsString p => String -> p
posn String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")", String
"}" ]
  String
"Double"  -> [ String
"L_doubl ", String
"{ PT _ (TD " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall {p}. IsString p => String -> p
posn String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")", String
"}" ]
  String
"Char"    -> [ String
"L_charac", String
"{ PT _ (TC " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall {p}. IsString p => String -> p
posn String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")", String
"}" ]
  String
own       -> [ String
"L_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
own,String
"{ PT _ (T_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
own String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall {p}. IsString p => String -> p
posn String
own String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")", String
"}" ]
  where
    posn :: String -> p
posn String
tokenCat = if CF -> String -> Bool
forall f. CFG f -> String -> Bool
isPositionCat CF
cf String
tokenCat Bool -> Bool -> Bool
|| Bool
functor then p
"_" else p
"$$"

specialRules :: ModuleName -> Bool -> TokenText -> CF -> String
specialRules :: String -> Bool -> TokenText -> CF -> String
specialRules String
absName Bool
functor TokenText
tokenText CF
cf = [String] -> String
unlines ([String] -> String)
-> ((String -> String) -> [String]) -> (String -> String) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"" ([String] -> [String])
-> ((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` CF -> [String]
forall f. CFG f -> [String]
literals CF
cf) ((String -> String) -> String) -> (String -> String) -> String
forall a b. (a -> b) -> a -> b
$ \String
t -> case String
t of
    -- "Ident"   -> "Ident   :: { Ident }"
    --         ++++ "Ident    : L_ident  { Ident $1 }"
    String
"String"  -> String
"String  :: { " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
mkTypePart String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" }"
            String -> String -> String
++++ String
"String   : L_quoted { " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
mkBodyPart String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" }"
    String
"Integer" -> String
"Integer :: { " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
mkTypePart String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" }"
            String -> String -> String
++++ String
"Integer  : L_integ  { " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
mkBodyPart String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" }"
    String
"Double"  -> String
"Double  :: { " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
mkTypePart String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" }"
            String -> String -> String
++++ String
"Double   : L_doubl  { " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
mkBodyPart String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" }"
    String
"Char"    -> String
"Char    :: { " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
mkTypePart String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" }"
            String -> String -> String
++++ String
"Char     : L_charac { " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
mkBodyPart String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" }"
    String
own       -> String
own String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: { " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
mkTypePart (String -> String
qualify String
own) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" }"
            String -> String -> String
++++ String
own String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  : L_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
own String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" { " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
mkBodyPart String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" }"
  where
    mkTypePart :: String -> String
mkTypePart String
tokenCat = if Bool
functor then [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"(", String -> String
qualify String
forall a. IsString a => a
posType, String
", ", String
tokenCat, String
")" ] else String
tokenCat
    mkBodyPart :: String -> String
mkBodyPart String
tokenCat
      | Bool
functor   = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String
"uncurry", String -> String
qualify String
forall a. IsString a => a
posConstr, String
"(tokenLineCol $1)"] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
mkValPart String
tokenCat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
      | Bool
otherwise = String -> String
mkValPart String
tokenCat
    mkValPart :: String -> String
mkValPart String
tokenCat =
      case String
tokenCat of
        String
"String"  -> if Bool
functor then String -> String
stringUnpack String
"((\\(PT _ (TL s)) -> s) $1)"
                                else String -> String
stringUnpack String
"$1"                                 -- String never has pos
        String
"Integer" -> if Bool
functor then String
"(read " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
stringUnpack String
"(tokenText $1)" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") :: Integer"
                                else String
"(read " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
stringUnpack String
"$1" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") :: Integer" -- Integer never has pos
        String
"Double"  -> if Bool
functor then String
"(read " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
stringUnpack String
"(tokenText $1)" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") :: Double"
                                else String
"(read " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
stringUnpack String
"$1" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") :: Double"  -- Double never has pos
        String
"Char"    -> if Bool
functor then String
"(read " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
stringUnpack String
"(tokenText $1)" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") :: Char"
                                else String
"(read " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
stringUnpack String
"$1" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") :: Char"    -- Char never has pos
        String
own       ->
          case Bool
functor of
            Bool
False ->
              case CF -> String -> Bool
forall f. CFG f -> String -> Bool
isPositionCat CF
cf String
tokenCat of
                Bool
False -> String -> String
qualify String
own String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" $1"
                Bool
True  -> String -> String
qualify String
own String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (mkPosToken $1)"
            Bool
True  ->
              case CF -> String -> Bool
forall f. CFG f -> String -> Bool
isPositionCat CF
cf String
tokenCat of
                Bool
False -> String -> String
qualify String
own String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (tokenText $1)"
                Bool
True  -> String -> String
qualify String
own String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (mkPosToken $1)"
    stringUnpack :: String -> String
stringUnpack = TokenText -> String -> String
tokenTextUnpack TokenText
tokenText
    qualify :: String -> String
qualify
      | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
absName = String -> String
forall a. a -> a
id
      | Bool
otherwise    = ((String
absName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".") String -> String -> String
forall a. [a] -> [a] -> [a]
++)