{-# LANGUAGE OverloadedStrings #-}

module BNFC.Backend.Haskell.Parser where

import BNFC.Prelude

import Control.Monad.State

import Prettyprinter

import           Data.List   (intersperse)
import qualified Data.Map    as Map
import           Data.String (fromString)

import System.FilePath (takeBaseName)

import BNFC.Backend.Common.StringUtils (escapeChars)
import BNFC.Backend.Common.Utils as Utils

import BNFC.Backend.CommonInterface.Backend

import BNFC.Backend.Haskell.Options
import BNFC.Backend.Haskell.State
import BNFC.Backend.Haskell.Utilities.Parser
import BNFC.Backend.Haskell.Utilities.Utils

import BNFC.CF
import BNFC.Options.GlobalOptions

haskellParser :: LBNF -> State HaskellBackendState Result
haskellParser :: LBNF -> State HaskellBackendState Result
haskellParser LBNF
lbnf = do
  HaskellBackendState
st <- StateT HaskellBackendState Identity HaskellBackendState
forall s (m :: * -> *). MonadState s m => m s
get
  let cfName :: String
cfName      = String -> String
takeBaseName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ GlobalOptions -> String
optInput (GlobalOptions -> String) -> GlobalOptions -> String
forall a b. (a -> b) -> a -> b
$ HaskellBackendState -> GlobalOptions
globalOpt HaskellBackendState
st
      toks :: [Token]
toks        = HaskellBackendState -> [Token]
lexerParserTokens HaskellBackendState
st
      rules :: [(Cat, Map RHS RuleLabel)]
rules       = HaskellBackendState -> [(Cat, Map RHS RuleLabel)]
parserRules HaskellBackendState
st
      inDirectory :: Bool
inDirectory = HaskellBackendOptions -> Bool
inDir (HaskellBackendOptions -> Bool) -> HaskellBackendOptions -> Bool
forall a b. (a -> b) -> a -> b
$ HaskellBackendState -> HaskellBackendOptions
haskellOpts HaskellBackendState
st
      nSpace :: Maybe String
nSpace      = HaskellBackendOptions -> Maybe String
nameSpace (HaskellBackendOptions -> Maybe String)
-> HaskellBackendOptions -> Maybe String
forall a b. (a -> b) -> a -> b
$ HaskellBackendState -> HaskellBackendOptions
haskellOpts HaskellBackendState
st
      funct :: Bool
funct       = HaskellBackendOptions -> Bool
functor (HaskellBackendOptions -> Bool) -> HaskellBackendOptions -> Bool
forall a b. (a -> b) -> a -> b
$ HaskellBackendState -> HaskellBackendOptions
haskellOpts HaskellBackendState
st
      tt :: TokenText
tt          = HaskellBackendOptions -> TokenText
tokenText (HaskellBackendOptions -> TokenText)
-> HaskellBackendOptions -> TokenText
forall a b. (a -> b) -> a -> b
$ HaskellBackendState -> HaskellBackendOptions
haskellOpts HaskellBackendState
st
      parserSpecification :: String
parserSpecification =
        LBNF
-> [(Cat, Map RHS RuleLabel)]
-> String
-> Bool
-> Maybe String
-> TokenText
-> [Token]
-> Bool
-> String
cf2parser LBNF
lbnf [(Cat, Map RHS RuleLabel)]
rules String
cfName Bool
inDirectory Maybe String
nSpace TokenText
tt [Token]
toks Bool
funct
  Result -> State HaskellBackendState Result
forall (m :: * -> *) a. Monad m => a -> m a
return [(Bool -> Maybe String -> String -> String -> String -> String
mkFilePath Bool
inDirectory Maybe String
nSpace String
cfName String
"Par" String
"y", String
parserSpecification)]

cf2parser :: LBNF
          -> [(Cat, Map RHS RuleLabel)]
          -> String
          -> Bool
          -> Maybe String
          -> TokenText
          -> [Token]
          -> Bool
          -> String
cf2parser :: LBNF
-> [(Cat, Map RHS RuleLabel)]
-> String
-> Bool
-> Maybe String
-> TokenText
-> [Token]
-> Bool
-> String
cf2parser LBNF
lbnf [(Cat, Map RHS RuleLabel)]
rules String
cfName Bool
inDir Maybe String
nameSpace TokenText
tokenText [Token]
tokens Bool
functor =
  LayoutOptions -> Doc () -> String
docToString LayoutOptions
defaultLayoutOptions (Doc () -> String) -> Doc () -> String
forall a b. (a -> b) -> a -> b
$ LBNF
-> [(Cat, Map RHS RuleLabel)]
-> String
-> Bool
-> Maybe String
-> TokenText
-> [Token]
-> Bool
-> Doc ()
cf2doc LBNF
lbnf [(Cat, Map RHS RuleLabel)]
rules String
cfName Bool
inDir Maybe String
nameSpace TokenText
tokenText [Token]
tokens Bool
functor

cf2doc :: LBNF
       -> [(Cat, Map RHS RuleLabel)]
       -> String
       -> Bool
       -> Maybe String
       -> TokenText
       -> [Token]
       -> Bool
       -> Doc ()
cf2doc :: LBNF
-> [(Cat, Map RHS RuleLabel)]
-> String
-> Bool
-> Maybe String
-> TokenText
-> [Token]
-> Bool
-> Doc ()
cf2doc LBNF
lbnf [(Cat, Map RHS RuleLabel)]
rules String
cfName Bool
inDir Maybe String
nameSpace TokenText
tokenText [Token]
tokens Bool
functor = ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ())
-> ([Doc ()] -> [Doc ()]) -> [Doc ()] -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
intersperse Doc ()
forall ann. Doc ann
emptyDoc)
  [ String -> String -> String -> TokenText -> [Cat] -> Doc ()
header String
parName String
absName String
lexName TokenText
tokenText [Cat]
parsers
  , Bool -> [Cat] -> Doc ()
declarations Bool
functor [Cat]
parsers
  -- TODO align tokens.
  , LBNF -> [Token] -> Bool -> Doc ()
tokensList LBNF
lbnf [Token]
tokens Bool
functor
  , Doc ()
delimiter
  , LBNF -> String -> TokenText -> Bool -> [Token] -> Doc ()
specialRules LBNF
lbnf String
absName TokenText
tokenText Bool
functor [Token]
tokens
  , String -> Bool -> [(Cat, Map RHS RuleLabel)] -> Doc ()
happyRules String
absName Bool
functor [(Cat, Map RHS RuleLabel)]
rules
  , String -> [String] -> TokenText -> Bool -> [Cat] -> Doc ()
footer String
absName [String]
usedBuiltins TokenText
tokenText Bool
functor [Cat]
parsers
  ]
  where
    parName :: ModuleName
    parName :: String
