{-
    BNF Converter: ocamlyacc Generator
    Copyright (C) 2005  Author:  Kristofer Johannisson

-}

-- based on BNFC Haskell backend

{-# LANGUAGE LambdaCase #-}

module BNFC.Backend.OCaml.CFtoOCamlYacc
       (
       cf2ocamlyacc, terminal, epName
       )
        where

import Data.Char
import Data.Foldable ( toList )
import Data.List     ( intercalate )

import BNFC.CF
import BNFC.Options  ( OCamlParser(..) )
import BNFC.Utils    ( (+++), mapHead, table )
import BNFC.Backend.Common
import BNFC.Backend.OCaml.OCamlUtil

-- Type declarations

type Pattern     = String
type Action      = String
type MetaVar     = String

-- The main function, that given a CF
-- generates a ocamlyacc module.
cf2ocamlyacc :: OCamlParser -> String -> CF -> String
cf2ocamlyacc :: OCamlParser -> TokenCat -> CF -> TokenCat
cf2ocamlyacc OCamlParser
ocamlParser TokenCat
absName CF
cf = [TokenCat] -> TokenCat
unlines
  [ OCamlParser -> TokenCat -> TokenCat
header OCamlParser
ocamlParser TokenCat
absName
  , TokenCat -> CF -> TokenCat
declarations TokenCat
absName CF
cf
  , TokenCat
"%%"
  , TokenCat
""
  , OCamlParser -> CF -> TokenCat
rules OCamlParser
ocamlParser CF
cf
  ]


header :: OCamlParser -> String -> String
header :: OCamlParser -> TokenCat -> TokenCat
header OCamlParser
ocamlParser TokenCat
absName = [TokenCat] -> TokenCat
unlines
  [ [TokenCat] -> TokenCat
unwords [ TokenCat
"/* Parser definition for use with", OCamlParser -> TokenCat
forall a. OCamlParserName a => a -> TokenCat
ocamlParserName OCamlParser
ocamlParser, TokenCat
"*/" ]
  , TokenCat
""
  , TokenCat
"%{"
  , TokenCat
"open " TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
absName
  , TokenCat
"open Lexing"
  , TokenCat
"%}"
  ]

declarations :: String -> CF -> String
declarations :: TokenCat -> CF -> TokenCat
declarations TokenCat
absName CF
cf =
  [TokenCat] -> TokenCat
unlines ([TokenCat] -> TokenCat) -> [TokenCat] -> TokenCat
forall a b. (a -> b) -> a -> b
$ [TokenCat] -> [[TokenCat]] -> [TokenCat]
forall a. [a] -> [[a]] -> [a]
intercalate [TokenCat
""]
    [ [TokenCat] -> [TokenCat] -> [TokenCat]
tokens (CF -> [TokenCat]
unicodeAndSymbols CF
cf) (CF -> [TokenCat]
asciiKeywords CF
cf)
    , CF -> [TokenCat]
specialTokens CF
cf
    , TokenCat -> CF -> [TokenCat]
entryPoints TokenCat
absName CF
cf
    , ((Cat, [Rule]) -> TokenCat) -> [(Cat, [Rule])] -> [TokenCat]
forall a b. (a -> b) -> [a] -> [b]
map (Cat -> TokenCat
catTyping (Cat -> TokenCat)
-> ((Cat, [Rule]) -> Cat) -> (Cat, [Rule]) -> TokenCat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cat, [Rule]) -> Cat
forall a b. (a, b) -> a
fst)      ([(Cat, [Rule])] -> [TokenCat]) -> [(Cat, [Rule])] -> [TokenCat]
forall a b. (a -> b) -> a -> b
$ CF -> [(Cat, [Rule])]
ruleGroups CF
cf
    , (TokenCat -> TokenCat) -> [TokenCat] -> [TokenCat]
forall a b. (a -> b) -> [a] -> [b]
map (Cat -> TokenCat
catTyping (Cat -> TokenCat) -> (TokenCat -> Cat) -> TokenCat -> TokenCat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenCat -> Cat
TokenCat) ([TokenCat] -> [TokenCat]) -> [TokenCat] -> [TokenCat]
forall a b. (a -> b) -> a -> b
$ CF -> [TokenCat]
forall f. CFG f -> [TokenCat]
literals CF
cf
    ]
  where
    catTyping :: Cat -> TokenCat
