{-# LANGUAGE OverloadedStrings #-}

module BNFC.Backend.Haskell.Lexer where

import BNFC.Prelude

import Control.Monad.State

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

import Prettyprinter
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.Layout
import BNFC.Backend.Haskell.Options
import BNFC.Backend.Haskell.State

import BNFC.Backend.Haskell.Utilities.Lexer
import BNFC.Backend.Haskell.Utilities.Utils

import BNFC.CF
import BNFC.Lexing
import BNFC.Options.GlobalOptions

import BNFC.Types.Position
import BNFC.Types.Regex

import qualified BNFC.Utils.List2 as List2


haskellLexer :: LBNF -> State HaskellBackendState Result
haskellLexer :: LBNF -> State HaskellBackendState Result
haskellLexer LBNF
lbnf = do
  HaskellBackendState
st <- StateT HaskellBackendState Identity HaskellBackendState
forall s (m :: * -> *). MonadState s m => m s
get
  Result
layout <- LBNF -> State HaskellBackendState Result
haskellLayout LBNF
lbnf
  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
      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
      tt :: TokenText
tt          = HaskellBackendOptions -> TokenText
tokenText (HaskellBackendOptions -> TokenText)
-> HaskellBackendOptions -> TokenText
forall a b. (a -> b) -> a -> b
$ HaskellBackendState -> HaskellBackendOptions
haskellOpts HaskellBackendState
st
      toks :: [Token]
toks        = HaskellBackendState -> [Token]
lexerParserTokens HaskellBackendState
st
      lexerSpecification :: String
lexerSpecification = LBNF
-> String -> Bool -> Maybe String -> TokenText -> [Token] -> String
cf2lexer LBNF
lbnf String
cfName Bool
inDirectory Maybe String
nSpace TokenText
tt [Token]
toks
  Result -> State HaskellBackendState Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> State HaskellBackendState Result)
-> Result -> State HaskellBackendState Result
forall a b. (a -> b) -> a -> b
$
    if LBNF -> Bool
layoutsAreUsed LBNF
lbnf
    then (Bool -> Maybe String -> String -> String -> String -> String
mkFilePath Bool
inDirectory Maybe String
nSpace String
cfName String
"Lex" String
"x", String
lexerSpecification) (String, String) -> Result -> Result
forall a. a -> [a] -> [a]
: Result
layout
    else [(Bool -> Maybe String -> String -> String -> String -> String
mkFilePath Bool
inDirectory Maybe String
nSpace String
cfName String
"Lex" String
"x", String
lexerSpecification)]

cf2lexer :: LBNF -> String -> Bool -> Maybe String -> TokenText -> [Token] -> String
cf2lexer :: LBNF
-> String -> Bool -> Maybe String -> TokenText -> [Token] -> String
cf2lexer LBNF
lbnf String
name Bool
inDir Maybe String
nameSpace TokenText
tokenText [Token]
toks =
  LayoutOptions -> Doc () -> String
docToString LayoutOptions
defaultLayoutOptions (Doc () -> String) -> Doc () -> String
forall a b. (a -> b) -> a -> b
$ LBNF
-> String -> Bool -> Maybe String -> TokenText -> [Token] -> Doc ()
cf2doc LBNF
lbnf String
name Bool
inDir Maybe String
nameSpace TokenText
tokenText [Token]
toks