parName = Bool -> Maybe String -> String -> String -> String
mkModule Bool
inDir Maybe String
nameSpace String
cfName String
"Par"
    absName :: ModuleName
    absName :: String
absName = Bool -> Maybe String -> String -> String -> String
mkModule Bool
inDir Maybe String
nameSpace String
cfName String
"Abs"
    lexName :: ModuleName
    lexName :: String
lexName = Bool -> Maybe String -> String -> String -> String
mkModule Bool
inDir Maybe String
nameSpace String
cfName String
"Lex"
    parsers :: [Cat]
    parsers :: [Cat]
parsers = (Cat, Map RHS RuleLabel) -> Cat
forall a b. (a, b) -> a
fst ((Cat, Map RHS RuleLabel) -> Cat)
-> [(Cat, Map RHS RuleLabel)] -> [Cat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Cat, Map RHS RuleLabel)]
rules
    delimiter :: Doc ()
    delimiter :: Doc ()
delimiter = Doc ()
"%%"
    usedBuiltins :: [String]
    usedBuiltins :: [String]
usedBuiltins = NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty Char -> String)
-> (BuiltinCat -> NonEmpty Char) -> BuiltinCat -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinCat -> NonEmpty Char
printBuiltinCat (BuiltinCat -> String) -> [BuiltinCat] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map BuiltinCat (List1 Position) -> [BuiltinCat]
forall k a. Map k a -> [k]
Map.keys (LBNF -> Map BuiltinCat (List1 Position)
_lbnfParserBuiltins LBNF
lbnf)

header :: ModuleName -> ModuleName -> ModuleName -> TokenText -> [Cat] -> Doc ()
header :: String -> String -> String -> TokenText -> [Cat] -> Doc ()
header String
parName String
absName String
lexName TokenText
tokenText [Cat]
entryPoints = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"-- File generated by the BNF Converter."
  , Doc ()