catTyping Cat
c = TokenCat -> Cat -> TokenCat -> TokenCat
typing TokenCat
absName Cat
c (Cat -> TokenCat
nonterminal Cat
c)

-- | Declare keyword and symbol tokens.

tokens :: [String] -> [String] -> [String]
tokens :: [TokenCat] -> [TokenCat] -> [TokenCat]
tokens [TokenCat]
symbols [TokenCat]
reswords =
  [[TokenCat]] -> [TokenCat]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ [TokenCat] -> TokenCat
unwords ([TokenCat] -> TokenCat) -> [TokenCat] -> TokenCat
forall a b. (a -> b) -> a -> b
$ TokenCat
"%token" TokenCat -> [TokenCat] -> [TokenCat]
forall a. a -> [a] -> [a]
: (TokenCat -> TokenCat) -> [TokenCat] -> [TokenCat]
forall a b. (a -> b) -> [a] -> [b]
map (TokenCat
"KW_" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++) [TokenCat]
reswords | Bool
hasReserved ]
    , [ TokenCat
"" | Bool
hasReserved ]
    , (((TokenCat, Int) -> TokenCat) -> [(TokenCat, Int)] -> [TokenCat]
forall a b. (a -> b) -> [a] -> [b]
`map` [TokenCat] -> [Int] -> [(TokenCat, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TokenCat]
symbols [Int
1::Int ..]) (((TokenCat, Int) -> TokenCat) -> [TokenCat])
-> ((TokenCat, Int) -> TokenCat) -> [TokenCat]
forall a b. (a -> b) -> a -> b
$ \ (TokenCat
s, Int
n) ->
        TokenCat
"%token SYMB" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ Int -> TokenCat
forall a. Show a => a -> TokenCat
show Int
n TokenCat -> TokenCat -> TokenCat
+++ TokenCat
"/*" TokenCat -> TokenCat -> TokenCat
+++ TokenCat
s TokenCat -> TokenCat -> TokenCat
+++ TokenCat
"*/"
    ]
  where
  hasReserved :: Bool
hasReserved = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [TokenCat] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TokenCat]
reswords

-- | map a CF terminal into a ocamlyacc token
terminal :: CF -> String -> String
terminal :: CF -> TokenCat -> TokenCat
terminal CF
cf = \ TokenCat
s ->
    -- Use a lambda here to make sure that kws is computed before the
    -- second argument is applied.
    -- The GHC manual says that let-floating is not consistently applied
    -- so just writing @terminal cf s = ...@ could result in computing
    -- kws for every @s@ anew.
    if TokenCat
