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