"-- Parser definition for use with Happy."
  , Doc ()
forall ann. Doc ann
lbrace
  , Doc ()
"{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}"
  , Doc ()
"{-# LANGUAGE PatternSynonyms #-}"
  , Doc ()
forall ann. Doc ann
emptyDoc
  , Doc ()
"module" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
parName
  , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"( happyError"
  , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
", myLexer"
  , [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ (Cat -> Doc ()) -> [Cat] -> [Doc ()]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> (Cat -> Doc ()) -> Cat -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
(<>) Doc ()
", " (Doc () -> Doc ()) -> (Cat -> Doc ()) -> Cat -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> Doc ()
parserCatName) [Cat]
entryPoints
  , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
") where"
  , Doc ()
forall ann. Doc ann
emptyDoc
  , Doc ()
"import Prelude"
  , Doc ()
forall ann. Doc ann
emptyDoc
  , Doc ()
"import qualified" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
absName
  , Doc ()
"import" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
lexName
  , TokenText -> Doc ()
tokenTextImport TokenText
tokenText
  , Doc ()
forall ann. Doc ann
rbrace
  ]

-- | The declarations of a happy file.
-- >>> declarations 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 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 :: Bool -> [Cat] -> Doc ()
declarations :: Bool -> [Cat] -> Doc ()
declarations Bool
functor [Cat]
cats = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ (Cat -> Doc ()) -> [Cat] -> [Doc ()]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Cat -> Doc ()
generateP Bool
functor) [Cat]
cats
  , Doc ()
"%monad { Err } { (>>=) } { return }"
  , Doc ()
"%tokentype" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
braces Doc ()
tokenName
  ]

-- | Generate the list of tokens and their identifiers.
tokensList :: LBNF -> [Token] -> Bool -> Doc ()
tokensList :: LBNF -> [Token] -> Bool -> Doc ()
tokensList LBNF
lbnf [Token]
tokens 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.
  | Map (NonEmpty Char) Int -> Bool
forall k a. Map k a -> Bool
Map.null (LBNF -> Map (NonEmpty Char) Int
_lbnfSymbolsKeywords LBNF
lbnf) Bool -> Bool -> Bool
&& [Token] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Token]
tokens = Doc ()
forall ann. Doc ann
emptyDoc
  | Bool