s TokenCat -> [TokenCat] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TokenCat]
kws then TokenCat
"KW_" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
s
    else case TokenCat -> [(TokenCat, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TokenCat
s ([TokenCat] -> [Int] -> [(TokenCat, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (CF -> [TokenCat]
unicodeAndSymbols CF
cf) [Int
1::Int ..]) of
      Just Int
i -> TokenCat
"SYMB" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ Int -> TokenCat
forall a. Show a => a -> TokenCat
show Int
i
      Maybe Int
Nothing -> TokenCat -> TokenCat
forall a. HasCallStack => TokenCat -> a
error (TokenCat -> TokenCat) -> TokenCat -> TokenCat
forall a b. (a -> b) -> a -> b
$ TokenCat
"CFtoOCamlYacc: terminal " TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat -> TokenCat
forall a. Show a => a -> TokenCat
show TokenCat
s TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
" not defined in CF."
  where
  kws :: [TokenCat]
kws = CF -> [TokenCat]
asciiKeywords CF
cf

-- | map a CF nonterminal into a ocamlyacc symbol
nonterminal :: Cat -> String
nonterminal :: Cat -> TokenCat
nonterminal Cat
c = (Char -> Char) -> TokenCat -> TokenCat
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
spaceToUnderscore (Cat -> TokenCat
fixType Cat
c)
    where spaceToUnderscore :: Char -> Char
spaceToUnderscore Char
' ' = Char
'_'
          spaceToUnderscore Char
x = Char
x

specialTokens :: CF -> [String]
specialTokens :: CF -> [TokenCat]
specialTokens CF
cf = [[TokenCat]] -> [TokenCat]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[TokenCat]] -> [TokenCat]) -> [[TokenCat]] -> [TokenCat]
forall a b. (a -> b) -> a -> b
$
  [ [ TokenCat
"%token TOK_EOF" ]
  , TokenCat -> [[TokenCat]] -> [TokenCat]
table TokenCat
" " [ TokenCat -> TokenCat -> [TokenCat]
prToken (TokenCat -> TokenCat
ty TokenCat
n)      TokenCat
n | TokenCat
n                 <- [TokenCat]
specialCatsP  ]
  , TokenCat -> [[TokenCat]] -> [TokenCat]
table TokenCat
" " [ TokenCat -> TokenCat -> [TokenCat]
prToken (Bool -> TokenCat
posTy Bool
pos) TokenCat
n | TokenReg RFun
n0 Bool
pos Reg
_ <- CF -> [Pragma]
forall function. CFG function -> [Pragma]
cfgPragmas CF
cf, let n :: TokenCat
n = RFun -> TokenCat
forall a. WithPosition a -> a
wpThing RFun
n0 ]
  ]
  where
  prToken :: TokenCat -> TokenCat -> [TokenCat]
prToken TokenCat
t TokenCat
n = [ TokenCat
"%token" TokenCat -> TokenCat -> TokenCat
+++ TokenCat
t, TokenCat
"TOK_" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
n ]
  ty :: TokenCat -> TokenCat
ty = \case
    TokenCat
"Ident"   -> TokenCat
"<string>"
    TokenCat
"String"  -> TokenCat
"<string>"
    TokenCat
"Integer" -> TokenCat
"<int>"
    TokenCat
"Double"  -> TokenCat
"<float>"
    TokenCat
"Char"    -> TokenCat
"<char>"
    TokenCat
_ -> TokenCat
forall a. HasCallStack => a
undefined
  posTy :: Bool -> TokenCat
posTy = \case
    Bool
True  -> TokenCat
"<(int * int) * string>"
    Bool
False -> TokenCat
"<string>"

entryPoints :: String -> CF -> [String]
entryPoints :: TokenCat -> CF -> [TokenCat]
entryPoints TokenCat
absName CF
cf =
  [[TokenCat]] -> [TokenCat]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ [TokenCat] -> TokenCat
unwords ([TokenCat] -> TokenCat) -> [TokenCat] -> TokenCat
forall a b. (a -> b) -> a -> b
$ TokenCat
"%start" TokenCat -> [TokenCat] -> [TokenCat]
forall a. a -> [a] -> [a]
: (Cat -> TokenCat) -> [Cat] -> [TokenCat]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> TokenCat
epName [Cat]
eps ]
    , (Cat -> TokenCat) -> [Cat] -> [TokenCat]
forall a b. (a -> b) -> [a] -> [b]
map (\ Cat
c -> TokenCat -> Cat -> TokenCat -> TokenCat
typing TokenCat
absName Cat
c (Cat -> TokenCat
epName Cat
c)) [Cat]
eps
    ]
  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

typing :: String -> Cat -> String -> String
typing :: TokenCat -> Cat -> TokenCat -> TokenCat
typing TokenCat
absName Cat
c TokenCat
s = TokenCat
"%type" TokenCat -> TokenCat -> TokenCat
+++ TokenCat
"<" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ Cat -> TokenCat
qualify (Cat -> Cat
normCat Cat
c) TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
">" TokenCat -> TokenCat -> TokenCat
+++ TokenCat
s
    where
          qualify :: Cat -> TokenCat