cf2doc :: LBNF -> String -> Bool -> Maybe String -> TokenText -> [Token] -> Doc ()
cf2doc :: LBNF
-> String -> Bool -> Maybe String -> TokenText -> [Token] -> Doc ()
cf2doc LBNF
lbnf String
cfName Bool
inDir Maybe String
nameSpace TokenText
tokenText [Token]
toks = ([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 -> Bool -> Maybe String -> TokenText -> Doc ()
prelude String
cfName Bool
inDir Maybe String
nameSpace TokenText
tokenText
  , Doc ()
cMacros
  , LBNF -> Doc ()
rMacros LBNF
lbnf
  , TokenText -> [Token] -> LBNF -> Doc ()
restOfAlex TokenText
tokenText [Token]
toks LBNF
lbnf
  ]

prelude :: String -> Bool -> Maybe String -> TokenText -> Doc ()
prelude :: String -> Bool -> Maybe String -> TokenText -> Doc ()
prelude String
cfName Bool
inDir Maybe String
nameSpace TokenText
tokenText = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$
  [ Doc ()
"-- File generated by the BNF Converter."
  , Doc ()
forall ann. Doc ann
emptyDoc
  , Doc ()
"-- -*- haskell -*-"
  , Doc ()
"-- Lexer definition for use with Alex 3."
  , Doc ()
forall ann. Doc ann
lbrace
  , Doc ()
"{-# OPTIONS -fno-warn-incomplete-patterns #-}"
  , Doc ()
"{-# OPTIONS_GHC -w #-}"
  , Doc ()
forall ann. Doc ann
emptyDoc
  , 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 (Bool -> Maybe String -> String -> String -> String
mkModule Bool
inDir Maybe String
nameSpace String
cfName String
"Lex")  Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"where"
  , Doc ()
forall ann. Doc ann
emptyDoc
  , Doc ()
"import Prelude"
  , 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 (TokenText
tokenText TokenText -> TokenText -> Bool
forall a. Eq a => a -> a -> Bool
/= TokenText
StringToken) [ TokenText -> Doc ()
tokenTextImport TokenText
tokenText, Doc ()
forall ann. Doc ann
emptyDoc ]
  [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++
  [ Doc ()
"import qualified Data.Bits"
  , Doc ()
"import           Data.Char     (ord)"
  , Doc ()
"import           Data.Function (on)"
  , Doc ()
"import           Data.Maybe    (fromMaybe)"
  , Doc ()
"import qualified Data.Map      as Map"
  , Doc ()
"import           Data.Map      (Map)"
  , Doc ()
"import           Data.Word     (Word8)"
  , Doc ()
forall ann. Doc ann
rbrace
  ]

-- | Character class definitions.

cMacros :: Doc ()
cMacros :: Doc ()
cMacros = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"-- Predefined character classes"
  , Doc ()
forall ann. Doc ann
emptyDoc
  , Doc ()
"$c = [A-Z\\192-\\221] # [\\215]  -- capital isolatin1 letter (215 = \\times)"
  , Doc ()
"$s = [a-z\\222-\\255] # [\\247]  -- small   isolatin1 letter (247 = \\div  )"
  , Doc ()
"$l = [$c $s]         -- letter"
  , Doc ()
"$d = [0-9]           -- digit"
  , Doc ()
"$i = [$l $d _ ']     -- identifier character"
  , Doc ()
"$u = [. \\n]          -- universal: any character"
  ]

-- | Regular expressions and lex actions.

rMacros :: LBNF -> Doc ()
rMacros :: LBNF -> Doc ()
rMacros LBNF
lbnf = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.unless (Map Symbol (List1 Position) -> Bool
forall k a. Map k a -> Bool
Map.null (LBNF -> Map Symbol (List1 Position)
_lbnfSymbols LBNF
lbnf))
  [ Doc ()
"-- Symbols and non-identifier-like reserved words"
  , Doc ()
forall ann. Doc ann
emptyDoc
  , Doc ()
"@rsyms =" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ([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
pipe) (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> (String -> String) -> String -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
esc (String -> Doc ()) -> [String] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
symbs)
  ]
  where
    symbs :: [String]
    symbs :: [String]
symbs = LBNF -> [String]
unicodeAndSymbols LBNF
lbnf
    esc :: String -> [String]
    esc :: String -> [String]
esc String
s = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
a then [String]
rest else String -> String
forall a. Show a => a -> String
show String
a String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
rest
      where
      (String
a, String
r) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\ Char
c -> Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& Char -> Bool
isAlphaNum Char
c) String
s
      rest :: [String]
rest = case String
r of
        []     -> []
        Char
c : String
xs -> (if Char -> Bool
isPrint Char
c then [Char
'\\',Char
c] else Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show (Char -> Int
ord Char
c)) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
esc String
xs

-- rest af Alex.

restOfAlex :: TokenText -> [Token] -> LBNF -> Doc ()
restOfAlex :: TokenText -> [Token] -> LBNF -> Doc ()
restOfAlex TokenText
tokenText [Token]
toks LBNF
lbnf = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
    [ Doc ()
":-"
    ,  [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ [[Doc ()]] -> [Doc ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ Doc ()
forall ann. Doc ann
emptyDoc ]
      -- Line comments.
      , Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (Bool -> Bool
not (Map Position LineComment -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (LBNF -> Map Position LineComment
_lbnfLineComments LBNF
lbnf)))
        [ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ LineComment -> Doc ()
lineComment (LineComment -> Doc ())
-> ((Position, LineComment) -> LineComment)
-> (Position, LineComment)
-> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, LineComment) -> LineComment
forall a b. (a, b) -> b
snd
          ((Position, LineComment) -> Doc ())
-> [(Position, LineComment)] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          Map Position LineComment -> [(Position, LineComment)]
forall k a. Map k a -> [(k, a)]
Map.toList (LBNF -> Map Position LineComment
_lbnfLineComments LBNF
lbnf)
        , Doc ()
forall ann. Doc ann
emptyDoc
        ]
      -- Block comments.
      , Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (Bool -> Bool
not (Map Position BlockComment -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (LBNF -> Map Position BlockComment
_lbnfBlockComments LBNF
lbnf)))
        [ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ BlockComment -> Doc ()
blockComment (BlockComment -> Doc ())
-> ((Position, BlockComment) -> BlockComment)
-> (Position, BlockComment)
-> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, BlockComment) -> BlockComment
forall a b. (a, b) -> b
snd
          ((Position, BlockComment) -> Doc ())
-> [(Position, BlockComment)] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          Map Position BlockComment -> [(Position, BlockComment)]
forall k a. Map k a -> [(k, a)]
Map.toList (LBNF -> Map Position BlockComment
_lbnfBlockComments LBNF
lbnf)
        , Doc ()
forall ann. Doc ann
emptyDoc
        ]
      ]
    , Doc ()
"-- Whitespace (skipped)"
    , Doc ()
"$white+ ;"
    , [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ [[Doc ()]] -> [Doc ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ Doc ()
forall ann. Doc ann
emptyDoc ]
      , Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (LBNF -> [String]
unicodeAndSymbols LBNF
lbnf))
        [ Doc ()
"-- Symbols"
        , Doc ()
"@rsyms"
        , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 Doc ()
"{ tok (eitherResIdent TV) }"
        , Doc ()
forall ann. Doc ann
emptyDoc
        ]
      , Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (Bool -> Bool
not (Map CatName (WithPosition TokenDef) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map CatName (WithPosition TokenDef)
lbnfTokens))
        [ Doc ()
userDefTokenTypes
        , Doc ()
forall ann. Doc ann
emptyDoc
        ]
      , [ Doc ()
"-- Keywords and Ident"
        , Doc ()
"$l $i*"
        , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 Doc ()
"{ tok (eitherResIdent TV) }"
        , Doc ()
forall ann. Doc ann
emptyDoc
        ]
      , Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (BuiltinCat
BString BuiltinCat -> [BuiltinCat] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BuiltinCat]
usedBuiltins)
        [ Doc ()
"-- String"
        , Doc ()
"\\\" ([$u # [\\\" \\\\ \\n]] | (\\\\ (\\\" | \\\\ | \\' | n | t | r | f)))* \\\""
        , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 Doc ()
"{ tok (TL . unescapeInitTail) }"
        , Doc ()
forall ann. Doc ann
emptyDoc
        ]
      , Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (BuiltinCat
BChar BuiltinCat -> [BuiltinCat] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BuiltinCat]
usedBuiltins)
        [ Doc ()
"-- Char"
        , Doc ()
"\\\' ($u # [\\\' \\\\] | \\\\ [\\\\ \\\' n t r f]) \\'"
        , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 Doc ()
"{ tok TC }"
        , Doc ()
forall ann. Doc ann
emptyDoc
        ]
      , Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (BuiltinCat
BInteger BuiltinCat -> [BuiltinCat] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BuiltinCat]
usedBuiltins)
        [ Doc ()
"-- Integer"
        , Doc ()
"$d+"
        , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 Doc ()
"{ tok TI }"
        , Doc ()
forall ann. Doc ann
emptyDoc
        ]
      , Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (BuiltinCat
BDouble  BuiltinCat -> [BuiltinCat] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BuiltinCat]
usedBuiltins)
        [ Doc ()
"-- Double"
        , Doc ()
"$d+ \\. $d+ (e (\\-)? $d+)?"
        , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 Doc ()
"{ tok TD }"
        , Doc ()
forall ann. Doc ann
emptyDoc
        ]
      ]
    , Doc ()
