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