qualify Cat
c = if Cat
c Cat -> [Cat] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ TokenCat -> Cat
TokenCat TokenCat
"Integer", TokenCat -> Cat
TokenCat TokenCat
"Double", TokenCat -> Cat
TokenCat TokenCat
"Char",
                                    TokenCat -> Cat
TokenCat TokenCat
"String", Cat -> Cat
ListCat (TokenCat -> Cat
TokenCat TokenCat
"Integer"),
                                    Cat -> Cat
ListCat (TokenCat -> Cat
TokenCat TokenCat
"Double"),
                                    Cat -> Cat
ListCat (TokenCat -> Cat
TokenCat TokenCat
"Char"),
                                    Cat -> Cat
ListCat (TokenCat -> Cat
TokenCat TokenCat
"String") ]
                      then Cat -> TokenCat
fixType Cat
c
                      else TokenCat
absName TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"." TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ Cat -> TokenCat
fixType Cat
c

epName :: Cat -> String
epName :: Cat -> TokenCat
epName Cat
c = TokenCat
"p" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> TokenCat -> TokenCat
forall a. (a -> a) -> [a] -> [a]
mapHead Char -> Char
toUpper (Cat -> TokenCat
nonterminal Cat
c)

entryPointRules :: OCamlParser -> CF -> [String]
entryPointRules :: OCamlParser -> CF -> [TokenCat]
entryPointRules OCamlParser
ocamlParser CF
cf =
  (Cat -> TokenCat) -> [Cat] -> [TokenCat]
forall a b. (a -> b) -> [a] -> [b]
map ([TokenCat] -> TokenCat
unlines ([TokenCat] -> TokenCat) -> (Cat -> [TokenCat]) -> Cat -> TokenCat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> [TokenCat]
mkRule) ([Cat] -> [TokenCat]) -> [Cat] -> [TokenCat]
forall a b. (a -> b) -> a -> b
$ 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
  where
  mkRule :: Cat -> [String]
  mkRule :: Cat -> [TokenCat]
mkRule = case OCamlParser
ocamlParser of
    OCamlParser
Menhir    -> \ Cat
cat ->
      [ Cat -> TokenCat
epRule Cat
cat TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
";" ]
    OCamlParser
OCamlYacc -> \ Cat
cat ->
      [ Cat -> TokenCat
epRule Cat
cat
          -- Andreas, 2022-02-10, issue 414:
          -- We keep the 'error' token rule, throwing BNFC_Util.Parse_error,
          -- for API stability.
          -- It would be more uniform with the Menhir backend to just drop this rule
          -- and let the user catch the Parsing.Parse_error exception.
      , TokenCat
"  /* Delete this error clause to get a Parsing.Parse_error exception instead: */"
      , TokenCat
ocamlYaccErrorCase
      , TokenCat
"  ;"
      ]
  epRule :: Cat -> String
  epRule :: Cat -> TokenCat
epRule Cat
cat = Cat -> TokenCat
epName Cat
cat TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
" : " TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ Cat -> TokenCat
nonterminal Cat
cat TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
" TOK_EOF { $1 }"

ocamlYaccErrorCase :: String
ocamlYaccErrorCase :: TokenCat
ocamlYaccErrorCase = [TokenCat] -> TokenCat
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ TokenCat
"  | error { raise (BNFC_Util.Parse_error ("
  , TokenCat
"Parsing.symbol_start_pos ()"
  , TokenCat
", "
  , TokenCat
"Parsing.symbol_end_pos ()"
  , TokenCat
")) }"
  ]

rules :: OCamlParser -> CF -> String
rules :: OCamlParser -> CF -> TokenCat
rules OCamlParser
ocamlParser CF
cf = [TokenCat] -> TokenCat
unlines ([TokenCat] -> TokenCat) -> [TokenCat] -> TokenCat
forall a b. (a -> b) -> a -> b
$ [[TokenCat]] -> [TokenCat]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ OCamlParser -> CF -> [TokenCat]
entryPointRules OCamlParser
ocamlParser CF
cf
    , ((Cat, [Rule]) -> TokenCat) -> [(Cat, [Rule])] -> [TokenCat]