forall ann. Doc ann
lbrace
    , Doc ()
"-- | Create a token with position."
    , Doc ()
"tok :: (" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
stringType Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
" -> Tok) -> (Posn -> " Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
stringType Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
" -> Token)"
    , Doc ()
"tok f p = PT p . f"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"-- | Token without position."
    , TokenText -> [Token] -> Doc ()
tokDataTypes TokenText
tokenText [Token]
toks
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"-- | Smart constructor for 'Tok' for the sake of backwards compatibility."
    , Doc ()
"pattern TS :: " Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
stringType Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
" -> Int -> Tok"
    , Doc ()
"pattern TS t i = TK (TokSymbol t i)"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"-- | Keyword or symbol tokens have a unique ID."
    , Doc ()
"data TokSymbol = TokSymbol"
    , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"{ tsText :: " Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
stringType
      , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 Doc ()
"-- ^ Keyword or symbol text."
      , Doc ()
", tsID   :: !Int"
      , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 Doc ()
"-- ^ Unique ID."
      , Doc ()
"} deriving (Show)" ]
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"-- | Keyword/symbol equality is determined by the unique ID."
    , Doc ()
"instance Eq  TokSymbol where (==)    = (==)    `on` tsID"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"-- | Keyword/symbol ordering is determined by the unique ID."
    , Doc ()
"instance Ord TokSymbol where compare = compare `on` tsID"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"-- | Token with position."
    , Doc ()
"data Token"
    , Doc ()
