{- 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, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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 $ concat $ intersperse [""] [ 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 = symbols 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 "$+-*=<>[](){}!?.,;:^~|&%#/\\$_@\"" restOfAlex :: CF -> [String] restOfAlex cf = [ "\"tokens_lx\"/\"tokens_acts\":-", lexComments (comments cf), "<> ::= ^w+", pTSpec (symbols cf,[]), -- modif Markus 12/02 - 2002 userDefTokenTypes, identAndRes, ifC catString " ::= ^\" ([^u # [^\"^\\^n]] | (^\\ (^\" | ^\\ | ^' | n | t)))* ^\"" ++ "%{ string p = PT p . TL . unescapeInitTail %}", ifC catChar " ::= ^\' (^u # [^\'^\\] | ^\\ [^\\ ^\' n t]) ^' %{ char p = PT p . TC %}", ifC catInteger " ::= ^d+ %{ int p = PT p . TI %}", ifC catDouble " ::= ^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 cat s = if isUsedCat cf 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 = " ::= " ++ aux xp ++ "%{ pTSpec p = PT p . TS %}" aux (xs,[]) = " %s " aux ([],ys) = " %r " aux (xs,ys) = " %s | %r " resWs = "[" ++ concat (intersperse "," [show s | s <- resws]) ++ "]" --- show s can be strange for isolatin1 characters --- precompile to search tree! userDefTokenTypes = unlines $ [" ::= " ++ printRegAlex exp ++ "%{ mk_" ++ show name ++ " p = PT p . eitherResIdent T_" ++ show 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 " ::= ^l ^i* %{ ident p = PT p . eitherResIdent TV %}" --ifC "Ident" " ::= ^l ^i* %{ ident p = PT p . eitherResIdent TV %}" resws = reservedWords cf 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 sorted2tree :: [String] -> BTree sorted2tree [] = N sorted2tree xs = B x (sorted2tree t1) (sorted2tree t2) where (t1,(x:t2)) = splitAt (length xs `div` 2) xs