otherwise = Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
    [ Doc ()
"%token"
    , [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ (NonEmpty Char, Int) -> Doc ()
printToken ((NonEmpty Char, Int) -> Doc ())
-> [(NonEmpty Char, Int)] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (NonEmpty Char) Int -> [(NonEmpty Char, Int)]
forall k a. Map k a -> [(k, a)]
Map.toList (LBNF -> Map (NonEmpty Char) Int
_lbnfSymbolsKeywords LBNF
lbnf)
    , [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep (Token -> Doc ()
printSpecialTokens (Token -> Doc ()) -> [Token] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Token]
tokens)
    ]
  where

    -- Print tokens coming from symbols and keywords.
    printToken :: (String1, Int) -> Doc ()
    printToken :: (NonEmpty Char, Int) -> Doc ()
printToken (NonEmpty Char
token, Int
n) =
      Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
squotes (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ String -> String
escapeChars (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Char
token) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
      Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
braces (Doc ()
forall ann. Doc ann
space Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"PT _" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (Doc ()
"TS _" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString (Int -> String
forall a. Show a => a -> String
show Int
n)) Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
space)

    -- Print tokens coming from builtin categories and user defined tokens.
    printSpecialTokens :: Token -> Doc ()
    printSpecialTokens :: Token -> Doc ()
printSpecialTokens (Builtin BuiltinCat
b) = case BuiltinCat
b of
      BuiltinCat
BChar    -> Doc ()
"L_charac" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
braces (Doc ()
" PT _ (TC" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> if Bool
functor then Doc ()
"_)" else Doc ()
"$$" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
") ")
      BuiltinCat
BDouble  -> Doc ()
"L_doubl"  Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
braces (Doc ()
" PT _ (TD" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> if Bool
functor then Doc ()
"_)" else Doc ()
"$$" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
") ")
      BuiltinCat
BInteger -> Doc ()
"L_integ"  Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
braces (Doc ()
" PT _ (TI" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> if Bool
functor then Doc ()
"_)" else Doc ()
"$$" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
") ")
      BuiltinCat
BString  -> Doc ()
"L_quoted" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
braces (Doc ()
" PT _ (TL" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> if Bool
functor then Doc ()
"_)" else Doc ()
"$$" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
") ")
    printSpecialTokens Token
Identifier =
      Doc ()
"L_Ident" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
braces (Doc ()
" PT _ (TV" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> if Bool
functor then Doc ()
"_)" else Doc ()
"$$" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
") ")
    printSpecialTokens (UserDefined NonEmpty Char
s) =
      Doc ()
"L_" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
tName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
braces (Doc ()
" PT _ (T_" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
tName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> NonEmpty Char -> Doc ()
posn NonEmpty Char
s Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
") ")
      where
        tName :: Doc ()
        tName :: Doc ()
tName = String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Char
s
        posn :: CatName -> Doc ()
        posn :: NonEmpty Char -> Doc ()
posn NonEmpty Char
tk = case NonEmpty Char
-> Map (NonEmpty Char) (WithPosition TokenDef)
-> Maybe (WithPosition TokenDef)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NonEmpty Char
tk (LBNF -> Map (NonEmpty Char) (WithPosition TokenDef)
_lbnfTokenDefs LBNF
lbnf) of
          Maybe (WithPosition TokenDef)
Nothing   -> String -> Doc ()
forall a. HasCallStack => String -> a
panic (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ String
"Token " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Char
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not found in _lbnfTokenDefs"
          Just WithPosition TokenDef
pDef ->
            if WithPosition TokenDef -> Bool
isPositionToken WithPosition TokenDef
pDef Bool -> Bool -> Bool
|| Bool
functor
            then Doc ()
"_"
            else Doc ()
"$$"

specialRules :: LBNF -> ModuleName -> TokenText -> Bool -> [Token] -> Doc ()
specialRules :: LBNF -> String -> TokenText -> Bool -> [Token] -> Doc ()
specialRules LBNF
lbnf String
absName TokenText
tokenText Bool
functor [Token]
tks = ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ())
-> ([Doc ()] -> [Doc ()]) -> [Doc ()] -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
intersperse Doc ()
forall ann. Doc ann
emptyDoc) ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$
  LBNF -> String -> TokenText -> Bool -> Token -> Doc ()
specialRule LBNF
lbnf String
absName TokenText
tokenText Bool
functor (Token -> Doc ()) -> [Token] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Token]
tks

-- Happy rules for builtin categories, indentifier and user defined tokens.
specialRule :: LBNF -> ModuleName -> TokenText -> Bool -> Token -> Doc ()
specialRule :: LBNF -> String -> TokenText -> Bool -> Token -> Doc ()
specialRule LBNF
lbnf String
absName TokenText
tokenText Bool
functor Token
t = case Token
t of
  Builtin BuiltinCat
b -> case BuiltinCat
b of
    BuiltinCat
BChar -> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"Char :: {" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
mkType String
tokenCat Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"}"
      , Doc ()
"Char  : L_charac {" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
mkBody Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"}"
      ]
    BuiltinCat
BDouble -> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"Double :: {" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
mkType String
tokenCat Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"}"
      , Doc ()
"Double  : L_doubl  {" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
mkBody Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"}"]
    BuiltinCat
BInteger -> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"Integer :: {" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
mkType String
tokenCat Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"}"
      , Doc ()
"Integer  : L_integ  {" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
mkBody Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"}"
      ]
    BuiltinCat
BString -> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"String :: {" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
mkType String
tokenCat Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"}"
      , Doc ()
"String  : L_quoted {" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
mkBody Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"}"
      ]
  Token
Identifier -> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"Ident :: {" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
mkType (String -> String -> String
qualify String
absName String
tokenCat) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"}"
      , Doc ()
"Ident  : L_Ident {" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
mkBody Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"}"
      ]
  UserDefined NonEmpty Char
s -> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ String -> Doc ()
forall a. IsString a => String -> a
fromString (NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Char
s) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
":: {" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
mkType (String -> String -> String
qualify String
absName String
tokenCat) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"}"
      , String -> Doc ()
forall a. IsString a => String -> a
fromString (NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Char
s) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
":" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString (NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty Char
"L_" NonEmpty Char -> NonEmpty Char -> NonEmpty Char
forall a. Semigroup a => a -> a -> a
<> NonEmpty Char
s)) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"{" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
mkBody Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"}"
      ]
  where
    tokenCat :: String