forall a b. (a -> b) -> [a] -> [b]
map ((Cat, [(TokenCat, TokenCat)]) -> TokenCat
prOne ((Cat, [(TokenCat, TokenCat)]) -> TokenCat)
-> ((Cat, [Rule]) -> (Cat, [(TokenCat, TokenCat)]))
-> (Cat, [Rule])
-> TokenCat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cat, [Rule]) -> (Cat, [(TokenCat, TokenCat)])
mkOne) ([(Cat, [Rule])] -> [TokenCat]) -> [(Cat, [Rule])] -> [TokenCat]
forall a b. (a -> b) -> a -> b
$ CF -> [(Cat, [Rule])]
ruleGroups CF
cf
    , CF -> [TokenCat]
specialRules CF
cf
    ]
  where
    mkOne :: (Cat, [Rule]) -> (Cat, [(TokenCat, TokenCat)])
mkOne (Cat
cat,[Rule]
rules) = (Cat
cat, (TokenCat -> TokenCat) -> [Rule] -> Cat -> [(TokenCat, TokenCat)]
constructRule (CF -> TokenCat -> TokenCat
terminal CF
cf) [Rule]
rules Cat
cat)
    prOne :: (Cat, [(TokenCat, TokenCat)]) -> TokenCat
prOne (Cat
_  , []  ) = [] -- nt has only internal use
    prOne (Cat
cat, (TokenCat, TokenCat)
l:[(TokenCat, TokenCat)]
ls) = [TokenCat] -> TokenCat
unlines ([TokenCat] -> TokenCat) -> [TokenCat] -> TokenCat
forall a b. (a -> b) -> a -> b
$ [[TokenCat]] -> [TokenCat]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [ [TokenCat] -> TokenCat
unwords [ TokenCat
nt, TokenCat
":", (TokenCat, TokenCat) -> TokenCat
rule (TokenCat, TokenCat)
l ] ]
        , ((TokenCat, TokenCat) -> TokenCat)
-> [(TokenCat, TokenCat)] -> [TokenCat]
forall a b. (a -> b) -> [a] -> [b]
map ((TokenCat
"  | " TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++) (TokenCat -> TokenCat)
-> ((TokenCat, TokenCat) -> TokenCat)
-> (TokenCat, TokenCat)
-> TokenCat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TokenCat, TokenCat) -> TokenCat
rule) [(TokenCat, TokenCat)]
ls
        , [ TokenCat
"  ;" ]
        ]
      where
        rule :: (TokenCat, TokenCat) -> TokenCat
rule (TokenCat
p,TokenCat
a) = [TokenCat] -> TokenCat
unwords [ TokenCat
p, TokenCat
"{", TokenCat
a , TokenCat
"}" ]
        nt :: TokenCat
nt = Cat -> TokenCat
nonterminal Cat
cat


-- 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 :: (String -> String) -> [Rule] -> NonTerminal -> [(Pattern,Action)]
constructRule :: (TokenCat -> TokenCat) -> [Rule] -> Cat -> [(TokenCat, TokenCat)]
constructRule TokenCat -> TokenCat
terminal [Rule]
rules Cat
nt =
  [ (TokenCat
p, Cat -> RFun -> [TokenCat] -> TokenCat
forall a. IsFun a => Cat -> a -> [TokenCat] -> TokenCat
generateAction Cat
nt (Rule -> RFun
forall function. Rul function -> function
funRule Rule
r) [TokenCat]
m)
  | Rule
r <- [Rule]
rules
  , let (TokenCat
p, [TokenCat]
m) = (TokenCat -> TokenCat) -> Rule -> (TokenCat, [TokenCat])
generatePatterns TokenCat -> TokenCat
terminal Rule
r
  ]



