{-
    BNF Converter: Alex 1.1 Generator
    Copyright (C) 2004  Author: Markus Forberg, Aarne Ranta

    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, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1335, USA
-}


module BNFC.Backend.Haskell.CFtoAlex (cf2alex) where

import BNFC.CF
import BNFC.Backend.Haskell.RegToAlex
import Data.List

cf2alex :: String -> String -> CF -> String
cf2alex name errMod cf = unlines $ intercalate [""] [
  prelude name errMod,
  cMacros,
  rMacros cf,
  restOfAlex cf
  ]

prelude :: String -> String -> [String]
prelude name errMod = [
  "-- This Alex file was machine-generated by the BNF converter",
  "%{",
  "module " ++ name ++ " where",
  "",
  "import Alex",
  "import " ++ errMod,
  "%}"
  ]
{- ----
cf2alex :: String -> CF -> String
cf2alex name cf = unlines $ concat $ intersperse [""] [
  prelude name,
  cMacros,
  rMacros cf,
  restOfAlex cf
  ]

prelude :: String -> [String]
prelude name = [
  "-- This Alex file was machine-generated by the BNF converter",
  "%{",
  "module Lex" ++ name ++ " where",
  "",
  "import Alex",
  "import ErrM",
  "%}"
  ]
-}
cMacros :: [String]
cMacros = [
  "{ ^l = [a-zA-Z^192-^255] # [^215 ^247]}    -- isolatin1 letter",
  "{ ^c = [A-Z^192-^221] # [^215]}    -- capital isolatin1 letter",
  "{ ^s = [a-z^222-^255] # [^247]}    -- small isolatin1 letter",
  "{ ^d = [0-9]            }    -- digit",
  "{ ^i = [^l^d^'^_]       }    -- identifier character",
  "{ ^u = [^0-^255]        }    -- universal: any character"
  ]

rMacros :: CF -> [String]
rMacros cf =
  let symbs = cfgSymbols cf
  in
  (if null symbs then [] else [
   "{ %s =    -- reserved words consisting of special symbols",
   "   " ++ unwords (intersperse "|" (map mkEsc symbs)),
   "}"
   ])
 where
  mkEsc = unwords . map ( f . (:[]))
  f s = if all isSpec s then '^':s else s
  isSpec = flip elem ("$+-*=<>[](){}!?.,;:^~|&%#/\\$_@\"" :: String)

