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

data Block = Implicit Int
           | Explicit

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, ''Block, 'Implicit, 'Explicit])
      (map mkName ["Token", "Err", "Posn", "PT", "Tok", "TS", "Pn", "Block", "Implicit","Explicit"])
 in fmap mkRename $
     fmap (DataD [] (mkName "Block") [] Nothing [NormalC (mkName "Implicit") [(Bang NoSourceUnpackedness NoSourceStrictness ,ConT ''Int)],
       NormalC (mkName "Explicit") []]
       ([DerivClause Nothing [ConT ''Show]])  :)
       (makedecs top lay stop (sort (reservedWords cf ++ symbols cf)))

-- Hack to make haddock work
makedecs :: Bool -> [String] -> [String] -> [String] -> Q [Dec]
makedecs top lay stop resws = [d|



  topLayout = $(lift top)
  layoutWords = $(lift lay)
  layoutStopWords = $(lift stop)

  layoutOpen  = $(lift layoutOpen')
  layoutClose = $(lift layoutClose')
  layoutSep   = $(lift layoutSep')


  resolveLayout tp = res Nothing [if tl then Implicit 1 else Explicit]
    where
    tl = tp && topLayout
    res _ [] ts = error $ "Layout error: stack empty. Tokens: " ++ show ts

    res _ st (t0:ts)
      | isLayoutOpen t0 = moveAlong (Explicit:st) [t0] ts

    res _ st (t0:ts)
      | isLayout t0 =
          case ts of
              t1:_ | isLayoutOpen t1 -> moveAlong st [t0] ts
              _ -> let col = if null ts then column t0 else column (head ts)
                       b:ts' = addToken (nextPos t0) layoutOpen ts
                       st' = Implicit col:st
                    in moveAlong st' [t0,b] ts'

      | 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

    res pt st@(Implicit n:ns) (t0:ts)

      | isStop t0 =
         let (ebs,ns') = span (`moreIndent` column t0) ns
             moreIndent (Implicit x) y = x > y
             moreIndent Explicit _ = False
             b = 1 + length ebs
             bs = replicate b layoutClose
             (ts1,ts2) = splitAt (1+b) $ addTokens (afterPrev pt) bs (t0:ts)
          in moveAlong ns' ts1 ts2

      | newLine && column t0 < n  =
         let b:t0':ts' = addToken (afterPrev pt) layoutClose (t0:ts)
          in moveAlong ns [b] (t0':ts')

      | newLine && column t0 == n =
         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

    res _ st (t:ts)  = moveAlong st [t] ts

    res (Just t) (Explicit:bs) [] | null bs = []
                                  | otherwise = res (Just t) bs []

    res (Just t) [Implicit n] []
        | isTokenIn [layoutSep] t = []
        | otherwise = addToken (nextPos t) layoutSep []

    res (Just t) (Implicit n:bs) [] =
       let c = addToken (nextPos t) layoutClose []
        in moveAlong bs c []

    res Nothing st [] = []

    moveAlong st [] ts = error $ "Layout error: moveAlong got [] as old tokens"
    moveAlong st ot ts = ot ++ res (Just $ last ot) st ts

  type Position = Posn

  isImplicit :: Block -> Bool
  isImplicit (Implicit _) = True
  isImplicit _ = False

  addTokens :: Position
            -> [String]
            -> [Token]
            -> [Token]
  addTokens p ss ts = foldr (addToken p) ts ss

  addToken :: Position
           -> String
           -> [Token]

         -> [Token]
  addToken p s ts = sToken p s : map (incrGlobal p (length s)) ts

  afterPrev = maybe (Pn 0 1 1) nextPos

  nextPos t = Pn (g + s) l (c + s + 1)
    where Pn g l c = position t
          s = tokenLength t

  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


  reservedwords = $(resnum)

  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)

  position t = case t of
    PT p _ -> p
    Err p -> p

  line t = case position t of Pn _ l _ -> l

  column t = case position t of Pn _ _ c -> c

  isTokenIn ts t = case t of
    PT _ (TS r _) | elem r ts -> True
    _ -> False

  isLayout = isTokenIn layoutWords

  isStop = isTokenIn layoutStopWords

  isLayoutOpen = isTokenIn [layoutOpen]

  isLayoutClose = isTokenIn [layoutClose]

  tokenLength t = length $ $(varE $ mkName "prToken") t

  |]
  where resnum = lift $ zip resws ([1..] :: [Int])