content: {-
      BNF Converter: Layout handling Generator
      Copyright (C) 2004  Author:  Aarne Ranta
      Copyright (C) 2005  Bjorn Bringert
  
  -}
  
  {-# LANGUAGE OverloadedStrings #-}
  
  module BNFC.Backend.Haskell.CFtoLayout where
  
  import Data.Maybe                 ( fromMaybe, mapMaybe )
  
  import BNFC.CF
  import BNFC.PrettyPrint
  import BNFC.Utils                 ( caseMaybe, for, whenJust )
  
  data TokSymbol = TokSymbol String Int
    deriving Show
  
  data LayoutDelimiters = LayoutDelimiters TokSymbol (Maybe TokSymbol) (Maybe TokSymbol)
    deriving Show
  
  cf2Layout :: String -> String -> CF -> String
  cf2Layout layName lexName cf = unlines $ concat
    [ [ "{-# OPTIONS_GHC -Wno-incomplete-patterns #-}"
      , ""
      , "{-# LANGUAGE LambdaCase #-}"
      , "{-# LANGUAGE PatternGuards #-}"
      , "{-# LANGUAGE OverloadedStrings #-}"
      , ""
      , "module " ++ layName ++ " where"
      , ""
      , "import Prelude"
      , "import Data.Maybe ( fromMaybe, listToMaybe, mapMaybe )"
      , "import qualified Data.List as List"
      , ""
      , "import " ++ lexName
      , "  ( Posn(..), Tok(..), Token(..), TokSymbol(..)"
      , "  , prToken, tokenLineCol, tokenPos, tokenPosn"
      , "  )"
      , ""
      , "-- local parameters"
      , ""
      , "data LayoutDelimiters"
      , "  = LayoutDelimiters"
      , "    { delimSep   :: TokSymbol"
      , "    , delimOpen  :: Maybe TokSymbol  -- ^ Nothing for toplevel layout."
      , "    , delimClose :: Maybe TokSymbol  -- ^ Nothing for toplevel layout."
      , "    }"
      , ""
      , "layoutWords :: [(TokSymbol, LayoutDelimiters)]"
      , render $ prettyList 2 "layoutWords =" "[" "]" "," $
          for lay $ \ (kw, delims) ->
            prettyList 0 empty "(" ")" "," $
              map text [ show kw, show delims ]
      , ""
      , "layoutStopWords :: [TokSymbol]"
      , render $ prettyList 2 "layoutStopWords =" "[" "]" "," $ map (text . show) stop
      , ""
      , "-- layout separators"
      , ""
      , "layoutOpen, layoutClose, layoutSep :: [TokSymbol]"
      , "layoutOpen  = List.nub $ mapMaybe (delimOpen  . snd) layoutWords"
      , "layoutClose = List.nub $ mapMaybe (delimClose . snd) layoutWords"
      , unwords $ concat
        [ [ "layoutSep   = List.nub $" ]
        , whenJust top $ \ sep -> [ show sep, ":" ]
        , [ "map (delimSep . snd) layoutWords" ]
        ]
      , ""
      , "parenOpen, parenClose :: [TokSymbol]"
      , render $ prettyList 2 "parenOpen  =" "[" "]" "," $ map (text . show) parenOpen
      , render $ prettyList 2 "parenClose =" "[" "]" "," $ map (text . show) parenClose
      , ""
      , "-- | Report an error during layout resolution."
      , "layoutError"
      , "   :: [Token]  -- ^ Remaining tokens."
      , "   -> String   -- ^ Error message."
      , "   -> a"
      , "layoutError ts msg"
      , "  | null ts   = error $ concat [ \"Layout error: \", msg, \".\" ]"
      , "  | otherwise = error $ unlines"
      , "      [ concat [ \"Layout error at \", tokenPos ts, \": \", msg, \".\" ]"
      , "      , unwords $ concat"
      , "         [ [ \"Remaining tokens:\" ]"
      , "         , map prToken $ take 10 ts"
      , "         , [ \"...\" | not $ null $ drop 10 ts ]"
      , "         ]"
      , "      ]"
      , ""
      , "-- | Replace layout syntax with explicit layout tokens."
      , "resolveLayout"
      , "  :: Bool      -- ^ Whether to use top-level layout."
      , "  -> [Token]   -- ^ Token stream before layout resolution."
      , "  -> [Token]   -- ^ Token stream after layout resolution."
      ]
    , caseMaybe topDelim
      -- No top-level layout
      [ "resolveLayout _topLayout = res Nothing [Explicit]"
      , "  where"
      ]
      -- Can have top-level layout
      (\ delim ->
      [ "resolveLayout topLayout ="
      , "  res Nothing [if topLayout then Implicit topDelim Definitive 1 else Explicit]"
      , "  where"
      , "  topDelim :: LayoutDelimiters"
      , "  topDelim = " ++ show delim
      ])
    , [ ""
      , "  res :: Maybe Token -- ^ The previous token, if any."
      , "      -> [Block]     -- ^ A stack of layout blocks."
      , "      -> [Token] -> [Token]"
      , ""
      , "  -- The stack should never be empty."
      , "  res _ [] ts = layoutError ts \"layout stack empty\""
      , ""
      , "  -- Handling explicit blocks:"
      , "  res _ st (t0 : ts)"
      , "    -- We found an open brace in the input,"
      , "    -- put an explicit layout block on the stack."
      , "    -- This is done even if there was no layout word,"
      , "    -- to keep opening and closing braces."
      , "    | isLayoutOpen t0 || isParenOpen t0"
      , "      = t0 : res (Just t0) (Explicit : st) ts"
      , ""
      , "    -- If we encounter a closing brace, exit the first explicit layout block."
      , "    | isLayoutClose t0 || isParenClose t0"
      , "      , let (imps, rest) = span isImplicit st"
      , "      , let st' = drop 1 rest"
      , "      = if null st'"
      , "        then layoutError ts $ unwords"
      , "          [ \"found\", prToken t0, \"at\" , tokenPos [t0]"
      , "          , \"without an explicit layout block\""
      , "          ]"
      , "        else map (closingToken ts (tokenPosn t0)) imps ++ t0 : res (Just t0) st' ts"
      , ""
      , "  -- Ending or confirming implicit layout blocks:"
      , "  res pt (b@(Implicit delim status col) : bs) (t0 : ts)"
      , "    "
      , "      -- Do not end top-level layout block by layout stop word."
      , "    | isStop t0,  col <= 1"
      , "      = t0 : res (Just t0) (b : bs) ts"
      , ""
      , "      -- End of implicit block by a layout stop word."
      , "    | isStop t0"
      , "           -- Exit the current block and all implicit blocks"
      , "           -- more indented than the current token."
      , "      , let (ebs, st') = span ((column t0 <) . indentation) bs"
      , "           -- Insert block-closers after the previous token."
      , "      = map (closingToken ts (afterPrev pt)) (b : ebs) ++ t0 : res (Just t0) st' ts"
      , ""
      , "    -- End of an implicit layout block by dedentation."
      , "    | newLine pt t0"
      , "      , column t0 < col"
      , "           -- Insert a block closer after the previous token."
      , "           -- Repeat, with the current block removed from the stack."
      , "      , let c = closingToken ts (afterPrev pt) b"
      , "      = c : res (Just c) bs (t0 : ts)"
      , ""
      , "    -- If we are on a newline, confirm the last tentative blocks."
      , "    | newLine pt t0, Tentative{} <- status"
      , "      = res pt (Implicit delim Definitive col : confirm col bs) (t0 : ts)"
      , ""
      , "  -- Starting and processing implicit layout blocks:"
      , "  res pt st (t0 : ts)"
      , "    -- Start a new layout block if the first token is a layout word."
      , "    | Just delim@(LayoutDelimiters _ mopen _) <- isLayout t0"
      , "      = maybeInsertSeparator pt t0 st $"
      , "        case ts of"
      , "          -- Explicit layout, just move on. The next step"
      , "          -- will push an explicit layout block."
      , "          t1 : _ | isLayoutOpen t1 ->"
      , "            t0 : res (Just t0) st ts"
      , "          -- Otherwise, insert an open brace after the layout word"
      , "          _ ->"
      , "            t0 : b : res (Just b) (addImplicit delim (tokenPosn t0) pos st) ts"
      , "            where"
      , "            b   = sToken (nextPos t0) $ fromMaybe undefined mopen"
      , "            -- At the end of the file, the start column does not matter."
      , "            -- So if there is no token t1 after t0, just use the position of t0."
      , "            pos = tokenPosn $ fromMaybe t0 $ listToMaybe ts"
      , ""
      , "    -- Insert separator if necessary."
      , "    | otherwise"
      , "      = maybeInsertSeparator pt t0 st $"
      , "        t0 : res (Just t0) st ts"
      , ""
      , "  -- At EOF: skip explicit blocks."
      , "  res (Just _) [Explicit]      [] = []"
      , "  res (Just t) (Explicit : bs) [] = res (Just t) bs []"
      , ""
      , "  -- If we are using top-level layout, insert a semicolon after"
      , "  -- the last token, if there isn't one already"
      , "  res (Just t) [Implicit (LayoutDelimiters sep _ _) _ _] []"
      , "    | isLayoutSep t = []"
      , "    | otherwise     = [sToken (nextPos t) sep]"
      , ""
      , "  -- At EOF in an implicit, non-top-level block: close the block"
      , "  res (Just t) (Implicit (LayoutDelimiters _ _ (Just close)) _ _ : bs) []"
      , "      = b : res (Just b) bs []"
      , "        where b = sToken (nextPos t) close"
      , ""
      , "  -- This should only happen if the input is empty."
      , "  res Nothing _st []"
      , "      = []"
      , ""
      , "  -- | Insert a 'layoutSep' if we are on a new line on the current"
      , "  --   implicit layout column."
      , "  maybeInsertSeparator"
      , "    :: Maybe Token  -- ^ The previous token."
      , "    -> Token        -- ^ The current token."
      , "    -> [Block]      -- ^ The layout stack."
      , "    -> [Token]      -- ^ The result token stream."
      , "    -> [Token]      -- ^ Maybe prepended with a 'layoutSep'."
      , "  maybeInsertSeparator pt t0 = \\case"
      , "    Implicit (LayoutDelimiters sep _ _) _ n : _"
      , "      | newLine pt t0"
      , "      , column t0 == n"
      , "      , maybe False (not . isTokenIn (layoutSep ++ layoutOpen)) pt"
      , "       -- Insert a semicolon after the previous token"
      , "       -- unless we are the beginning of the file,"
      , "       -- or the previous token is a semicolon or open brace."
      , "      -> (sToken (afterPrev pt) sep :)"
      , "    _ -> id"
      , ""
      , "  closingToken :: [Token] -> Position -> Block -> Token"
      , "  closingToken ts pos = sToken pos . \\case"
      , "    Implicit (LayoutDelimiters _ _ (Just sy)) _ _ -> sy"
      , "    _ -> layoutError ts \"trying to close a top level block\""
      , ""
      , "type Position = Posn"
      , "type Line     = Int"
      , "type Column   = Int"
      , ""
      , "-- | Entry of the layout stack."
      , "data Block"
      , "   = Implicit LayoutDelimiters Status Column"
      , "       -- ^ An implicit layout block with its start column."
      , "   | Explicit"
      , ""
      , "-- | Get current indentation.  0 if we are in an explicit block."
      , "indentation :: Block -> Column"
      , "indentation = \\case"
      , "  Implicit _ _ n -> n"
      , "  Explicit -> 0"
      , ""
      , "-- | Check if s block is implicit."
      , "isImplicit :: Block -> Bool"
      , "isImplicit = \\case"
      , "  Implicit{} -> True"
      , "  Explicit{} -> False"
      , ""
      , "data Status"
      , "  = Tentative   -- ^ A layout column that has not been confirmed by a line break"
      , "  | Definitive  -- ^ A layout column that has been confirmed by a line break."
      , ""
      , "-- | Add a new implicit layout block."
      , "addImplicit"
      , "  :: LayoutDelimiters -- ^ Delimiters of the new block."
      , "  -> Position         -- ^ Position of the layout keyword."
      , "  -> Position         -- ^ Position of the token following the layout keword."
      , "  -> [Block]"
      , "  -> [Block]"
      , "addImplicit delim (Pn _ l0 _) (Pn _ l1 c1) st"
      , "    -- Case: layout keyword was at the end of the line:"
      , "    -- New implicit block is definitive."
      , "    | l1 > l0   = Implicit delim Definitive (col st') : st'"
      , "    -- Case: staying on the same line:"
      , "    -- New implicit block is tentative."
      , "    | otherwise = Implicit delim Tentative (col st) : st"
      , "  where"
      , "  st' = confirm c1 st"
      , "  col bs = max c1 $ 1 + definiteIndentation bs"
      , "    -- The column of the next token determines the starting column"
      , "    -- of the implicit layout block."
      , "    -- However, the next block needs to be strictly more indented"
      , "    -- than the previous block."
      , ""
      , "  -- | Get the current confirmed indentation level."
      , "  definiteIndentation :: [Block] -> Int"
      , "  definiteIndentation bs ="
      , "    case dropWhile isTentative bs of"
      , "      Implicit _ Definitive n : _ -> n"
      , "      _ -> 0  -- 0 enables a first unindented block, see 194_layout/good05.in"
      , ""
      , "  isTentative :: Block -> Bool"
      , "  isTentative = \\case"
      , "    Implicit _ Tentative _ -> True"
      , "    _ -> False"
      , ""
      , "-- | Confirm tentative blocks that are not more indented than @col@."
      , "confirm :: Column -> [Block] -> [Block]"
      , "confirm c0 = loop"
      , "  where"
      , "  loop = \\case"
      , "    Implicit delim Tentative c : bs"
      , "      | c <= c0 -> Implicit delim Definitive c : loop bs"
      , "    bs -> bs"
      , ""
      , "-- | Get the position immediately to the right of the given token."
      , "--   If no token is given, gets the first position in the file."
      , "afterPrev :: Maybe Token -> Position"
      , "afterPrev = maybe (Pn 0 1 1) nextPos"
      , ""
      , "-- | Get the position immediately to the right of the given token."
      , "nextPos :: Token -> Position"
      , "nextPos t = Pn (g + s) l (c + s + 1)"
      , "  where"
      , "  Pn g l c = tokenPosn t"
      , "  s        = tokenLength t"
      , ""
      , "-- | Get the number of characters in the token."
      , "tokenLength :: Token -> Int"
      , "tokenLength = length . prToken"
      , ""
      , "-- | Create a position symbol token."
      , "sToken :: Position -> TokSymbol -> Token"
      , "sToken p t = PT p $ TK t"
      , ""
      , "-- | Get the line number of a token."
      , "line :: Token -> Line"
      , "line = fst . tokenLineCol"
      , ""
      , "-- | Get the column number of a token."
      , "column :: Token -> Column"
      , "column = snd . tokenLineCol"
      , ""
      , "-- | Is the following token on a new line?"
      , "newLine :: Maybe Token -> Token -> Bool"
      , "newLine pt t0 = maybe True ((line t0 >) . line) pt"
      , ""
      , "-- | Check if a word is a layout start token."
      , "isLayout :: Token -> Maybe LayoutDelimiters"
      , "isLayout = \\case"
      , "  PT _ (TK t) -> lookup t layoutWords"
      , "  _ -> Nothing"
      , ""
      , "-- | Check if a token is one of the given symbols."
      , "isTokenIn :: [TokSymbol] -> Token -> Bool"
      , "isTokenIn ts = \\case"
      , "  PT _ (TK t) -> t `elem` ts"
      , "  _ -> False"
      , ""
      , "-- | Check if a token is a layout stop token."
      , "isStop :: Token -> Bool"
      , "isStop = isTokenIn layoutStopWords"
      , ""
      , "-- | Check if a token is the layout open token."
      , "isLayoutOpen :: Token -> Bool"
      , "isLayoutOpen = isTokenIn layoutOpen"
      , ""
      , "-- | Check if a token is the layout separator token."
      , "isLayoutSep :: Token -> Bool"
      , "isLayoutSep = isTokenIn layoutSep"
      , ""
      , "-- | Check if a token is the layout close token."
      , "isLayoutClose :: Token -> Bool"
      , "isLayoutClose = isTokenIn layoutClose"
      , ""
      , "-- | Check if a token is an opening parenthesis."
      , "isParenOpen :: Token -> Bool"
      , "isParenOpen = isTokenIn parenOpen"
      , ""
      , "-- | Check if a token is a closing parenthesis."
      , "isParenClose :: Token -> Bool"
      , "isParenClose = isTokenIn parenClose"
      ]
    ]
    where
    (top0, lay0, stop0) = layoutPragmas cf
    top      = mkTokSymbol =<< top0
    topDelim = fmap (\ sep -> LayoutDelimiters sep Nothing Nothing) top
    lay      = for lay0 $ \ (kw, Delimiters sep open close) ->
      ( fromMaybe undefined $ mkTokSymbol kw
      , LayoutDelimiters (fromMaybe undefined $ mkTokSymbol sep) (mkTokSymbol open) (mkTokSymbol close)
      )
    stop = mapMaybe mkTokSymbol stop0
    mkTokSymbol :: String -> Maybe TokSymbol
    mkTokSymbol x = TokSymbol x <$> lookup x tokens
    tokens = cfTokens cf
    -- Extra parentheses to keep track of (#370).
    parenOpen  = mapMaybe mkTokSymbol [ "(", "[" ]
    parenClose = mapMaybe mkTokSymbol [ ")", "]" ]
  