restOfAlex :: CF -> [String]
restOfAlex cf = [
  "\"tokens_lx\"/\"tokens_acts\":-",
  lexComments (comments cf),
  "<>         ::= ^w+",
  pTSpec (cfgSymbols cf,[]), -- modif Markus 12/02 - 2002

  userDefTokenTypes,
  identAndRes,

  ifC catString "<string>  ::= ^\" ([^u # [^\"^\\^n]] | (^\\ (^\" | ^\\ | ^' | n | t)))* ^\"" ++
                  "%{ string p = PT p . TL . unescapeInitTail %}",
  ifC catChar   "<char>    ::= ^\' (^u # [^\'^\\] | ^\\ [^\\ ^\' n t]) ^'  %{ char   p = PT p . TC    %}",
  ifC catInteger "<int>    ::= ^d+      %{ int    p = PT p . TI    %}",
  ifC catDouble
      "<double>   ::= ^d+ ^. ^d+ (e (^-)? ^d+)? %{ double  p = PT p . TD %}",
  "",
  "%{ ",
  "",
  "data Tok =",
  "   TS String     -- reserved words",
  " | TL String     -- string literals",
  " | TI String     -- integer literals",
  " | TV String     -- identifiers",
  " | TD String     -- double precision float literals",
  " | TC String     -- character literals",
  userDefTokenConstrs,
  " deriving (Eq,Show)",
  "",
  "data Token = ",
  "   PT  Posn Tok",
  " | Err Posn",
  "  deriving Show",
  "",
  "tokenPos (PT (Pn _ l _) _ :_) = \"line \" ++ show l",
  "tokenPos (Err (Pn _ l _) :_) = \"line \" ++ show l",
  "tokenPos _ = \"end of file\"",
  "",
  "posLineCol (Pn _ l c) = (l,c)",
  "mkPosToken t@(PT p _) = (posLineCol p, prToken t)",
  "",
  "prToken t = case t of",
  "  PT _ (TS s) -> s",
  "  PT _ (TI s) -> s",
  "  PT _ (TV s) -> s",
  "  PT _ (TD s) -> s",
  "  PT _ (TC s) -> s",
  userDefTokenPrint,
  "  _ -> show t",
  "",
  "tokens:: String -> [Token]",
  "tokens inp = scan tokens_scan inp",
  "",
  "tokens_scan:: Scan Token",
  "tokens_scan = load_scan (tokens_acts,stop_act) tokens_lx",
  "        where",
  "        stop_act p \"\"  = []",
  "        stop_act p inp = [Err p]",
  "",
  "eitherResIdent :: (String -> Tok) -> String -> Tok",
  "eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where",
  "  isResWord s = isInTree s $",
  "    " ++ show (sorted2tree $ sort resws),
  "",
  "data BTree = N | B String BTree BTree deriving (Show)",
  "",
  "isInTree :: String -> BTree -> Bool",
  "isInTree x tree = case tree of",
  "  N -> False",
  "  B a left right",
  "   | x < a  -> isInTree x left",
  "   | x > a  -> isInTree x right",
  "   | x == a -> True",
  "",
  "unescapeInitTail :: String -> String",
  "unescapeInitTail = unesc . tail where",
  "  unesc s = case s of",
  "    '\\\\':c:cs | elem c ['\\\"', '\\\\', '\\\''] -> c : unesc cs",
  "    '\\\\':'n':cs  -> '\\n' : unesc cs",
  "    '\\\\':'t':cs  -> '\\t' : unesc cs",
  "    '\"':[]    -> []",
  "    c:cs      -> c : unesc cs",
  "    _         -> []",
  "%}"
  ]
 where
   ifC :: TokenCat -> String -> String
   ifC cat s = if isUsedCat cf (TokenCat cat) then s else ""
   lexComments ([],[])           = []
   lexComments (xs,s1:ys) = "<>         ::= " ++ ('^':intersperse '^' s1) ++ " [.]* ^n\n" ++ lexComments (xs,ys)
   lexComments (([l1,l2],[r1,r2]):xs,[]) = concat
                                        [
                                        "<>         ::= ",
                                        '^':l1:' ':'^':l2:" ([^u # ^",
                                        l2:"] | ^",
                                        r1:" [^u # ^",
                                        r2:"])* (^",
                                        r1:")+ ^",
                                        r2:"\n",
                                        lexComments (xs,[])
                                        ]
   lexComments (_ : xs, []) = lexComments (xs,[])
---   lexComments (xs,(_:ys)) = lexComments (xs,ys)
   pTSpec ([],[]) = ""
   pTSpec xp =
    "<pTSpec>   ::= " ++ aux xp ++ "%{ pTSpec p = PT p . TS    %}"
   aux (_,[]) = " %s "
   aux ([],_) = " %r "
   aux (_,_) = " %s | %r "

   userDefTokenTypes = unlines
     ["<mk_" ++ name ++ "> ::= " ++ printRegAlex exp ++
      "%{ mk_" ++ name ++ " p = PT p . eitherResIdent T_"  ++ name ++ " %}"
                                        | (name,exp) <- tokenPragmas cf]
   userDefTokenConstrs = unlines
     [" | T_" ++ name ++ " String" | name <- tokenNames cf]
   userDefTokenPrint = unlines
     ["  PT _ (T_" ++ name ++ " s) -> s" | name <- tokenNames cf]

   identAndRes = --This has to be there for Reserved Words. Michael
     "<ident>   ::= ^l ^i*   %{ ident  p = PT p . eitherResIdent TV %}"
     --ifC "Ident"  "<ident>   ::= ^l ^i*   %{ ident  p = PT p . eitherResIdent TV %}"

   resws = reservedWords cf

data BTree = N | B String BTree BTree deriving (Show)

sorted2tree :: [String] -> BTree
sorted2tree [] = N
sorted2tree xs = B x (sorted2tree t1) (sorted2tree t2) where
  (t1, x : t2) = splitAt (length xs `div` 2) xs