"  = PT  Posn Tok"
    , Doc ()
"  | Err Posn"
    , Doc ()
"  deriving (Eq, Show, Ord)"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"-- | Pretty print a position."
    , Doc ()
"printPosn :: Posn -> String"
    , Doc ()
"printPosn (Pn _ l c) = \"line \" ++ show l ++ \", column \" ++ show c"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"-- | Pretty print the position of the first token in the list."
    , Doc ()
"tokenPos :: [Token] -> String"
    , Doc ()
"tokenPos (t:_) = printPosn (tokenPosn t)"
    , Doc ()
"tokenPos []    = \"end of file\""
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"-- | Get the position of a token."
    , Doc ()
"tokenPosn :: Token -> Posn"
    , Doc ()
"tokenPosn (PT p _) = p"
    , Doc ()
"tokenPosn (Err p)  = p"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"-- | Get line and column of a token."
    , Doc ()
"tokenLineCol :: Token -> (Int, Int)"
    , Doc ()
"tokenLineCol = posLineCol . tokenPosn"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"-- | Get line and column of a position."
    , Doc ()
"posLineCol :: Posn -> (Int, Int)"
    , Doc ()
"posLineCol (Pn _ l c) = (l,c)"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"-- | Convert a token into \"position token\" form."
    , Doc ()
"mkPosToken :: Token -> ((Int, Int), " Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
stringType Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
")"
    , Doc ()
"mkPosToken t = (tokenLineCol t, tokenText t)"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
tokenTextfunction
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"-- | Convert a token to a string."
    , Doc ()
"prToken :: Token -> String"
    , Doc ()
"prToken t =" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> String -> Doc ()
applyP String
stringUnpack String
"tokenText t"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"-- | Convert potential keyword into token or use fallback conversion."
    , Doc ()
"eitherResIdent :: (" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
stringType Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"-> Tok) ->" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
stringType Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"-> Tok"
    , Doc ()
"eitherResIdent tv s = fromMaybe (tv s) (Map.lookup s resWords)"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"-- | The keywords and symbols of the language organized as a Map."
    , if TokenText -> Bool
isStringToken TokenText
tokenText
      then Doc ()
"resWords :: Map String Tok"
      else Doc ()
"resWords :: Map Data.Text.Text Tok"
    , Doc ()
"resWords = Map.fromAscList"
    , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [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 ()]
tokenTuples
    , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
forall ann. Doc ann
rbracket
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"-- | Unquote string literal."
    , Doc ()
"unescapeInitTail ::" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
stringType Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"->" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
stringType
    , Doc ()
"unescapeInitTail =" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
stringPack Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
      Doc ()
". unesc . tail . " Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a. IsString a => String -> a
fromString String
stringUnpack
    , Doc ()
"  where"
    , Doc ()
"  unesc s = case s of"
    , Doc ()
"    '\\\\':c:cs | elem c ['\\\"', '\\\\', '\\\''] -> c : unesc cs"
    , Doc ()
"    '\\\\':'n':cs  -> '\\n' : unesc cs"
    , Doc ()
"    '\\\\':'t':cs  -> '\\t' : unesc cs"
    , Doc ()
"    '\\\\':'r':cs  -> '\\r' : unesc cs"
    , Doc ()
"    '\\\\':'f':cs  -> '\\f' : unesc cs"
    , Doc ()
"    '\"':[]       -> []"
    , Doc ()
"    c:cs         -> c : unesc cs"
    , Doc ()
"    _            -> []"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"-------------------------------------------------------------------"
    , Doc ()
"-- Alex wrapper code."
    , Doc ()
"-- A modified \"posn\" wrapper."
    , Doc ()
"-------------------------------------------------------------------"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"data Posn = Pn !Int !Int !Int"
    , Doc ()
"  deriving (Eq, Show, Ord)"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"alexStartPos :: Posn"
    , Doc ()
"alexStartPos = Pn 0 1 1"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"alexMove :: Posn -> Char -> Posn"
    , Doc ()
"alexMove (Pn a l c) '\\t' = Pn (a+1)  l     (((c+7) `div` 8)*8+1)"
    , Doc ()
"alexMove (Pn a l c) '\\n' = Pn (a+1) (l+1)   1"
    , Doc ()
"alexMove (Pn a l c) _    = Pn (a+1)  l     (c+1)"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"type Byte = Word8"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"type AlexInput ="
    , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"( Posn     -- current position"
      , Doc ()
", Char     -- previous char"
      , Doc ()
", [Byte]   -- pending bytes on the current char"
      ,  Doc ()
forall ann. Doc ann
comma Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
stringType Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
") -- current input string"
      ]
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"tokens ::" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
stringType Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"-> [Token]"
    , Doc ()