tokenCat = Token -> String
printTokenName Token
t

    mkType :: String -> Doc ()
    mkType :: String -> Doc ()
mkType String
token =
      if Bool
functor
      then Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> String -> String
qualify String
absName String
posType) Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
comma Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
token)
      else String -> Doc ()
forall a. IsString a => String -> a
fromString String
token

    mkBody :: Doc ()
    mkBody :: Doc ()
mkBody
      | Bool
functor   =
          Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (Doc ()
"uncurry" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> String -> String
qualify String
absName String
posConstr) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"(tokenLineCol $1)"
          Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
comma Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Token -> Doc ()
mkVal Token
t)
      | Bool
otherwise = Token -> Doc ()
mkVal Token
t

    mkVal :: Token -> Doc ()
    mkVal :: Token -> Doc ()
mkVal Token
tk = case Token
tk of
      Builtin BuiltinCat
b -> case BuiltinCat
b of
        BuiltinCat
BChar ->
          if Bool
functor
          then Doc ()
"(read" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
stringUnpack String
"(tokenText $1)" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
") :: Char"
          -- Char never has pos.
          else Doc ()
"(read" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
stringUnpack String
"$1" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
") :: Char"
        BuiltinCat
BDouble ->
          if Bool
functor
          then Doc ()
"(read" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
stringUnpack String
"(tokenText $1)" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
") :: Double"
          -- Double never has pos.
          else Doc ()
"(read" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
stringUnpack String
"$1" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
") :: Double"
        BuiltinCat
BInteger ->
          if Bool
functor
          then Doc ()
"(read" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
stringUnpack String
"(tokenText $1)" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
") :: Integer"
          -- Integer never has pos.
          else Doc ()
"(read" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
stringUnpack String
"$1" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
") :: Integer"
        BuiltinCat
BString ->
          if Bool
functor
          then String -> Doc ()
stringUnpack String
"((\\(PT _ (TL s)) -> s) $1)"
          -- String never has pos.
          else String -> Doc ()
stringUnpack String
"$1"
      Token
Identifier ->
        if Bool
functor
        then String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> String -> String
qualify String
absName String
"Ident") Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"(tokenText $1)"
        else String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> String -> String
qualify String
absName String
"Ident") Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"$1"
      UserDefined NonEmpty Char
s ->
        if Bool
functor
        then
          case NonEmpty Char
-> Map (NonEmpty Char) (WithPosition TokenDef)
-> Maybe (WithPosition TokenDef)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NonEmpty Char
s (LBNF -> Map (NonEmpty Char) (WithPosition TokenDef)
_lbnfTokenDefs LBNF
lbnf) of
            Maybe (WithPosition TokenDef)
Nothing   -> String -> Doc ()
forall a. HasCallStack => String -> a
panic (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ String
"Token " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Char
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not found in _lbnfTokenDefs"
            Just WithPosition TokenDef
pDef ->
              if WithPosition TokenDef -> Bool
isPositionToken WithPosition TokenDef
pDef
              then String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> String -> String
qualify String
absName (NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Char
s)) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"(mkPosToken $1)"
              else String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> String -> String
qualify String
absName (NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Char
s)) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"(tokenText $1)"
        else
          case NonEmpty Char
-> Map (NonEmpty Char) (WithPosition TokenDef)
-> Maybe (WithPosition TokenDef)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NonEmpty Char
s (LBNF -> Map (NonEmpty Char) (WithPosition TokenDef)
_lbnfTokenDefs LBNF
lbnf) of
            Maybe (WithPosition TokenDef)
Nothing   -> String -> Doc ()
forall a. HasCallStack => String -> a
panic (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ String
"Token " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Char
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not found in _lbnfTokenDefs"
            Just WithPosition TokenDef
pDef ->
              if WithPosition TokenDef -> Bool
isPositionToken WithPosition TokenDef
pDef
              then String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> String -> String
qualify String
absName (NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Char
s)) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"(mkPosToken $1)"
              else String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> String -> String
qualify String
absName (NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Char
s)) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"$1"

    stringUnpack :: String -> Doc ()
    stringUnpack :: String -> Doc ()
stringUnpack = TokenText -> String -> Doc ()
tokenTextUnpack TokenText
tokenText

