{-# LANGUAGE OverloadedStrings #-} module BNFC.Backend.Haskell.Layout (cf2layout, haskellLayout) where import BNFC.CF import BNFC.Backend.CommonInterface.Backend import BNFC.Backend.Common.Utils as Utils import BNFC.Backend.Haskell.Options import BNFC.Backend.Haskell.State import BNFC.Backend.Haskell.Utilities.Utils import BNFC.Options.GlobalOptions import BNFC.Prelude import Control.Monad.State import qualified Data.Map as Map import Data.List (intersperse) import Data.String (fromString) import Prettyprinter import System.FilePath (takeBaseName) haskellLayout :: LBNF -> State HaskellBackendState Result haskellLayout lbnf = do st <- get let cfName = takeBaseName $ optInput $ globalOpt st inDirectory = inDir $ haskellOpts st nSpace = nameSpace $ haskellOpts st layout = cf2layout lbnf cfName inDirectory nSpace return [(mkFilePath inDirectory nSpace cfName "Layout" "hs", layout)] cf2layout :: LBNF -> String -> Bool -> Maybe String -> String cf2layout lbnf cfName inDir nameSpace = docToString defaultLayoutOptions $ cf2doc lbnf cfName inDir nameSpace cf2doc :: LBNF -> String -> Bool -> Maybe String -> Doc () cf2doc lbnf cfName inDir nameSpace = vsep . intersperse emptyDoc $ [ prologue layoutModule lexModule , restOfLayout lbnf ] where layoutModule = mkModule inDir nameSpace cfName "Layout" lexModule = mkModule inDir nameSpace cfName "Lex" prologue :: ModuleName -> ModuleName -> Doc () prologue layutModule lexModule = vsep [ "{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}" , emptyDoc , "{-# LANGUAGE LambdaCase #-}" , "{-# LANGUAGE PatternGuards #-}" , "{-# LANGUAGE OverloadedStrings #-}" , emptyDoc , "module" <+> fromString layutModule <+> "where" , emptyDoc , "import Prelude" , "import Data.Maybe ( fromMaybe, listToMaybe, mapMaybe )" , "import qualified Data.List as List" , emptyDoc , "import" <+> fromString lexModule , " ( Posn(..), Tok(..), Token(..), TokSymbol(..)" , " , prToken, tokenLineCol, tokenPos, tokenPosn" , " )" ] restOfLayout :: LBNF -> Doc () restOfLayout lbnf = vsep [ "-- local parameters" , emptyDoc , "data LayoutDelimiters" , " = LayoutDelimiters" , " { delimSep :: TokSymbol" , " , delimOpen :: Maybe TokSymbol -- ^ Nothing for toplevel layout." , " , delimClose :: Maybe TokSymbol -- ^ Nothing for toplevel layout." , " }" , emptyDoc , layoutWords , emptyDoc , layoutStop , emptyDoc , "-- layout separators" , emptyDoc , "layoutOpen, layoutClose, layoutSep :: [TokSymbol]" , "layoutOpen = List.nub $ mapMaybe (delimOpen . snd) layoutWords" , "layoutClose = List.nub $ mapMaybe (delimClose . snd) layoutWords" , "layoutSep = List.nub $ TokSymbol \";\"" <+> fromString (show semiColonId) <+> ": map (delimSep . snd) layoutWords" , emptyDoc , "parenOpen, parenClose :: [TokSymbol]" , "parenOpen = [TokSymbol \"(\"" <+> fromString (show lParenId) <> "]" , "parenClose = [TokSymbol \")\"" <+> fromString (show rParenId) <> "]" , emptyDoc , "-- | Replace layout syntax with explicit layout tokens." , "resolveLayout :: Bool -- ^ Whether to use top-level layout." , " -> [Token] -> [Token]" , if isJust top then vsep [ "resolveLayout topLayout =" , " res Nothing [if topLayout then Implicit topDelim Definitive 1 else Explicit]" , " where" , " topDelim :: LayoutDelimiters" , " topDelim = LayoutDelimiters" <+> parens delimiterTokSymbol <+> "Nothing Nothing" ] else vsep [ "resolveLayout _topLayout = res Nothing [Explicit]" , " where" ] , emptyDoc ------------------------------------------- , " res :: Maybe Token -- ^ The previous token, if any." , " -> [Block] -- ^ A stack of layout blocks." , " -> [Token] -> [Token]" , emptyDoc , " -- The stack should never be empty." , " res _ [] ts = error $ \"Layout error: stack empty. Tokens: \" ++ show ts" , emptyDoc , " -- 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" , emptyDoc , " -- 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 error $ unwords" , " [ \"Layout error: Found\", prToken t0, \"at\" , tokenPos [t0]" , " , \"without an explicit layout block.\"" , " ]" , " else map (closingToken (tokenPosn t0)) imps ++ t0 : res (Just t0) st' ts" , emptyDoc , " -- Ending or confirming implicit layout blocks:" , " res pt (b@(Implicit delim status col) : bs) (t0 : ts)" , emptyDoc , " -- 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 (afterPrev pt)) (b : ebs) ++ t0 : res (Just t0) st' ts" , emptyDoc , " -- 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 (afterPrev pt) b" , " = c : res (Just c) bs (t0 : ts)" , emptyDoc , " -- 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)" , emptyDoc , " -- 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" , emptyDoc , " -- Insert separator if necessary." , " | otherwise" , " = maybeInsertSeparator pt t0 st $" , " t0 : res (Just t0) st ts" , emptyDoc , " -- At EOF: skip explicit blocks." , " res (Just _) [Explicit] [] = []" , " res (Just t) (Explicit : bs) [] = res (Just t) bs []" , emptyDoc , " -- 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]" , emptyDoc , " -- 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" , emptyDoc , " -- This should only happen if the input is empty." , " res Nothing _st []" , " = []" , emptyDoc , " -- | 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" , emptyDoc , " closingToken :: Position -> Block -> Token" , " closingToken pos = sToken pos . \\case" , " Implicit (LayoutDelimiters _ _ (Just sy)) _ _ -> sy" , " _ -> error \"Trying to close a top level block.\"" , emptyDoc , "type Position = Posn" , "type Line = Int" , "type Column = Int" , emptyDoc , "-- | Entry of the layout stack." , "data Block" , " = Implicit LayoutDelimiters Status Column" , " -- ^ An implicit layout block with its start column." , " | Explicit" , emptyDoc , "-- | Get current indentation. 0 if we are in an explicit block." , "indentation :: Block -> Column" , "indentation = \\case" , " Implicit _ _ n -> n" , " Explicit -> 0" , emptyDoc , "-- | Check if s block is implicit." , "isImplicit :: Block -> Bool" , "isImplicit = \\case" , " Implicit{} -> True" , " Explicit{} -> False" , emptyDoc , "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." , emptyDoc , "-- | 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." , emptyDoc , " -- | 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" , emptyDoc , " isTentative :: Block -> Bool" , " isTentative = \\case" , " Implicit _ Tentative _ -> True" , " _ -> False" , emptyDoc , "-- | 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" , emptyDoc , "-- | 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" , emptyDoc , "-- | 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" , emptyDoc , "-- | Get the number of characters in the token." , "tokenLength :: Token -> Int" , "tokenLength = length . prToken" , emptyDoc , "-- | Create a position symbol token." , "sToken :: Position -> TokSymbol -> Token" , "sToken p t = PT p $ TK t" , emptyDoc , "-- | Get the line number of a token." , "line :: Token -> Line" , "line = fst . tokenLineCol" , emptyDoc , "-- | Get the column number of a token." , "column :: Token -> Column" , "column = snd . tokenLineCol" , emptyDoc , "-- | Is the following token on a new line?" , "newLine :: Maybe Token -> Token -> Bool" , "newLine pt t0 = maybe True ((line t0 >) . line) pt" , emptyDoc , "-- | Check if a word is a layout start token." , "isLayout :: Token -> Maybe LayoutDelimiters" , "isLayout = \\case" , " PT _ (TK t) -> lookup t layoutWords" , " _ -> Nothing" , emptyDoc , "-- | Check if a token is one of the given symbols." , "isTokenIn :: [TokSymbol] -> Token -> Bool" , "isTokenIn ts = \\case" , " PT _ (TK t) -> t `elem` ts" , " _ -> False" , emptyDoc , "-- | Check if a token is a layout stop token." , "isStop :: Token -> Bool" , "isStop = isTokenIn layoutStopWords" , emptyDoc , "-- | Check if a token is the layout open token." , "isLayoutOpen :: Token -> Bool" , "isLayoutOpen = isTokenIn layoutOpen" , emptyDoc , "-- | Check if a token is the layout separator token." , "isLayoutSep :: Token -> Bool" , "isLayoutSep = isTokenIn layoutSep" , emptyDoc , "-- | Check if a token is the layout close token." , "isLayoutClose :: Token -> Bool" , "isLayoutClose = isTokenIn layoutClose" , emptyDoc , "-- | Check if a token is an opening parenthesis." , "isParenOpen :: Token -> Bool" , "isParenOpen = isTokenIn parenOpen" , emptyDoc , "-- | Check if a token is a closing parenthesis." , "isParenClose :: Token -> Bool" , "isParenClose = isTokenIn parenClose" ] where symbolsAndKeywords = _lbnfSymbolsKeywords lbnf semiColonId = fromJust $ Map.lookup ";" symbolsAndKeywords lBraceId = fromJust $ Map.lookup "{" symbolsAndKeywords rBraceId = fromJust $ Map.lookup "}" symbolsAndKeywords lParenId = fromJust $ Map.lookup "(" symbolsAndKeywords rParenId = fromJust $ Map.lookup ")" symbolsAndKeywords delimiterTokSymbol = printTokSymbol (";", semiColonId) startNames = theKeyword <$> Map.keys (_lbnfLayoutStart lbnf) startIds = snd <$> Map.toList ( Map.filterWithKey (\ k _ -> k `elem` startNames) (_lbnfSymbolsKeywords lbnf) ) startSymbols = zip (toList <$> startNames) startIds stopNames = theKeyword <$> Map.keys (_lbnfLayoutStop lbnf) stopIds = snd <$> Map.toList ( Map.filterWithKey (\ k _ -> k `elem` stopNames) (_lbnfSymbolsKeywords lbnf) ) stopSymbols = zip (toList <$> stopNames) stopIds top = _lbnfLayoutTop lbnf layoutWords :: Doc () layoutWords = vsep [ "layoutWords :: [(TokSymbol, LayoutDelimiters)]" , "layoutWords = [" , indent 2 $ vsep (punctuate comma $ printTuple <$> startSymbols) <+> rbracket ] where printTuple :: (String, Int) -> Doc () printTuple s@(_, _) = vsep [ lparen <+> printTokSymbol s , ", LayoutDelimiters" <+> parens (printTokSymbol (";", semiColonId)) <+> parens ("Just" <+> parens (printTokSymbol ("{", lBraceId))) <+> parens ("Just" <+> parens (printTokSymbol ("}", rBraceId))) , rparen ] layoutStop :: Doc () layoutStop = vsep [ "layoutStopWords :: [TokSymbol]" , "layoutStopWords =" <+> brackets (hsep ( punctuate comma (printTokSymbol <$> stopSymbols))) ] printTokSymbol :: (String, Int) -> Doc () printTokSymbol (tokName, tokId) = "TokSymbol" <+> dquotes (fromString tokName) <+> fromString (show tokId)