"tokens str = go (alexStartPos, '\\n', [], str)"
    , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"where"
      , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
        [ Doc ()
"go :: AlexInput -> [Token]"
        , Doc ()
"go inp@(pos, _, _, str) ="
        , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
          [ Doc ()
"case alexScan inp 0 of"
          , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
            [ Doc ()
"AlexEOF                   -> []"
            , Doc ()
"AlexError (pos, _, _, _)  -> [Err pos]"
            , Doc ()
"AlexSkip  inp' len        -> go inp'"
            , Doc ()
"AlexToken inp' len act    -> act pos (" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
stringTake Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"len str) : (go inp')"
            ]
          ]
        ]
      ]
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"alexGetByte :: AlexInput -> Maybe (Byte,AlexInput)"
    , Doc ()
"alexGetByte (p, c, (b:bs), s) = Just (b, (p, c, bs, s))"
    , Doc ()
"alexGetByte (p, _, [], s) ="
    , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"case" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> String -> Doc ()
apply String
stringUncons String
"s" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
" of"
      , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
        [ Doc ()
stringNilP Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"-> Nothing"
        , Doc ()
stringConsP Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"->"
        , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
          [ Doc ()
"let p'     = alexMove p c"
          , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 Doc ()
"(b:bs) = utf8Encode c"
          , Doc ()
"in p' `seq` Just (b, (p', c, bs, s))"
          ]
        ]
      ]
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"alexInputPrevChar :: AlexInput -> Char"
    , Doc ()
"alexInputPrevChar (p, c, bs, s) = c"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"-- | Encode a Haskell String to a list of Word8 values, in UTF8 format."
    , Doc ()
"utf8Encode :: Char -> [Word8]"
    , Doc ()
"utf8Encode = map fromIntegral . go . ord"
    , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"where"
    , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"go oc"
    , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
3 Doc ()
"| oc <= 0x7f       = [oc]"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
3 Doc ()
"| oc <= 0x7ff      = [ 0xc0 + (oc `Data.Bits.shiftR` 6)"
    , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
24 Doc ()
", 0x80 + oc Data.Bits..&. 0x3f"
    , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
24 Doc ()
"]"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
3 Doc ()
"| oc <= 0xffff     = [ 0xe0 + (oc `Data.Bits.shiftR` 12)"
    , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
24 Doc ()
", 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)"
    , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
24 Doc ()
", 0x80 + oc Data.Bits..&. 0x3f"
    , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
24 Doc ()
"]"
    , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
3 Doc ()
"| otherwise        = [ 0xf0 + (oc `Data.Bits.shiftR` 18)"
    , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
24 Doc ()
", 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f)"
    , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
24 Doc ()
", 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)"
    , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
24 Doc ()
", 0x80 + oc Data.Bits..&. 0x3f"
    , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
24 Doc ()
"]"
    , Doc ()
forall ann. Doc ann
rbrace
    ]

  where

    symbolsKeywords :: [(Doc (), Int)]
    symbolsKeywords :: [(Doc (), Int)]
symbolsKeywords =
      ((CatName, Int) -> (Doc (), Int))