-- Happy rules.
happyRules :: ModuleName
           -> Bool
           -> [(Cat, Map RHS RuleLabel)]
           -> Doc ()
happyRules :: String -> Bool -> [(Cat, Map RHS RuleLabel)] -> Doc ()
happyRules String
absName Bool
functor =
  [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ())
-> ([(Cat, Map RHS RuleLabel)] -> [Doc ()])
-> [(Cat, Map RHS RuleLabel)]
-> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
intersperse Doc ()
forall ann. Doc ann
emptyDoc ([Doc ()] -> [Doc ()])
-> ([(Cat, Map RHS RuleLabel)] -> [Doc ()])
-> [(Cat, Map RHS RuleLabel)]
-> [Doc ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  ((Cat, Map RHS RuleLabel) -> Doc ())
-> [(Cat, Map RHS RuleLabel)] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Cat -> Map RHS RuleLabel -> Doc ())
-> (Cat, Map RHS RuleLabel) -> Doc ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (String -> Bool -> Cat -> Map RHS RuleLabel -> Doc ()
printRule String
absName Bool
functor))

printRule :: ModuleName
          -> Bool
          -> Cat
          -> Map RHS RuleLabel
          -> Doc ()
printRule :: String -> Bool -> Cat -> Map RHS RuleLabel -> Doc ()
printRule String
absName Bool
functor Cat
category Map RHS RuleLabel
rhs = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
catName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"::" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
ruleType
  , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep [ Doc ()
catName, [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ (Doc () -> Doc () -> Doc ()) -> [Doc ()] -> [Doc ()] -> [Doc ()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
(<+>) (Doc ()
":" Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
: Doc () -> [Doc ()]
forall a. a -> [a]
repeat Doc ()
"|") [Doc ()]
ruleCases]
  ]
  where

    catName :: Doc ()
    catName :: Doc ()
catName = String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ Cat -> String
printCatNamePrec' Cat
category

    ruleType :: Doc ()
    ruleType :: Doc ()
ruleType =
      if Bool
functor
      then Doc ()
forall ann. Doc ann
lbrace Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> String -> String
qualify String
absName String
posType) Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
comma Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
        Doc ()
qualifiedCat) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
forall ann. Doc ann
rbrace
      else Doc ()
forall ann. Doc ann
lbrace Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
qualifiedCat Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
forall ann. Doc ann
rbrace
      where
        qualifiedCat :: Doc ()
        qualifiedCat :: Doc ()
qualifiedCat =
          if Cat -> Bool
isCatList Cat
category
          then
            if Cat -> Bool
isCatBuiltin Cat
category
            then Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
