BNFC-2.5.0: src/formats/haskell2/CFtoLayout.hs
{-
BNF Converter: Layout handling Generator
Copyright (C) 2004 Author: Aarne Ranta
Copyright (C) 2005 Bjorn Bringert
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module CFtoLayout where
import Data.List (sort)
import CF
layoutOpen = "{"
layoutClose = "}"
layoutSep = ";"
cf2Layout :: Bool -> Bool -> String -> String -> CF -> String
cf2Layout alex1 inDir layName lexName cf =
let
(top,lay,stop) = layoutPragmas cf
in unlines $ [
"module " ++ layName ++ " where",
"",
"import " ++ lexName,
if alex1 then "import Alex" else "",
"",
"import Data.Maybe (isNothing, fromJust)",
"",
"-- Generated by the BNF Converter",
"",
"-- local parameters",
"",
"topLayout = " ++ show top,
"layoutWords = " ++ show lay,
"layoutStopWords = " ++ show stop,
"",
"-- layout separators",
"",
"layoutOpen = " ++ show layoutOpen,
"layoutClose = " ++ show layoutClose,
"layoutSep = " ++ show layoutSep,
"",
"-- | Replace layout syntax with explicit layout tokens.",
"resolveLayout :: Bool -- ^ Whether to use top-level layout.",
" -> [Token] -> [Token]",
"resolveLayout tp = res Nothing [if tl then Implicit 1 else Explicit]",
" where",
" -- Do top-level layout if the function parameter and the grammar say so.",
" tl = tp && topLayout",
"",
" res :: Maybe Token -- ^ The previous token, if any.",
" -> [Block] -- ^ A stack of layout blocks.",
" -> [Token] -> [Token]",
"",
" -- The stack should never be empty.",
" res _ [] ts = error $ \"Layout error: stack empty. Tokens: \" ++ show ts",
"",
" 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 = moveAlong (Explicit:st) [t0] ts",
"",
" res _ st (t0:ts)",
" -- Start a new layout block if the first token is a layout word",
" | isLayout t0 =",
" case ts of",
" -- Explicit layout, just move on. The case above",
" -- will push an explicit layout block.",
" t1:_ | isLayoutOpen t1 -> moveAlong st [t0] ts",
" -- at end of file, the start column doesn't matter",
" _ -> let col = if null ts then column t0 else column (head ts)",
" -- insert an open brace after the layout word",
" b:ts' = addToken (nextPos t0) layoutOpen ts",
" -- save the start column",
" st' = Implicit col:st ",
" in moveAlong st' [t0,b] ts'",
"",
" -- If we encounter a closing brace, exit the first explicit layout block.",
" | isLayoutClose t0 = ",
" let st' = drop 1 (dropWhile isImplicit st)",
" in if null st' ",
" then error $ \"Layout error: Found \" ++ layoutClose ++ \" at (\" ",
" ++ show (line t0) ++ \",\" ++ show (column t0) ",
" ++ \") without an explicit layout block.\"",
" else moveAlong st' [t0] ts",
"",
" -- We are in an implicit layout block",
" res pt st@(Implicit n:ns) (t0: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,ns') = span (`moreIndent` column t0) ns",
" moreIndent (Implicit x) y = x > y",
" moreIndent Explicit _ = False",
" -- the number of blocks exited",
" b = 1 + length ebs",
" bs = replicate b layoutClose",
" -- Insert closing braces after the previous token.",
" (ts1,ts2) = splitAt (1+b) $ addTokens (afterPrev pt) bs (t0:ts)",
" in moveAlong ns' ts1 ts2",
"",
" -- End of an implicit layout block",
" | newLine && column t0 < n = ",
" -- Insert a closing brace after the previous token.",
" let b:t0':ts' = addToken (afterPrev pt) layoutClose (t0:ts)",
" -- Repeat, with the current block removed from the stack",
" in moveAlong ns [b] (t0':ts')",
"",
" -- Encounted a new line in an implicit layout block.",
" | newLine && column t0 == n = ",
" -- 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.",
" if isNothing pt || isTokenIn [layoutSep,layoutOpen] (fromJust pt) ",
" then moveAlong st [t0] ts",
" else let b:t0':ts' = addToken (afterPrev pt) layoutSep (t0:ts)",
" in moveAlong st [b,t0'] ts'",
" where newLine = case pt of",
" Nothing -> True",
" Just t -> line t /= line t0",
"",
" -- Nothing to see here, move along.",
" res _ st (t:ts) = moveAlong st [t] ts",
"",
" -- At EOF: skip explicit blocks.",
" res (Just t) (Explicit:bs) [] | null bs = []",
" | otherwise = 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 n] []",
" | isTokenIn [layoutSep] t = []",
" | otherwise = addToken (nextPos t) layoutSep []",
"",
" -- At EOF in an implicit, non-top-level block: close the block",
" res (Just t) (Implicit n:bs) [] =",
" let c = addToken (nextPos t) layoutClose []",
" in moveAlong bs c []",
"",
" -- This should only happen if the input is empty.",
" res Nothing st [] = []",
"",
" -- | Move on to the next token.",
" moveAlong :: [Block] -- ^ The layout stack.",
" -> [Token] -- ^ Any tokens just processed.",
" -> [Token] -- ^ the rest of the tokens.",
" -> [Token]",
" moveAlong st [] ts = error $ \"Layout error: moveAlong got [] as old tokens\"",
" moveAlong st ot ts = ot ++ res (Just $ last ot) st ts",
"",
"data Block = Implicit Int -- ^ An implicit layout block with its start column.",
" | Explicit ",
" deriving Show",
"",
"type Position = Posn",
"",
"-- | Check if s block is implicit.",
"isImplicit :: Block -> Bool",
"isImplicit (Implicit _) = True",
"isImplicit _ = False",
"",
"-- | Insert a number of tokens at the begninning of a list of tokens.",
"addTokens :: Position -- ^ Position of the first new token.",
" -> [String] -- ^ Token symbols.",
" -> [Token] -- ^ The rest of the tokens. These will have their",
" -- positions updated to make room for the new tokens .",
" -> [Token] ",
"addTokens p ss ts = foldr (addToken p) ts ss",
"",
"-- | Insert a new symbol token at the begninning of a list of tokens.",
"addToken :: Position -- ^ Position of the new token.",
" -> String -- ^ Symbol in the new token.",
" -> [Token] -- ^ The rest of the tokens. These will have their",
" -- positions updated to make room for the new token.", " -> [Token]",
"addToken p s ts = sToken p s : map (incrGlobal p (length s)) ts",
"",
"-- | 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 = position t",
" s = tokenLength t",
"",
"-- | Add to the global and column positions of a token.",
"-- The column position is only changed if the token is on",
"-- the same line as the given position.",
"incrGlobal :: Position -- ^ If the token is on the same line",
" -- as this position, update the column position.",
" -> Int -- ^ Number of characters to add to the position.",
" -> Token -> Token",
"incrGlobal (Pn _ l0 _) i (PT (Pn g l c) t) =",
" if l /= l0 then PT (Pn (g + i) l c) t",
" else PT (Pn (g + i) l (c + i)) t",
"incrGlobal _ _ p = error $ \"cannot add token at \" ++ show p",
"",
"-- | Create a symbol token.",
"sToken :: Position -> String -> Token",
"sToken p s = PT p (TS s i)",
" where",
" i = case s of"] ++
[ " " ++ show s ++ " -> " ++ show i
| (s, i) <- zip resws [1..]
] ++
[" _ -> error $ \"not a reserved word: \" ++ show s",
"",
"-- | Get the position of a token.",
"position :: Token -> Position",
"position t = case t of",
" PT p _ -> p",
" Err p -> p",
"",
"-- | Get the line number of a token.",
"line :: Token -> Int",
"line t = case position t of Pn _ l _ -> l",
"",
"-- | Get the column number of a token.",
"column :: Token -> Int",
"column t = case position t of Pn _ _ c -> c",
"",
"-- | Check if a token is one of the given symbols.",
"isTokenIn :: [String] -> Token -> Bool",
"isTokenIn ts t = case t of",
" PT _ (TS r _) | elem r ts -> True",
" _ -> False",
"",
"-- | Check if a word is a layout start token.",
"isLayout :: Token -> Bool",
"isLayout = isTokenIn layoutWords",
"",
"-- | 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 close token.",
"isLayoutClose :: Token -> Bool",
"isLayoutClose = isTokenIn [layoutClose]",
"",
"-- | Get the number of characters in the token.",
"tokenLength :: Token -> Int",
"tokenLength t = length $ prToken t",
""
]
where
resws = sort (reservedWords cf ++ symbols cf)