-> [(CatName, Int)] -> [(Doc (), Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      (\(CatName
s,Int
i) -> (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> String
escapeChars (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ CatName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList CatName
s), Int
i))
      (Map CatName Int -> [(CatName, Int)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map CatName Int -> [(CatName, Int)])
-> Map CatName Int -> [(CatName, Int)]
forall a b. (a -> b) -> a -> b
$ LBNF -> Map CatName Int
_lbnfSymbolsKeywords LBNF
lbnf)

    tokenTuples :: [Doc ()]
    tokenTuples :: [Doc ()]
tokenTuples = ((Doc (), Int) -> Doc ()) -> [(Doc (), Int)] -> [Doc ()]
forall a b. (a -> b) -> [a] -> [b]
map (Doc (), Int) -> Doc ()
toTokTuple [(Doc (), Int)]
symbolsKeywords

    -- tuple containing resersed word and corresponding token.
    toTokTuple :: (Doc (), Int) -> Doc ()
    toTokTuple :: (Doc (), Int) -> Doc ()
toTokTuple (Doc ()
n, Int
i) =
      if TokenText -> Bool
isStringToken TokenText
tokenText
      then [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
tupled [Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
dquotes Doc ()
n, Doc ()
"TS" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
dquotes Doc ()
n 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
i)]
      else [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
tupled
        [ Doc ()
"Data.Text.pack" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
dquotes Doc ()
n
        , Doc ()
"TS" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens ( Doc ()
"Data.Text.pack" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
dquotes Doc ()
n) 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
i)
        ]

    lineComment :: LineComment -> Doc ()
    lineComment :: LineComment -> Doc ()
lineComment (LineComment CatName
s) = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"-- Line comment" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
s'
      , Doc ()
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 ()
forall ann. Doc ann
semi
      ]
      where
        s' :: Doc ()
        s' :: Doc ()
s' = Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
dquotes (String -> Doc ()
forall a. IsString a => String -> a
fromString (CatName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList CatName
s))

    blockComment :: BlockComment -> Doc ()
    blockComment :: BlockComment -> Doc ()
blockComment (BlockComment CatName
s1 CatName
s2) =
      [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"-- Block comment" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
        Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
dquotes (String -> Doc ()
forall a. IsString a => String -> a
fromString (CatName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList CatName
s1)) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
        Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
dquotes (String -> Doc ()
forall a. IsString a => String -> a
fromString (CatName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList CatName
s2))
      , Regex -> Doc ()
printRegAlex (String -> String -> Regex
mkRegMultilineComment (CatName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList CatName
s1) (CatName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList CatName
s2)) Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
semi
      ]

    lbnfTokens :: TokenDefs
    lbnfTokens :: Map CatName (WithPosition TokenDef)
lbnfTokens =
      if Map CatName (WithPosition TokenDef) -> Bool
hasIdentifier (Map CatName (WithPosition TokenDef) -> Bool)
-> Map CatName (WithPosition TokenDef) -> Bool
forall a b. (a -> b) -> a -> b
$ LBNF -> Map CatName (WithPosition TokenDef)
_lbnfTokenDefs LBNF
lbnf
      then CatName
-> Map CatName (WithPosition TokenDef)
-> Map CatName (WithPosition TokenDef)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (Char
'I' Char -> String -> CatName
forall a. a -> [a] -> NonEmpty a
:| String
"dent") (LBNF -> Map CatName (WithPosition TokenDef)
_lbnfTokenDefs LBNF
lbnf)
      else LBNF -> Map CatName (WithPosition TokenDef)
_lbnfTokenDefs LBNF
lbnf

    userDefTokenTypes :: Doc ()
    userDefTokenTypes :: Doc ()
userDefTokenTypes = ([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
$
      (CatName, Regex) -> Doc ()
userDefTokenType ((CatName, Regex) -> Doc ())
-> ((CatName, WithPosition TokenDef) -> (CatName, Regex))
-> (CatName, WithPosition TokenDef)
-> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(CatName
a,WithPosition TokenDef
b) -> (CatName
a, (TokenDef -> Regex
regexToken (TokenDef -> Regex)
-> (WithPosition TokenDef -> TokenDef)
-> WithPosition TokenDef
-> Regex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithPosition TokenDef -> TokenDef
forall a. WithPosition a -> a
wpThing) WithPosition TokenDef
b))
      ((CatName, WithPosition TokenDef) -> Doc ())
-> [(CatName, WithPosition TokenDef)] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      Map CatName (WithPosition TokenDef)
-> [(CatName, WithPosition TokenDef)]
forall k a. Map k a -> [(k, a)]
Map.toList Map CatName (WithPosition TokenDef)
lbnfTokens

    userDefTokenType :: (CatName, Regex) -> Doc ()
    userDefTokenType :: (CatName, Regex) -> Doc ()
userDefTokenType (CatName
name, Regex
regex) = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"-- token" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString (CatName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList CatName
name)
      , Regex -> Doc ()
printRegAlex Regex
regex
      , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
braces (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc ()
forall ann. Doc ann
space Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"tok" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
forall ann. Doc ann
lparen Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"eitherResIdent T_" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<>
        String -> Doc ()
forall a. IsString a => String -> a
fromString (CatName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList CatName
name) Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
rparen Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
space
      ]

    usedBuiltins:: [BuiltinCat]
    usedBuiltins :: [BuiltinCat]
usedBuiltins = Map BuiltinCat (List1 Position) -> [BuiltinCat]
forall k a. Map k a -> [k]
Map.keys (Map BuiltinCat (List1 Position) -> [BuiltinCat])
-> Map BuiltinCat (List1 Position) -> [BuiltinCat]
forall a b. (a -> b) -> a -> b
$ LBNF -> Map BuiltinCat (List1 Position)
_lbnfParserBuiltins LBNF
lbnf

    tokDataTypes :: TokenText -> [Token] -> Doc ()
    tokDataTypes :: TokenText -> [Token] -> Doc ()
tokDataTypes TokenText
tt [Token]
tokens =
      if TokenText -> Bool
isStringToken TokenText
tt
      then
        [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$
          [ Doc ()
"data Tok"
          , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"= TK {-# UNPACK #-} !TokSymbol  -- ^ Reserved word or symbol."
          , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"| TL !String                    -- ^ String literal."
          , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"| TI !String                    -- ^ Integer literal."
          , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"| TV !String                    -- ^ Identifier."
          , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"| TD !String                    -- ^ Float literal."
          , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"| TC !String                    -- ^ Character literal."
              ]
          [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++ (Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> (Token -> Doc ()) -> Token -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> Doc ()
tokDataType (Token -> Doc ()) -> [Token] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
filter Token -> Bool
isUserDefined [Token]
tokens)
          [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++ [Doc ()
forall ann. Doc ann
space Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
space Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"deriving (Eq, Show, Ord)"]
      else
        [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$
          [ Doc ()
"data Tok"
          , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"= TK {-# UNPACK #-} !TokSymbol  -- ^ Reserved word or symbol."
          , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"| TL !Data.Text.Text            -- ^ String literal."
          , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"| TI !Data.Text.Text            -- ^ Integer literal."
          , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"| TV !Data.Text.Text            -- ^ Identifier."
          , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"| TD !Data.Text.Text            -- ^ Float literal."
          , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"| TC !Data.Text.Text            -- ^ Character literal."
              ]
          [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++ (Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> (Token -> Doc ()) -> Token -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> Doc ()
tokDataType (Token -> Doc ()) -> [Token] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
filter Token -> Bool
isUserDefined [Token]
tokens)
          [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++ [Doc ()
forall ann. Doc ann
space Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
space Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"deriving (Eq, Show, Ord)"]

    tokDataType :: Token -> Doc ()
    tokDataType :: Token -> Doc ()
tokDataType Token
token = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"|" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Token -> Doc ()
tokenName Token
token Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"!" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
stringType Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Token -> Doc ()
tokenComment Token
token
      ]

    tokenTextfunction :: Doc ()
    tokenTextfunction :: Doc ()
tokenTextfunction = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$
      [ Doc ()
"-- | Convert a token to its text."
      , Doc ()
"tokenText :: Token -> " Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
stringType
      , Doc ()
"tokenText t = case t of"
      , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
        [ Doc ()
"PT _ (TS s _) -> s"
        , Doc ()
"PT _ (TL s)   -> " Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> String -> Doc ()
applyP String
stringPack String
"show s"
        , Doc ()
"PT _ (TI s)   -> s"
        , Doc ()
"PT _ (TV s)   -> s"
        , Doc ()
"PT _ (TD s)   -> s"
        , Doc ()
"PT _ (TC s)   -> s"
        , Doc ()
"Err _         -> " Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> String -> Doc ()
apply String
stringPack String
"\"#error\""
        ]
      ]
      [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++ [ Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"PT _ (" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Token -> Doc ()
tokenName Token
token Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"s) -> s"
          | Token
token <- (Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
filter Token -> Bool
isUserDefined [Token]
toks ]

    (Doc ()
stringType, Doc ()
stringTake, String
stringUncons, String
stringPack, String
stringUnpack, Doc ()
stringNilP, Doc ()
stringConsP) =
      case TokenText
tokenText of
        TokenText
StringToken     -> (Doc ()
"String",        Doc ()
"take",    String
"",          String
"id",      String
"id",        Doc ()
"[]",      Doc ()
"(c:s)"     )
        TokenText
TextToken       -> (Doc ()
"Data.Text.Text", Doc ()
"Data.Text.take", String
"Data.Text.uncons", String
"Data.Text.pack", String
"Data.Text.unpack", Doc ()
"Nothing", Doc ()
"Just (c,s)")


    apply :: String -> String -> Doc ()
    apply :: String -> String -> Doc ()
apply String
""   String
s = String -> Doc ()
forall a. IsString a => String -> a
fromString String
s
    apply String
"id" String
s = String -> Doc ()
forall a. IsString a => String -> a
fromString String
s
    apply String
f    String
s = String -> Doc ()
forall a. IsString a => String -> a
fromString String
f Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
s

    applyP :: String -> String -> Doc ()
    applyP :: String -> String -> Doc ()
applyP String
""   String
s = String -> Doc ()
forall a. IsString a => String -> a
fromString String
s
    applyP String
"id" String
s = String -> Doc ()
forall a. IsString a => String -> a
fromString String
s
    applyP String
f    String
s = String -> Doc ()
forall a. IsString a => String -> a
fromString String
f Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
forall ann. Doc ann
lparen Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a. IsString a => String -> a
fromString String
s Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
rparen

-----------------------------------------------------------

-- Pretty printer for Regex.

-- The top-level printing method.

printRegAlex :: Regex -> Doc ()
printRegAlex :: Regex -> Doc ()
printRegAlex = Int -> Regex -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
0

-- the printer class does the job
class Print a where
  prt :: Int -> a -> Doc ()

instance {-# OVERLAPPABLE #-} Print a => Print [a] where
  prt :: Int -> [a] -> Doc ()
prt Int
i [a]
as = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ (a -> Doc ()) -> [a] -> [Doc ()]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> a -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
i) [a]
as

instance Print Char where
  prt :: Int -> Char -> Doc ()
prt Int
_ = \case
    Char
'\n'             -> Doc ()
"\\n"
    Char
'\t'             -> Doc ()
"\\t"
    Char
'\r'             -> Doc ()
"\\r"
    Char
'\f'             -> Doc ()
"\\f"
    Char
c | Char -> Bool
isAlphaNum Char
c -> String -> Doc ()
forall a. IsString a => String -> a
fromString [Char
c]
    Char
c | Char -> Bool
isPrint Char
c    -> String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:[Char
c]
    Char
c                -> String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show (Char -> Int
ord Char
c)

instance Print Regex where
  prt :: Int -> Regex -> Doc ()
prt Int
i Regex
e = case Regex
e of

    RChar (CMinus CharClassUnion
yes CharClassUnion
no) ->
      if CharClassUnion -> Bool
isEmpty CharClassUnion
no
      then
        if CharClassUnion -> Bool
onlyOneChar CharClassUnion
yes
        then Int -> CharClassUnion -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
2 CharClassUnion
yes
        else
          Doc ()
forall ann. Doc ann
lbracket Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> CharClassUnion -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
2 CharClassUnion
yes Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
forall ann. Doc ann
rbracket
      else
        Doc ()
forall ann. Doc ann
lbracket Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
        Int -> CharClassUnion -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
2 CharClassUnion
yes Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
        String -> Doc ()
forall a. IsString a => String -> a
fromString String
"#" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
        Int -> CharClassUnion -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
2 CharClassUnion
no Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
        Doc ()
forall ann. Doc ann
rbracket

    RAlts  List2 Regex
regs -> Int -> Int -> Doc () -> Doc ()
prPrec Int
i Int
1 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
intersperse Doc ()
"|" ([Doc ()] -> [Doc ()]) -> [Doc ()] -> [Doc ()]
forall a b. (a -> b) -> a -> b
$
      (Regex -> Doc ()) -> [Regex] -> [Doc ()]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Regex -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
1) ([Regex] -> [Doc ()]) -> [Regex] -> [Doc ()]
forall a b. (a -> b) -> a -> b
$ List2 Regex -> [Item (List2 Regex)]
forall l. IsList l => l -> [Item l]
List2.toList List2 Regex
regs

    RMinus Regex
reg1 Regex
reg2 ->
      Doc ()
forall ann. Doc ann
lbracket Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
      Int -> Regex -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
2 Regex
reg1 Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
      String -> Doc ()
forall a. IsString a => String -> a
fromString String
"#" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
      Int -> Regex -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
2 Regex
reg2 Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
      Doc ()
forall ann. Doc ann
rbracket

    Regex
REps -> Doc ()
forall ann. Doc ann
lparen Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
rparen

    RSeqs  List2 Regex
regs -> Int -> Int -> Doc () -> Doc ()
prPrec Int
i Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ Int -> [Regex] -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
2 ([Regex] -> Doc ()) -> [Regex] -> Doc ()
forall a b. (a -> b) -> a -> b
$ List2 Regex -> [Item (List2 Regex)]
forall l. IsList l => l -> [Item l]
List2.toList List2 Regex
regs

    RStar  Regex
reg  -> Int -> Int -> Doc () -> Doc ()
prPrec Int
i Int
3 (Int -> Regex -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
3 Regex
reg) Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a. IsString a => String -> a
fromString String
"*"

    RPlus  Regex
reg  -> Int -> Int -> Doc () -> Doc ()
prPrec Int
i Int
3 (Int -> Regex -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
3 Regex
reg) Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a. IsString a => String -> a
fromString String
"+"

    ROpt   Regex
reg  -> Int -> Int -> Doc () -> Doc ()
prPrec Int
i Int
3 (Int -> Regex -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
3 Regex
reg) Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a. IsString a => String -> a
fromString String
"?"

instance Print CharClassUnion where
  prt :: Int -> CharClassUnion -> Doc ()
prt Int
i CharClassUnion
e = case CharClassUnion
e of
    CharClassUnion
CAny      -> Doc ()
"$u"
    CAlt [CharClassAtom]
alts -> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ (CharClassAtom -> Doc ()) -> [CharClassAtom] -> [Doc ()]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> CharClassAtom -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
i) [CharClassAtom]
alts

instance Print CharClassAtom where
  prt :: Int -> CharClassAtom -> Doc ()
prt Int
_ CharClassAtom
e = case CharClassAtom
e of
    CChar Char
c -> Int -> Char -> Doc ()
forall a. Print a => Int -> a -> Doc ()
prt Int
0 Char
c
    CharClassAtom
CDigit  -> String -> Doc ()
forall a. IsString a => String -> a
fromString String
"$d"
    CharClassAtom
CLower  -> String -> Doc ()
forall a. IsString a => String -> a
fromString String
"$s"
    CharClassAtom
CUpper  -> String -> Doc ()
forall a. IsString a => String -> a
fromString String
"$c"