brackets (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ Cat -> String
printCatName Cat
category
            else Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
brackets (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
qualify String
absName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Cat -> String
printCatName Cat
category
          else String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
qualify String
absName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Cat -> String
printCatName Cat
category

    ruleCases :: [Doc ()]
    ruleCases :: [Doc ()]
ruleCases = Bool -> String -> (RHS, RuleLabel) -> Doc ()
constructRule Bool
functor String
absName ((RHS, RuleLabel) -> Doc ()) -> [(RHS, RuleLabel)] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map RHS RuleLabel -> [(RHS, RuleLabel)]
forall k a. Map k a -> [(k, a)]
Map.toList Map RHS RuleLabel
rhs


constructRule :: Bool -> ModuleName -> (RHS, RuleLabel) -> Doc ()
constructRule :: Bool -> String -> (RHS, RuleLabel) -> Doc ()
constructRule Bool
functor String
absName (RHS
rhs, RuleLabel
label) =
  Doc ()
pat' Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
forall ann. Doc ann
lbrace Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
action  Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
forall ann. Doc ann
rbrace
  where
    rName :: String
rName           = Label -> String
printRuleName Label
rLabel
    rLabel :: Label
rLabel          = RuleLabel -> Label
ruleLabel RuleLabel
label
    (String
pat, [String]
metavars) = Bool -> RHS -> (String, [String])
generatePatterns Bool
functor RHS
rhs
    pat' :: Doc ()
pat'            = String -> Doc ()
forall a. IsString a => String -> a
fromString String
pat
    metavars' :: Doc ()
metavars'       = String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String]
metavars

    action :: Doc ()
    action :: Doc ()
action
      | Bool
functor   = Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc ()
actionPos Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
comma Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
actionValue
      | Bool
otherwise = Doc ()
actionValue

    actionPos :: Doc ()
    actionPos :: Doc ()
actionPos = case RHS
rhs of
      []                -> String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ String
absName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
noPosConstr
      (NTerminal Cat
_) : RHS
_ -> Doc ()
"fst $1"
      (Terminal Keyword
_) : RHS
_  -> Doc ()
"uncurry" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
qualified String
posConstr Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"(tokenLineCol $1)"

    actionValue :: Doc ()
    actionValue :: Doc ()
actionValue
      | Label -> Bool
isCoercion Label
rLabel = Doc ()
metavars'
      | Label -> Bool
isList Label
rLabel     =
        if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
metavars then String -> Doc ()
qualified String
rName else String -> Doc ()
qualified String
rName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
metavars'
      | Bool
functor           =
        if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
metavars
        then String -> Doc ()
qualified String
rName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens Doc ()
actionPos
        else String -> Doc ()
qualified String
rName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens Doc ()
actionPos Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
metavars'
      | Bool
otherwise         =
        if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
metavars then String -> Doc ()
qualified String
rName else String -> Doc ()
qualified String
rName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
metavars'

    qualified :: String -> Doc ()
    qualified :: String -> Doc ()
qualified String
s
      | Label -> Bool
isList Label
rLabel = String -> Doc ()
forall a. IsString a => String -> a
fromString String
s
      | Bool
otherwise     = String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ String
absName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s


footer :: ModuleName -> [String] -> TokenText -> Bool -> [Cat] -> Doc ()
footer :: String -> [String] -> TokenText -> Bool -> [Cat] -> Doc ()
footer String
absName [String]
usedBuiltins TokenText
tokenText Bool
functor [Cat]
entryPoints = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
forall ann. Doc ann
lbrace
  , Doc ()
forall ann. Doc ann
emptyDoc
  , Doc ()
"type Err = Either String"
  , Doc ()
forall ann. Doc ann
emptyDoc
  , Doc ()
"happyError :: [" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
tokenName Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"] -> Err a"
  , Doc ()
"happyError ts = Left $"
  , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"\"syntax error at \" ++ tokenPos ts ++ "
  , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"case ts of"
  , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 Doc ()
"[]      -> []"
  , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 Doc ()
"[Err _] -> \" due to lexer error\""
  , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 Doc ()
"t:_     -> \" before `\"" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"++" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"(prToken t)" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"++" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"\"'\""
  , Doc ()
forall ann. Doc ann
emptyDoc
  , Doc ()
"myLexer ::" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TokenText -> Doc ()
tokenTextType TokenText
tokenText Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"-> [" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
tokenName Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"]"
  , Doc ()
"myLexer = tokens"
  , [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$
    Doc ()
forall ann. Doc ann
emptyDoc
    Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
:
    Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when Bool
functor
      [ Doc ()
"-- Entrypoints"
      , Doc ()
forall ann. Doc ann
emptyDoc
      , ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ())
-> ([Doc ()] -> [Doc ()]) -> [Doc ()] -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
intersperse Doc ()
forall ann. Doc ann
emptyDoc) ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ Cat -> Doc ()
mkParseFun (Cat -> Doc ()) -> [Cat] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Cat]
entryPoints
      ]
  , Doc ()
forall ann. Doc ann
rbrace
  ]
  where
    mkParseFun :: Cat -> Doc ()
    mkParseFun :: Cat -> Doc ()
mkParseFun Cat
c = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Cat -> Doc ()
parserCatName Cat
c Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"::" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
brackets Doc ()
tokenName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"-> Err" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
c'
      , Cat -> Doc ()
parserCatName Cat
c Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"=" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"fmap snd" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"." Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Cat -> Doc ()
parserCatName Cat
c Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"_internal"
      ]
      where
        c' :: Doc ()
        c' :: Doc ()
c' =
          if Cat -> Bool
isCatList Cat
c
          then
            if String
catName String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
usedBuiltins
            then Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
brackets (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ String -> Doc ()
forall a. IsString a => String -> a
fromString String
catName
            else Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
brackets (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> String -> String
qualify String
absName String
catName)
          else String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> String -> String
qualify String
absName (Type -> String
printTypeName (Cat -> Type
catToType Cat
c)))
        catName :: String
        catName :: String
catName = Type -> String
printTypeName (Cat -> Type
catToType Cat
c)