BNFC-2.5.0: src/formats/haskell2/CFtoAlex.hs
{-
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 CFtoAlex (cf2alex) where
import CF
import 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 "String" "<string> ::= ^\" ([^u # [^\"^\\^n]] | (^\\ (^\" | ^\\ | ^' | n | t)))* ^\"" ++
"%{ string p = PT p . TL . unescapeInitTail %}",
ifC "Char" "<char> ::= ^\' (^u # [^\'^\\] | ^\\ [^\\ ^\' n t]) ^' %{ char p = PT p . TC %}",
ifC "Integer" "<int> ::= ^d+ %{ int p = PT p . TI %}",
ifC "Double"
"<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 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 =
"<pTSpec> ::= " ++ 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 $
["<mk_" ++ name ++ "> ::= " ++ printRegAlex exp ++
"%{ mk_" ++ name ++ " p = PT p . eitherResIdent T_" ++ name ++ " %}"
| (name,exp) <- tokenPragmas cf]
userDefTokenConstrs = unlines $
[" | T_" ++ name ++ " String" | (name,_) <- tokenPragmas cf]
userDefTokenPrint = unlines $
[" PT _ (T_" ++ name ++ " s) -> s" | (name,_) <- tokenPragmas 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)
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