-- Generates a string containing the semantic action.
-- An action can for example be: Sum $1 $2, that is, construct an AST
-- with the constructor Sum applied to the two metavariables $1 and $2.
generateAction :: IsFun a => NonTerminal -> a -> [MetaVar] -> Action
generateAction :: forall a. IsFun a => Cat -> a -> [TokenCat] -> TokenCat
generateAction Cat
_ a
f [TokenCat]
ms = (if a -> Bool
forall a. IsFun a => a -> Bool
isCoercion a
f then TokenCat
"" else TokenCat
f') TokenCat -> TokenCat -> TokenCat
+++ [TokenCat] -> TokenCat
mkTuple [TokenCat]
ms
    where
    f' :: TokenCat
f' = case a -> TokenCat
forall a. IsFun a => a -> TokenCat
funName a
f of -- ocaml cons is somehow not a standard infix oper, right?
           TokenCat
"(:[])" -> TokenCat
"(fun x -> [x])"
           TokenCat
"(:)"   -> TokenCat
"(fun (x,xs) -> x::xs)"
           TokenCat
x       -> TokenCat -> TokenCat
sanitizeOcaml TokenCat
x


generatePatterns :: (String -> String) -> Rule -> (Pattern,[MetaVar])
generatePatterns :: (TokenCat -> TokenCat) -> Rule -> (TokenCat, [TokenCat])
generatePatterns TokenCat -> TokenCat
terminal Rule
r = case Rule -> SentForm
forall function. Rul function -> SentForm
rhsRule Rule
r of
  []  -> (TokenCat
"/* empty */",[])
  SentForm
its -> ([TokenCat] -> TokenCat
unwords ((Either Cat TokenCat -> TokenCat) -> SentForm -> [TokenCat]
forall a b. (a -> b) -> [a] -> [b]
map Either Cat TokenCat -> TokenCat
mkIt SentForm
its), SentForm -> [TokenCat]
forall {a} {b}. [Either a b] -> [TokenCat]
metas SentForm
its)
 where
   mkIt :: Either Cat TokenCat -> TokenCat
mkIt Either Cat TokenCat
i = case Either Cat TokenCat
i of
     Left Cat
c -> Cat -> TokenCat
nonterminal Cat
c
     Right TokenCat
s -> TokenCat -> TokenCat
terminal TokenCat
s
   metas :: [Either a b] -> [TokenCat]
metas [Either a b]
its = [ (Char
'$'Char -> TokenCat -> TokenCat
forall a. a -> [a] -> [a]
: Int -> TokenCat
forall a. Show a => a -> TokenCat
show Int
i) | (Int
i, Left a
_c) <- [Int] -> [Either a b] -> [(Int, Either a b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ::Int ..] [Either a b]
its ]

specialRules :: CF -> [String]
specialRules :: CF -> [TokenCat]
specialRules CF
cf = ((TokenCat -> TokenCat) -> [TokenCat] -> [TokenCat]
forall a b. (a -> b) -> [a] -> [b]
`map` CF -> [TokenCat]
forall f. CFG f -> [TokenCat]
literals CF
cf) ((TokenCat -> TokenCat) -> [TokenCat])
-> (TokenCat -> TokenCat) -> [TokenCat]
forall a b. (a -> b) -> a -> b
$ \case
  TokenCat
"Ident"   -> TokenCat
"ident : TOK_Ident  { Ident $1 };"
  TokenCat
"String"  -> TokenCat
"string : TOK_String { $1 };"
  TokenCat
"Integer" -> TokenCat
"int :  TOK_Integer  { $1 };"
  TokenCat
"Double"  -> TokenCat
"float : TOK_Double  { $1 };"
  TokenCat
"Char"    -> TokenCat
"char : TOK_Char { $1 };"
  TokenCat
own       -> [TokenCat] -> TokenCat
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([TokenCat] -> TokenCat) -> [TokenCat] -> TokenCat
forall a b. (a -> b) -> a -> b
$
    [ Cat -> TokenCat
fixType (TokenCat -> Cat
TokenCat TokenCat
own), TokenCat
" : TOK_", TokenCat
own, TokenCat
" { ", TokenCat
own, TokenCat
" (",  TokenCat
posn, TokenCat
"$1)};" ]
    where -- ignore position categories for now
    posn :: TokenCat
posn = TokenCat
"" -- if isPositionCat cf own then "mkPosToken " else ""