{- 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)