{-
    BNF Converter: Layout handling Generator
    Copyright (C) 2004  Author:  Aarne Ranta
    Copyright (C) 2005  Bjorn Bringert

-}

module BNFC.Backend.Haskell.CFtoLayout where

import Data.List (sort)
import BNFC.CF
import BNFC.Options (TokenText(..))
import BNFC.Backend.Haskell.Utils

layoutOpen :: [Char]
layoutOpen  = [Char]
"{"
layoutClose :: [Char]
layoutClose = [Char]
"}"
layoutSep :: [Char]
layoutSep   = [Char]
";"

cf2Layout :: TokenText -> String -> String -> CF -> String
cf2Layout :: TokenText -> [Char] -> [Char] -> CF -> [Char]
cf2Layout TokenText
tokenText [Char]
layName [Char]
lexName CF
cf = [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [
  [Char]
"module " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
layName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" where",
  [Char]
"",
  [Char]
"import Prelude",
  [Char]
"",
  [Char]
"import " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
lexName,
  [Char]
"",
  if TokenText
tokenText TokenText -> TokenText -> Bool
forall a. Eq a => a -> a -> Bool
== TokenText
TextToken then [Char]
"import qualified Data.Text" else [Char]
"",
  [Char]
"import Data.Maybe (isNothing, fromJust)",
  [Char]
"",
  [Char]
"-- Generated by the BNF Converter",
  [Char]
"",
  [Char]
"-- local parameters",
  [Char]
"",
  [Char]
"",
  [Char]
"topLayout :: Bool",
  [Char]
"topLayout = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Bool -> [Char]
forall a. Show a => a -> [Char]
show Bool
top,
  [Char]
"",
  [Char]
"layoutWords, layoutStopWords :: [String]",
  [Char]
"layoutWords     = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show [[Char]]
lay,
  [Char]
"layoutStopWords = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show [[Char]]
stop,
  [Char]
"",
  [Char]
"-- layout separators",
  [Char]
"",
  [Char]
"",
  [Char]
"layoutOpen, layoutClose, layoutSep :: String",
  [Char]
"layoutOpen  = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
layoutOpen,
  [Char]
"layoutClose = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
layoutClose,
  [Char]
"layoutSep   = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
layoutSep,
  [Char]
"",
  [Char]
"-- | Replace layout syntax with explicit layout tokens.",
  [Char]
"resolveLayout :: Bool    -- ^ Whether to use top-level layout.",
  [Char]
"              -> [Token] -> [Token]",
  [Char]
"resolveLayout tp = res Nothing [if tl then Implicit 1 else Explicit]",
  [Char]
"  where",
  [Char]
"  -- Do top-level layout if the function parameter and the grammar say so.",
  [Char]
"  tl = tp && topLayout",
  [Char]
"",
  [Char]
"  res :: Maybe Token -- ^ The previous token, if any.",
  [Char]
"      -> [Block] -- ^ A stack of layout blocks.",
  [Char]
"      -> [Token] -> [Token]",
  [Char]
"",
  [Char]
"  -- The stack should never be empty.",
  [Char]
"  res _ [] ts = error $ \"Layout error: stack empty. Tokens: \" ++ show ts",
  [Char]
"",
  [Char]
"  res _ st (t0:ts)",
  [Char]
"    -- We found an open brace in the input,",
  [Char]
"    -- put an explicit layout block on the stack.",
  [Char]
"    -- This is done even if there was no layout word,",
  [Char]
"    -- to keep opening and closing braces.",
  [Char]
"    | isLayoutOpen t0 = moveAlong (Explicit:st) [t0] ts",
  [Char]
"",
  [Char]
"  -- We are in an implicit layout block",
  [Char]
"  res pt (Implicit n:ns) (t0:ts)",
  [Char]
"",
  [Char]
"      -- End of implicit block by a layout stop word",
  [Char]
"    | isStop t0 =",
  [Char]
"           -- Exit the current block and all implicit blocks",
  [Char]
"           -- more indented than the current token",
  [Char]
"       let (ebs,ns') = span (`moreIndent` column t0) ns",
  [Char]
"           moreIndent (Implicit x) y = x > y",
  [Char]
"           moreIndent Explicit _ = False",
  [Char]
"           -- the number of blocks exited",
  [Char]
"           b = 1 + length ebs",
  [Char]
"           bs = replicate b layoutClose",
  [Char]
"           -- Insert closing braces after the previous token.",
  [Char]
"           (ts1,ts2) = splitAt (1+b) $ addTokens (afterPrev pt) bs (t0:ts)",
  [Char]
"        in moveAlong ns' ts1 ts2",
  [Char]
"",
  [Char]
"    -- End of an implicit layout block",
  [Char]
"    | newLine pt t0 && column t0 < n  = ",
  [Char]
"           -- Insert a closing brace after the previous token.",
  [Char]
"       let b:t0':ts' = addToken (afterPrev pt) layoutClose (t0:ts)",
  [Char]
"           -- Repeat, with the current block removed from the stack",
  [Char]
"        in moveAlong ns [b] (t0':ts')",
  [Char]
"",
  [Char]
"  res pt st (t0:ts)",
  [Char]
"    -- Start a new layout block if the first token is a layout word",
  [Char]
"    | isLayout t0 =",
  [Char]
"        case ts of",
  [Char]
"            -- Explicit layout, just move on. The case above",
  [Char]
"            -- will push an explicit layout block.",
  [Char]
"            t1:_ | isLayoutOpen t1 -> moveAlong st [t0] ts",
  [Char]
"                 -- The column of the next token determines the starting column",
  [Char]
"                 -- of the implicit layout block.",
  [Char]
"                 -- However, the next block needs to be strictly more indented",
  [Char]
"                 -- than the previous block.",
  [Char]
"            _ -> let col = max (indentation st + 1) $",
  [Char]
"                       -- at end of file, the start column doesn't matter",
  [Char]
"                       if null ts then column t0 else column (head ts)",
  [Char]
"                     -- insert an open brace after the layout word",
  [Char]
"                     b:ts' = addToken (nextPos t0) layoutOpen ts",
  [Char]
"                     -- save the start column",
  [Char]
"                     st' = Implicit col:st ",
  [Char]
"                 in -- Do we have to insert an extra layoutSep?",
  [Char]
"                case st of",
  [Char]
"                  Implicit n:_",
  [Char]
"                    | newLine pt t0 && column t0 == n",
  [Char]
"                      && not (isNothing pt ||",
  [Char]
"                              isTokenIn [layoutSep,layoutOpen] (fromJust pt)) ->",
  [Char]
"                     let b':t0':b'':_ =",
  [Char]
"                           addToken (afterPrev pt) layoutSep (t0:b:ts')",
  [Char]
"                     in moveAlong st' [b',t0',b''] ts'",
  [Char]
"                  _ -> moveAlong st' [t0,b] ts'",
  [Char]
"",
  [Char]
"    -- If we encounter a closing brace, exit the first explicit layout block.",
  [Char]
"    | isLayoutClose t0 = ",
  [Char]
"          let st' = drop 1 (dropWhile isImplicit st)",
  [Char]
"           in if null st' ",
  [Char]
"                 then error $ \"Layout error: Found \" ++ layoutClose ++ \" at (\" ",
  [Char]
"                              ++ show (line t0) ++ \",\" ++ show (column t0) ",
  [Char]
"                              ++ \") without an explicit layout block.\"",
  [Char]
"                 else moveAlong st' [t0] ts",
  [Char]
"",
  [Char]
"  -- Insert separator if necessary.",
  [Char]
"  res pt st@(Implicit n : _) (t0:ts)",
  [Char]
"    -- Encounted a new line in an implicit layout block.",
  [Char]
"    | newLine pt t0 && column t0 == n = ",
  [Char]
"       -- Insert a semicolon after the previous token.",
  [Char]
"       -- unless we are the beginning of the file,",
  [Char]
"       -- or the previous token is a semicolon or open brace.",
  [Char]
"       if isNothing pt || isTokenIn [layoutSep,layoutOpen] (fromJust pt)",
  [Char]
"          then moveAlong st [t0] ts",
  [Char]
"          else let b:t0':ts' = addToken (afterPrev pt) layoutSep (t0:ts)",
  [Char]
"                in moveAlong st [b,t0'] ts'",
  [Char]
"",
  [Char]
"  -- Nothing to see here, move along.",
  [Char]
"  res _ st (t:ts)  = moveAlong st [t] ts",
  [Char]
"",
  [Char]
"  -- At EOF: skip explicit blocks.",
  [Char]
"  res (Just t) (Explicit:bs) [] | null bs = []",
  [Char]
"                                | otherwise = res (Just t) bs []",
  [Char]
"",
  [Char]
"  -- If we are using top-level layout, insert a semicolon after",
  [Char]
"  -- the last token, if there isn't one already",
  [Char]
"  res (Just t) [Implicit _n] []",
  [Char]
"      | isTokenIn [layoutSep] t = []",
  [Char]
"      | otherwise = addToken (nextPos t) layoutSep []",
  [Char]
"",
  [Char]
"  -- At EOF in an implicit, non-top-level block: close the block",
  [Char]
"  res (Just t) (Implicit _ : bs) [] =",
  [Char]
"     let c = addToken (nextPos t) layoutClose []",
  [Char]
"      in moveAlong bs c []",
  [Char]
"",
  [Char]
"  -- This should only happen if the input is empty.",
  [Char]
"  res Nothing _st [] = []",
  [Char]
"",
  [Char]
"  -- | Move on to the next token.",
  [Char]
"  moveAlong :: [Block] -- ^ The layout stack.",
  [Char]
"            -> [Token] -- ^ Any tokens just processed.",
  [Char]
"            -> [Token] -- ^ the rest of the tokens.",
  [Char]
"            -> [Token]",
  [Char]
"  moveAlong _  [] _  = error \"Layout error: moveAlong got [] as old tokens\"",
  [Char]
"  moveAlong st ot ts = ot ++ res (Just $ last ot) st ts",
  [Char]
"",
  [Char]
"  newLine :: Maybe Token -> Token -> Bool",
  [Char]
"  newLine pt t0 = case pt of",
  [Char]
"    Nothing -> True",
  [Char]
"    Just t  -> line t /= line t0",
  [Char]
"",
  [Char]
"data Block",
  [Char]
"   = Implicit Int -- ^ An implicit layout block with its start column.",
  [Char]
"   | Explicit",
  [Char]
"   deriving Show",
  [Char]
"",
  [Char]
"-- | Get current indentation.  0 if we are in an explicit block.",
  [Char]
"indentation :: [Block] -> Int",
  [Char]
"indentation (Implicit n : _) = n",
  [Char]
"indentation _ = 0",
  [Char]
"",
  [Char]
"-- | Check if s block is implicit.",
  [Char]
"isImplicit :: Block -> Bool",
  [Char]
"isImplicit (Implicit _) = True",
  [Char]
"isImplicit _ = False",
  [Char]
"",
  [Char]
"type Position = Posn",
  [Char]
"",
  [Char]
"-- | Insert a number of tokens at the begninning of a list of tokens.",
  [Char]
"addTokens :: Position -- ^ Position of the first new token.",
  [Char]
"          -> [String] -- ^ Token symbols.",
  [Char]
"          -> [Token]  -- ^ The rest of the tokens. These will have their",
  [Char]
"                      --   positions updated to make room for the new tokens .",
  [Char]
"          -> [Token]",
  [Char]
"addTokens p ss ts = foldr (addToken p) ts ss",
  [Char]
"",
  [Char]
"-- | Insert a new symbol token at the begninning of a list of tokens.",
  [Char]
"addToken :: Position -- ^ Position of the new token.",
  [Char]
"         -> String   -- ^ Symbol in the new token.",
  [Char]
"         -> [Token]  -- ^ The rest of the tokens. These will have their",
  [Char]
"                     --   positions updated to make room for the new token.",  [Char]
"         -> [Token]",
  [Char]
"addToken p s ts = sToken p s : map (incrGlobal p (length s)) ts",
  [Char]
"",
  [Char]
"-- | Get the position immediately to the right of the given token.",
  [Char]
"--   If no token is given, gets the first position in the file.",
  [Char]
"afterPrev :: Maybe Token -> Position",
  [Char]
"afterPrev = maybe (Pn 0 1 1) nextPos",
  [Char]
"",
  [Char]
"-- | Get the position immediately to the right of the given token.",
  [Char]
"nextPos :: Token -> Position",
  [Char]
"nextPos t = Pn (g + s) l (c + s + 1)",
  [Char]
"  where Pn g l c = position t",
  [Char]
"        s = tokenLength t",
  [Char]
"",
  [Char]
"-- | Add to the global and column positions of a token.",
  [Char]
"--   The column position is only changed if the token is on",
  [Char]
"--   the same line as the given position.",
  [Char]
"incrGlobal :: Position -- ^ If the token is on the same line",
  [Char]
"                       --   as this position, update the column position.",
  [Char]
"           -> Int      -- ^ Number of characters to add to the position.",
  [Char]
"           -> Token -> Token",
  [Char]
"incrGlobal (Pn _ l0 _) i (PT (Pn g l c) t) =",
  [Char]
"  if l /= l0 then PT (Pn (g + i) l c) t",
  [Char]
"             else PT (Pn (g + i) l (c + i)) t",
  [Char]
"incrGlobal _ _ p = error $ \"cannot add token at \" ++ show p",
  [Char]
"",
  [Char]
"-- | Create a symbol token.",
  [Char]
"sToken :: Position -> String -> Token",
  [Char]
"sToken p s = PT p (TS " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TokenText -> [Char] -> [Char]
tokenTextPackParens TokenText
tokenText [Char]
"s" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" i)",
  [Char]
"  where",
  [Char]
"    i = case s of"] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
  [ [Char]
"      " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" -> " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
i
    | ([Char]
s, Integer
i) <- [[Char]] -> [Integer] -> [([Char], Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[Char]]
resws [Integer
1..]
  ] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
  [[Char]
"      _ -> error $ \"not a reserved word: \" ++ show s",
  [Char]
"",
  [Char]
"-- | Get the position of a token.",
  [Char]
"position :: Token -> Position",
  [Char]
"position t = case t of",
  [Char]
"  PT p _ -> p",
  [Char]
"  Err p -> p",
  [Char]
"",
  [Char]
"-- | Get the line number of a token.",
  [Char]
"line :: Token -> Int",
  [Char]
"line t = case position t of Pn _ l _ -> l",
  [Char]
"",
  [Char]
"-- | Get the column number of a token.",
  [Char]
"column :: Token -> Int",
  [Char]
"column t = case position t of Pn _ _ c -> c",
  [Char]
"",
  [Char]
"-- | Check if a token is one of the given symbols.",
  [Char]
"isTokenIn :: [String] -> Token -> Bool",
  [Char]
"isTokenIn ts t = case t of",
  [Char]
"  PT _ (TS r _) | " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TokenText -> [Char] -> [Char]
tokenTextUnpack TokenText
tokenText [Char]
"r" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" `elem` ts -> True",
  [Char]
"  _ -> False",
  [Char]
"",
  [Char]
"-- | Check if a word is a layout start token.",
  [Char]
"isLayout :: Token -> Bool",
  [Char]
"isLayout = isTokenIn layoutWords",
  [Char]
"",
  [Char]
"-- | Check if a token is a layout stop token.",
  [Char]
"isStop :: Token -> Bool",
  [Char]
"isStop = isTokenIn layoutStopWords",
  [Char]
"",
  [Char]
"-- | Check if a token is the layout open token.",
  [Char]
"isLayoutOpen :: Token -> Bool",
  [Char]
"isLayoutOpen = isTokenIn [layoutOpen]",
  [Char]
"",
  [Char]
"-- | Check if a token is the layout close token.",
  [Char]
"isLayoutClose :: Token -> Bool",
  [Char]
"isLayoutClose = isTokenIn [layoutClose]",
  [Char]
"",
  [Char]
"-- | Get the number of characters in the token.",
  [Char]
"tokenLength :: Token -> Int",
  [Char]
"tokenLength t = length $ prToken t",

  [Char]
""
  ]
  where
    resws :: [[Char]]
resws = [[Char]] -> [[Char]]
forall a. Ord a => [a] -> [a]
sort ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ CF -> [[Char]]
forall f. CFG f -> [[Char]]
reservedWords CF
cf [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ CF -> [[Char]]
forall f. CFG f -> [[Char]]
cfgSymbols CF
cf
    (Bool
top,[[Char]]
lay,[[Char]]
stop) = CF -> (Bool, [[Char]], [[Char]])
layoutPragmas CF
cf