BNFC-meta-0.3: Language/LBNF/CFtoLayout.hs
{-#LANGUAGE TemplateHaskell#-}
{-
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 Language.LBNF.CFtoLayout(cf2Layout) where
import Data.List (sort)
import Data.Maybe (isNothing, fromJust)
import Language.LBNF.CF hiding (rename)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
-- TODO: avoid using SYB
import Data.Generics as SYB
-- Generic renaming function
rename :: SYB.Data a => [(Name,Name)] -> a -> a
rename table = everywhere (mkT step)
where
step :: Name -> Name
step x = maybe x id (lookup x table)
-- Dummy data types and functions
data Token =
Err Posn |
PT Posn Tok
data Tok = TS !String Int
data Posn = Pn Int Int Int
layoutOpen' = "{"
layoutClose' = "}"
layoutSep' = ";"
cf2Layout :: CF -> Q [Dec]
cf2Layout cf =
let
(top,lay,stop) = layoutPragmas cf
mkRename = rename $ zip
(id [''Token, 'Err, ''Posn, 'PT, ''Tok, 'TS, 'Pn ])
(map mkName ["Token", "Err", "Posn", "PT", "Tok", "TS", "Pn"])
in fmap mkRename [d|
-- Generated by the BNF Converter
-- local parameters
topLayout = $(lift top)
layoutWords = $(lift lay)
layoutStopWords = $(lift stop)
-- layout separators
layoutOpen = $(lift layoutOpen')
layoutClose = $(lift layoutClose')
layoutSep = $(lift 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]
-> [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.
reservedwords = $(lift $ zip resws ([1..] :: [Int]))
sToken :: Position -> String -> Token
sToken p s = PT p (TS s i)
where i = maybe (error $ "not a reserved word: " ++ show s) id (lookup s reservedwords)
-- where
-- i = case s of
-- [ " " ++ show s ++ " -> " ++ show i
-- | (s, i) <-
-- ] ++
-- _ -> 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 $ $(varE $ mkName "prToken") t
|]
where
resws = sort (reservedWords cf ++ symbols cf)