mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-21 18:59:32 -06:00
removed src for 2.9
This commit is contained in:
aarne
@@ -1,43 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/16 05:40:50 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.4 $
|
||||
--
|
||||
-- (Description of the module)
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module Main (main) where
|
||||
|
||||
import LexGF
|
||||
import Alex
|
||||
import System
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
file1:file2:_ <- getArgs
|
||||
s <- readFile file1
|
||||
ts <- tokens s
|
||||
if file1==file2 then print (length ts) else return () -- make sure file1 is in mem
|
||||
writeFile file2 [] -- create file2 or remove its old contents
|
||||
alphaConv file2 ts (Pn 1 1 1)
|
||||
|
||||
alphaConv :: FilePath -> [Token] -> Posn -> IO ()
|
||||
alphaConv file (t:ts) p0 = case t of
|
||||
PT p (TV s) -> changeId file p0 p s ts
|
||||
_ -> putToken file p0 t >>= alphaConv file ts
|
||||
alphaConv _ _ = putStrLn "Ready."
|
||||
|
||||
putToken :: FilePath -> Posn -> Token -> IO Posn
|
||||
putToken file (Pn _ l0 c0) t@(PT (Pn a l c) _) = do
|
||||
let s = prToken t
|
||||
ns = l - l0
|
||||
ls = length s
|
||||
replicate ns $ appendFile file '\n'
|
||||
replicate (if ns == 0 then c - c0 else c-1) $ putChar ' '
|
||||
putStr s
|
||||
return $ Pn (a + ls) l (c + ls) ts
|
||||
@@ -1,366 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/16 05:40:50 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.7 $
|
||||
--
|
||||
-- produce a HTML document from a list of GF grammar files. AR 6\/10\/2002
|
||||
--
|
||||
-- Added @--!@ (NewPage) and @--*@ (Item) 21\/11\/2003
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module Main (main) where
|
||||
|
||||
|
||||
import Data.Char
|
||||
import Data.List
|
||||
import System.Cmd
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import System.Locale
|
||||
import System.Time
|
||||
|
||||
-- to read files and write a file
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
xx <- getArgs
|
||||
let
|
||||
(typ,format,names) = case xx of
|
||||
"-latex" : xs -> (0,doc2latex,xs)
|
||||
"-htmls" : xs -> (2,doc2html,xs)
|
||||
"-txt" : xs -> (3,doc2txt,xs)
|
||||
"-txt2" : xs -> (3,doc2txt2,xs)
|
||||
"-txthtml": xs -> (4,doc2txt,xs)
|
||||
xs -> (1,doc2html,xs)
|
||||
if null xx
|
||||
then do
|
||||
putStrLn welcome
|
||||
putStrLn help
|
||||
else flip mapM_ names (\name -> do
|
||||
ss <- readFile name
|
||||
time <- modTime name
|
||||
let outfile = fileFormat typ name
|
||||
writeFile outfile $ format $ pDoc time ss)
|
||||
case typ of
|
||||
2 ->
|
||||
mapM_ (\name -> system $ "htmls " ++ (fileFormat typ name)) names
|
||||
4 ->
|
||||
mapM_ (\name ->
|
||||
system $ "txt2tags -thtml --toc " ++ (fileFormat typ name)) names
|
||||
_ -> return ()
|
||||
return ()
|
||||
|
||||
modTime :: FilePath -> IO ModTime
|
||||
modTime name =
|
||||
do
|
||||
t <- getModificationTime name
|
||||
ct <- toCalendarTime t
|
||||
let timeFmt = "%Y-%m-%d %H:%M:%S %Z"
|
||||
return $ formatCalendarTime defaultTimeLocale timeFmt ct
|
||||
|
||||
welcome = unlines [
|
||||
"",
|
||||
"gfdoc - a rudimentary GF document generator.",
|
||||
"(c) Aarne Ranta (aarne@cs.chalmers.se) 2002 under GNU GPL."
|
||||
]
|
||||
|
||||
help = unlines $ [
|
||||
"",
|
||||
"Usage: gfdoc (-latex|-htmls|-txt|-txthtml) <file>+",
|
||||
"",
|
||||
"The program operates with lines in GF code, treating them into LaTeX",
|
||||
"(flag -latex), to a set of HTML documents (flag -htmls), to a txt2tags file",
|
||||
"(flag -txt), to HTML via txt (flag -txthtml), or to one",
|
||||
"HTML file (by default). The output is written in a file",
|
||||
"whose name is formed from the input file name by replacing its suffix",
|
||||
"with html or tex; in case of set of HTML files, the names are prefixed",
|
||||
"by 01-, 02-, etc, and each file has navigation links.",
|
||||
"",
|
||||
"The translation is line by line",
|
||||
"depending as follows on how the line begins",
|
||||
"",
|
||||
" --[Int] heading of level Int",
|
||||
" -- new paragraph",
|
||||
" --! new page (in HTML, recognized by the htmls program)",
|
||||
" --. end of document",
|
||||
--- " --- ignore this comment line in document",
|
||||
--- " {---} ignore this code line in document",
|
||||
" --*[Text] Text paragraph starting with a bullet",
|
||||
" --[Text] Text belongs to text paragraph",
|
||||
" [Text] Text belongs to code paragraph",
|
||||
"",
|
||||
"Within a text paragraph, text enclosed between certain characters",
|
||||
"is treated specially:",
|
||||
"",
|
||||
" *[Text]* emphasized (boldface)",
|
||||
" \"[Text]\" example string (italics)",
|
||||
" $[Text]$ example code (courier)",
|
||||
"",
|
||||
"For other formatting and links, we recommend the txt2tags format."
|
||||
]
|
||||
|
||||
fileFormat typ x = body ++ suff where
|
||||
body = reverse $ dropWhile (/='.') $ reverse x
|
||||
suff = case typ of
|
||||
0 -> "tex"
|
||||
_ | typ < 3 -> "html"
|
||||
_ -> "txt"
|
||||
|
||||
-- the document datatype
|
||||
|
||||
data Doc = Doc Title ModTime [Paragraph]
|
||||
|
||||
type ModTime = String
|
||||
|
||||
type Title = [TextItem]
|
||||
|
||||
data Paragraph =
|
||||
Text [TextItem] -- text line starting with --
|
||||
| List [[TextItem]] --
|
||||
| Code String -- other text line
|
||||
| Item [TextItem] -- bulleted item: line prefixed by --*
|
||||
| New -- new paragraph: line consisting of --
|
||||
| NewPage -- new parage: line consisting of --!
|
||||
| Heading Int [TextItem] -- text line starting with --n where n = 1,2,3,4
|
||||
|
||||
data TextItem =
|
||||
Str String
|
||||
| Emp String -- emphasized, *...*
|
||||
| Lit String -- string literal, "..."
|
||||
| Inl String -- inlined code, '...'
|
||||
|
||||
|
||||
-- parse document
|
||||
|
||||
pDoc :: ModTime -> String -> Doc
|
||||
pDoc time s = case dropWhile emptyOrPragma (lines s) of
|
||||
('-':'-':'1':title) : paras -> Doc (pItems title) time (map pPara (grp paras))
|
||||
paras -> Doc [] time (map pPara (grp paras))
|
||||
where
|
||||
grp ss = case ss of
|
||||
s : rest --- | ignore s -> grp rest
|
||||
| isEnd s -> []
|
||||
| begComment s -> let (s1,s2) = getComment (drop 2 s : rest)
|
||||
in map ("-- " ++) s1 ++ grp s2
|
||||
| isComment s -> s : grp rest
|
||||
| all isSpace s -> grp rest
|
||||
[] -> []
|
||||
_ -> unlines code : grp rest where (code,rest) = span (not . isComment) ss
|
||||
pPara s = case s of
|
||||
'-':'-':d:text | isDigit d -> Heading (read [d]) (pItems text)
|
||||
'-':'-':'!':[] -> NewPage
|
||||
'-':'-':[] -> New
|
||||
'-':'-':'*':text -> Item (pItems (dropWhile isSpace text))
|
||||
'-':'-':text -> Text (pItems (dropWhile isSpace text))
|
||||
_ -> Code s
|
||||
pItems s = case s of
|
||||
'*' : cs -> get 1 Emp (=='*') cs
|
||||
'"' : cs -> get 1 Lit (=='"') cs
|
||||
'$' : cs -> get 1 Inl (=='$') cs
|
||||
[] -> []
|
||||
_ -> get 0 Str (flip elem "*\"$") s
|
||||
|
||||
get _ _ _ [] = []
|
||||
get k con isEnd cs = con beg : pItems (drop k rest)
|
||||
where (beg,rest) = span (not . isEnd) cs
|
||||
|
||||
ignore s = case s of
|
||||
'-':'-':'-':_ -> True
|
||||
'{':'-':'-':'-':'}':_ -> True
|
||||
_ -> False
|
||||
|
||||
isEnd s = case s of
|
||||
'-':'-':'.':_ -> True
|
||||
_ -> False
|
||||
|
||||
emptyOrPragma s = all isSpace s || "--#" `isPrefixOf` s
|
||||
|
||||
-- render in html
|
||||
|
||||
doc2html :: Doc -> String
|
||||
doc2html (Doc title time paras) = unlines $
|
||||
tagXML "html" $
|
||||
tagXML "body" $
|
||||
unwords (tagXML "i" ["Produced by " ++ welcome]) :
|
||||
mkTagXML "p" :
|
||||
concat (tagXML "h1" [concat (map item2html title)]) :
|
||||
empty :
|
||||
map para2html paras
|
||||
|
||||
para2html :: Paragraph -> String
|
||||
para2html p = case p of
|
||||
Text its -> concat (map item2html its)
|
||||
Item its -> mkTagXML "li" ++ concat (map item2html its)
|
||||
Code s -> unlines $ tagXML "pre" $ map (indent 2) $
|
||||
remEmptyLines $ lines $ spec s
|
||||
New -> mkTagXML "p"
|
||||
NewPage -> mkTagXML "p" ++ "\n" ++ mkTagXML "!-- NEW --"
|
||||
Heading i its -> concat $ tagXML ('h':show i) [concat (map item2html its)]
|
||||
|
||||
item2html :: TextItem -> String
|
||||
item2html i = case i of
|
||||
Str s -> spec s
|
||||
Emp s -> concat $ tagXML "b" [spec s]
|
||||
Lit s -> concat $ tagXML "i" [spec s]
|
||||
Inl s -> concat $ tagXML "tt" [spec s]
|
||||
|
||||
mkTagXML t = '<':t ++ ">"
|
||||
mkEndTagXML t = mkTagXML ('/':t)
|
||||
tagXML t ss = mkTagXML t : ss ++ [mkEndTagXML t]
|
||||
|
||||
spec = elimLt
|
||||
|
||||
elimLt s = case s of
|
||||
'<':cs -> "<" ++ elimLt cs
|
||||
c :cs -> c : elimLt cs
|
||||
_ -> s
|
||||
|
||||
|
||||
-- render in latex
|
||||
|
||||
doc2latex :: Doc -> String
|
||||
doc2latex (Doc title time paras) = unlines $
|
||||
preludeLatex :
|
||||
funLatex "title" [concat (map item2latex title)] :
|
||||
funLatex "author" [fontLatex "footnotesize" (welcome)] :
|
||||
envLatex "document" (
|
||||
funLatex "maketitle" [] :
|
||||
map para2latex paras)
|
||||
|
||||
para2latex :: Paragraph -> String
|
||||
para2latex p = case p of
|
||||
Text its -> concat (map item2latex its)
|
||||
Item its -> "\n\n$\\bullet$" ++ concat (map item2latex its) ++ "\n\n"
|
||||
Code s -> unlines $ envLatex "verbatim" $ map (indent 2) $
|
||||
remEmptyLines $ lines $ s
|
||||
New -> "\n"
|
||||
NewPage -> "\\newpage"
|
||||
Heading i its -> headingLatex i (concat (map item2latex its))
|
||||
|
||||
item2latex :: TextItem -> String
|
||||
item2latex i = case i of
|
||||
Str s -> specl s
|
||||
Emp s -> fontLatex "bf" (specl s)
|
||||
Lit s -> fontLatex "it" (specl s)
|
||||
Inl s -> fontLatex "tt" (specl s)
|
||||
|
||||
funLatex :: String -> [String] -> String
|
||||
funLatex f xs = "\\" ++ f ++ concat ["{" ++ x ++ "}" | x <- xs]
|
||||
|
||||
envLatex :: String -> [String] -> [String]
|
||||
envLatex e ss =
|
||||
funLatex "begin" [e] :
|
||||
ss ++
|
||||
[funLatex "end" [e]]
|
||||
|
||||
headingLatex :: Int -> String -> String
|
||||
-- for slides
|
||||
-- headingLatex _ s = funLatex "newone" [] ++ "\n" ++ funLatex "heading" [s]
|
||||
headingLatex i s = funLatex t [s] where
|
||||
t = case i of
|
||||
2 -> "section"
|
||||
3 -> "subsection"
|
||||
_ -> "subsubsection"
|
||||
|
||||
fontLatex :: String -> String -> String
|
||||
fontLatex f s = "{\\" ++ f ++ " " ++ s ++ "}"
|
||||
|
||||
specl = eliml
|
||||
|
||||
eliml s = case s of
|
||||
'|':cs -> mmath "mid" ++ elimLt cs
|
||||
'{':cs -> mmath "\\{" ++ elimLt cs
|
||||
'}':cs -> mmath "\\}" ++ elimLt cs
|
||||
_ -> s
|
||||
|
||||
mmath s = funLatex "mbox" ["$" ++ s ++ "$"]
|
||||
|
||||
preludeLatex = unlines $ [
|
||||
"\\documentclass[12pt]{article}",
|
||||
"\\usepackage{isolatin1}",
|
||||
"\\setlength{\\oddsidemargin}{0mm}",
|
||||
"\\setlength{\\evensidemargin}{-2mm}",
|
||||
"\\setlength{\\topmargin}{-16mm}",
|
||||
"\\setlength{\\textheight}{240mm}",
|
||||
"\\setlength{\\textwidth}{158mm}",
|
||||
"\\setlength{\\parskip}{2mm}",
|
||||
"\\setlength{\\parindent}{0mm}"
|
||||
]
|
||||
|
||||
-- render in txt2tags
|
||||
-- as main document (welcome, top-level subtitles)
|
||||
-- as chapter (no welcome, subtitle level + i)
|
||||
|
||||
doc2txt :: Doc -> String
|
||||
doc2txt (Doc title time paras) = unlines $
|
||||
let tit = concat (map item2txt title) in
|
||||
tit:
|
||||
("Last update: " ++ time):
|
||||
"":
|
||||
"% NOTE: this is a txt2tags file.":
|
||||
"% Create an html file from this file using:":
|
||||
("% txt2tags " ++ tit):
|
||||
"\n":
|
||||
concat (["Produced by " ++ welcome]) :
|
||||
"\n" :
|
||||
empty :
|
||||
map (para2txt 0) paras
|
||||
|
||||
doc2txt2 :: Doc -> String
|
||||
doc2txt2 (Doc title time paras) = unlines $
|
||||
let tit = concat (map item2txt title) in
|
||||
tit:
|
||||
"":
|
||||
concat (tagTxt (replicate 2 '=') [tit]):
|
||||
"\n":
|
||||
empty :
|
||||
map (para2txt 2) paras
|
||||
|
||||
para2txt :: Int -> Paragraph -> String
|
||||
para2txt j p = case p of
|
||||
Text its -> concat (map item2txt its)
|
||||
Item its -> "- " ++ concat (map item2txt its)
|
||||
Code s -> unlines $ tagTxt "```" $ map (indent 2) $
|
||||
remEmptyLines $ lines s
|
||||
New -> "\n"
|
||||
NewPage -> "\n" ++ "!-- NEW --"
|
||||
Heading i its ->
|
||||
concat $ tagTxt (replicate (i + j) '=') [concat (map item2txt its)]
|
||||
|
||||
item2txt :: TextItem -> String
|
||||
item2txt i = case i of
|
||||
Str s -> s
|
||||
Emp s -> concat $ tagTxt "**" [spec s]
|
||||
Lit s -> concat $ tagTxt "//" [spec s]
|
||||
Inl s -> concat $ tagTxt "``" [spec s]
|
||||
|
||||
tagTxt t ss = t : ss ++ [t]
|
||||
|
||||
|
||||
|
||||
-- auxiliaries
|
||||
|
||||
empty = ""
|
||||
|
||||
isComment = (== "--") . take 2
|
||||
|
||||
begComment = (== "{-") . take 2
|
||||
|
||||
getComment ss = case ss of
|
||||
"-}":ls -> ([],ls)
|
||||
l:ls -> (l : s1, s2) where (s1,s2) = getComment ls
|
||||
_ -> ([],[])
|
||||
|
||||
indent n = (replicate n ' ' ++)
|
||||
|
||||
remEmptyLines = rem False where
|
||||
rem prevGood ls = case span empty ls of
|
||||
(_ :_, ss@(_ : _)) -> (if prevGood then ("":) else id) $ rem False ss
|
||||
(_, []) -> []
|
||||
(_, s:ss) -> s : rem True ss
|
||||
empty = all isSpace
|
||||
@@ -1,102 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/05/16 17:07:18 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.11 $
|
||||
--
|
||||
-- chop an HTML file into separate files, each linked to the next and previous.
|
||||
-- the names of the files are n-file, with n = 01,02,...
|
||||
-- the chopping is performed at each separator, here defined as @\<!-- NEW --\>@
|
||||
--
|
||||
-- AR 7\/1\/2002 for the Vinnova meeting in Linköping.
|
||||
-- Added table of contents generation in file 00, 16/4/2005
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module Main (main) where
|
||||
|
||||
import System
|
||||
import Char
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
file:_ <- getArgs
|
||||
htmls file
|
||||
|
||||
htmls :: FilePath -> IO ()
|
||||
htmls file = do
|
||||
s <- readFile file
|
||||
let ss = allPages file s
|
||||
lg = length ss
|
||||
putStrLn $ show lg ++ " slides"
|
||||
mapM_ (uncurry writeFile . mkFile file lg) ss
|
||||
|
||||
allPages :: FilePath -> String -> [(Int,String)]
|
||||
allPages file s = addIndex $ zip [1..] $ map unlines $ chop lss where
|
||||
chop ls = case span isNoSep ls of
|
||||
(s,_:ss) -> s : chop ss
|
||||
_ -> [ls]
|
||||
isNoSep = (/= separator)
|
||||
addIndex = ((0,mkIndex file lss) :)
|
||||
lss = lines s
|
||||
|
||||
mkFile :: FilePath -> Int -> (Int,String) -> (FilePath,String)
|
||||
mkFile base mx (number,content) =
|
||||
(fileName base number,
|
||||
unlines [
|
||||
begHTML,
|
||||
"<font size=1>",
|
||||
pageNum mx number,
|
||||
link base mx number,
|
||||
"</font>",
|
||||
"<p>",
|
||||
content,
|
||||
endHTML
|
||||
]
|
||||
)
|
||||
|
||||
begHTML, endHTML, separator :: String
|
||||
begHTML = "<html><body bgcolor=\"#FFFFFF\" text=\"#000000\">"
|
||||
endHTML = "</body></html>"
|
||||
separator = "<!-- NEW -->"
|
||||
|
||||
link :: FilePath -> Int -> Int -> String
|
||||
link file mx n =
|
||||
(if n >= mx-1 then "" else (" <a href=\"" ++ file' ++ "\">Next</a>")) ++
|
||||
(if n == 1 then "" else (" <a href=\"" ++ file_ ++ "\">Previous</a>")) ++
|
||||
(" <a href=\"" ++ file0 ++ "\">Contents</a>") ++
|
||||
(" <a href=\"" ++ file ++ "\">Fulltext</a>") ++
|
||||
(" <a href=\"" ++ file1 ++ "\">First</a>") ++
|
||||
(" <a href=\"" ++ file2 ++ "\">Last</a>")
|
||||
where
|
||||
file_ = fileName file (n - 1)
|
||||
file' = fileName file (n + 1)
|
||||
file0 = fileName file 0
|
||||
file1 = fileName file 1
|
||||
file2 = fileName file (mx - 1)
|
||||
|
||||
fileName :: FilePath -> Int -> FilePath
|
||||
fileName file n = (if n < 10 then ('0':) else id) $ show n ++ "-" ++ file
|
||||
|
||||
pageNum mx num = "<p align=right>" ++ show num ++"/" ++ show (mx-1) ++ "</p>"
|
||||
|
||||
mkIndex file = unlines . mkInd 1 where
|
||||
mkInd n ss = case ss of
|
||||
s : rest | (s==separator) -> mkInd (n+1) rest
|
||||
s : rest -> case getHeading s of
|
||||
Just (i,t) -> mkLine n i t : mkInd n rest
|
||||
_ -> mkInd n rest
|
||||
_ -> []
|
||||
getHeading s = case dropWhile isSpace s of
|
||||
'<':h:i:_:t | isDigit i -> return (i,take (length t - 5) t) -- drop final </hi>
|
||||
_ -> Nothing
|
||||
mkLine _ '1' t = t ++ " : Table of Contents<p>" -- heading of whole document
|
||||
mkLine n i t = stars i ++ link n t ++ "<br>"
|
||||
stars i = case i of
|
||||
'3' -> "<li> "
|
||||
'4' -> "<li>* "
|
||||
_ -> ""
|
||||
link n t = "<a href=\"" ++ fileName file n ++ "\">" ++ t ++ "</a>"
|
||||
@@ -1,61 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/05/12 10:03:34 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.9 $
|
||||
--
|
||||
-- Compile @HelpFile.hs@ from the text file @HelpFile@.
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module Main (main) where
|
||||
|
||||
main = do
|
||||
s <- readFile "HelpFile"
|
||||
let s' = mkHsFile (lines s)
|
||||
writeFile "GF/Shell/HelpFile.hs" s'
|
||||
|
||||
mkHsFile ss =
|
||||
helpHeader ++
|
||||
"module GF.Shell.HelpFile where\n\n" ++
|
||||
"import GF.Data.Operations\n\n" ++
|
||||
"txtHelpFileSummary =\n" ++
|
||||
" unlines $ map (concat . take 1 . lines) $ paragraphs txtHelpFile\n\n" ++
|
||||
"txtHelpCommand c =\n" ++
|
||||
" case lookup c [(takeWhile (/=',') p,p) | p <- paragraphs txtHelpFile] of\n" ++
|
||||
" Just s -> s\n" ++
|
||||
" _ -> \"Command not found.\"\n\n" ++
|
||||
"txtHelpFile =\n" ++
|
||||
unlines (map mkOne ss) ++
|
||||
" []"
|
||||
|
||||
mkOne s = " \"" ++ pref s ++ (escs s) ++ "\" ++"
|
||||
where
|
||||
pref (' ':_) = "\\n"
|
||||
pref _ = "\\n" ---
|
||||
escs [] = []
|
||||
escs (c:cs) | elem c "\"\\" = '\\':c:escs cs
|
||||
| fromEnum c > 127 = "\\" ++show (fromEnum c)++escs cs
|
||||
escs (c:cs) = c:escs cs
|
||||
|
||||
helpHeader = unlines [
|
||||
"----------------------------------------------------------------------",
|
||||
"-- |",
|
||||
"-- Module : GF.Shell.HelpFile",
|
||||
"-- Maintainer : Aarne Ranta",
|
||||
"-- Stability : (stable)",
|
||||
"-- Portability : (portable)",
|
||||
"--",
|
||||
"-- > CVS $Date: 2005/05/12 10:03:34 $",
|
||||
"-- > CVS $Author: aarne $",
|
||||
"-- > CVS $Revision: 1.9 $",
|
||||
"--",
|
||||
"-- Help on shell commands. Generated from HelpFile by 'make help'.",
|
||||
"-- PLEASE DON'T EDIT THIS FILE.",
|
||||
"-----------------------------------------------------------------------------",
|
||||
"",
|
||||
""
|
||||
]
|
||||
@@ -1,70 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/16 05:40:51 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.4 $
|
||||
--
|
||||
-- (Description of the module)
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module Main (main) where
|
||||
import Fudgets
|
||||
import System
|
||||
|
||||
import Operations
|
||||
|
||||
import Greek (mkGreek)
|
||||
import Arabic (mkArabic)
|
||||
import Hebrew (mkHebrew)
|
||||
import Russian (mkRussian)
|
||||
|
||||
-- AR 12/4/2000
|
||||
|
||||
main = do
|
||||
xx <- getArgs
|
||||
(case xx of
|
||||
"HELP" : _ -> putStrLn usageWriteF
|
||||
"FILE" : file : _ -> do
|
||||
str <- readFileIf file
|
||||
fudlogueWrite (Just str)
|
||||
w:_ -> fudlogueWrite (Just (unwords xx))
|
||||
_ -> fudlogueWrite Nothing)
|
||||
|
||||
usageWriteF =
|
||||
"Usage: WriteF [-H20Mg -A5M] [FILE <filename> | <inputstring> | HELP]" ++++
|
||||
"Without arguments, an interactive display is opened." ++++
|
||||
"Prefix your string with / for Greek, - for Arabic, + for Hebrew, _ for Russian."
|
||||
|
||||
fudlogueWrite mbstr =
|
||||
fudlogue $
|
||||
shellF "Unicode Output" (writeF mbstr >+< quitButtonF)
|
||||
|
||||
writeF Nothing = writeOutputF >==< writeInputF
|
||||
writeF (Just str) = startupF [str] writeOutputF
|
||||
|
||||
displaySizeP = placerF (spacerP (sizeS (Point 440 500)) verticalP)
|
||||
|
||||
writeOutputF =
|
||||
displaySizeP (moreF' (setFont myFont))
|
||||
--- displaySizeP (scrollF (displayF' (setFont myFont)))
|
||||
--- >=^<
|
||||
--- vboxD' 0 . map g
|
||||
>==<
|
||||
mapF (map mkUnicode . lines)
|
||||
|
||||
writeInputF = stringInputF' (setShowString mkUnicode . setFont myFont)
|
||||
|
||||
mkUnicode s = case s of
|
||||
'/':cs -> mkGreek cs
|
||||
'+':cs -> mkHebrew cs
|
||||
'-':cs -> mkArabic cs
|
||||
'_':cs -> mkRussian cs
|
||||
_ -> s
|
||||
|
||||
myFont = "-mutt-clearlyu-medium-r-normal--17-120-100-100-p-101-iso10646-1"
|
||||
--- myFont = "-arabic-newspaper-medium-r-normal--32-246-100-100-p-137-iso10646-1"
|
||||
--- myFont = "-misc-fixed-medium-r-semicondensed--13-120-75-75-c-60-iso10646-1"
|
||||
@@ -1,21 +0,0 @@
|
||||
Aarne Ranta 21/9/2006
|
||||
|
||||
Interpreter for ready-made translation lists. Supports
|
||||
translation, random generation, and translation quiz.
|
||||
|
||||
To compile:
|
||||
|
||||
g++ -o gfex gfex.cpp
|
||||
|
||||
To use:
|
||||
|
||||
./gfex peace.gft
|
||||
|
||||
To produce a gft file in GF:
|
||||
|
||||
gt | tb -unlexer=unwords -compact | wf foo.gft
|
||||
|
||||
The format uses encoding of words as integers, which
|
||||
gives a memory-efficient run-time program. Also the
|
||||
treebank file size is about 1/3 of sentences stored
|
||||
in words.
|
||||
@@ -1,20 +0,0 @@
|
||||
14 3 4 2
|
||||
English Swedish German
|
||||
|
||||
I Sie du ich ihr jag ni schlafe schlafen schlafst schlaft sleep sover you
|
||||
|
||||
1 12
|
||||
14 12
|
||||
14 12
|
||||
14 12
|
||||
|
||||
6 13
|
||||
3 13
|
||||
7 13
|
||||
7 13
|
||||
|
||||
4 8
|
||||
3 10
|
||||
5 11
|
||||
2 9
|
||||
|
||||
@@ -1,340 +0,0 @@
|
||||
#include <algorithm>
|
||||
#include <cctype>
|
||||
#include <cstdlib>
|
||||
#include <fstream>
|
||||
#include <iomanip>
|
||||
#include <ios>
|
||||
#include <iostream>
|
||||
#include <iterator>
|
||||
#include <map>
|
||||
#include <set>
|
||||
#include <stdexcept>
|
||||
#include <string>
|
||||
#include <vector>
|
||||
#include <list>
|
||||
#include <time.h>
|
||||
#include <stdio.h>
|
||||
|
||||
using std::cin ;
|
||||
using std::cout ;
|
||||
using std::endl ;
|
||||
using std::equal ;
|
||||
using std::find_if ;
|
||||
using std::getline ;
|
||||
using std::istream ;
|
||||
using std::logic_error ;
|
||||
using std::map ;
|
||||
using std::max ;
|
||||
using std::multimap ;
|
||||
using std::rand ;
|
||||
using std::set ;
|
||||
using std::setw ;
|
||||
using std::sort ;
|
||||
using std::streamsize ;
|
||||
using std::string ;
|
||||
using std::vector ;
|
||||
using std::list ;
|
||||
|
||||
|
||||
typedef vector<string> Wordlist ;
|
||||
typedef map<string,int> Lexicon ;
|
||||
typedef vector<int> Sentence ;
|
||||
typedef int Tree ;
|
||||
typedef vector<Sentence> Linearizer ;
|
||||
typedef map<Sentence,vector<Tree> > Parser ;
|
||||
|
||||
// interpreter of compact translation lists, generated in GF by
|
||||
// tb -compact. AR 22/9/2006
|
||||
|
||||
// map words to indices
|
||||
Sentence getSentence(Lexicon& lexicon, const vector<string>& ws, int mx)
|
||||
{
|
||||
|
||||
Sentence sent ;
|
||||
int wc = 0 ;
|
||||
for (vector<string>::const_iterator i = ws.begin() ; i != ws.end() ; ++i) {
|
||||
sent.push_back(lexicon[*i]) ;
|
||||
++ wc ;
|
||||
}
|
||||
for (int i = wc ; i != mx ; ++i) sent.push_back(0) ;
|
||||
|
||||
//debug
|
||||
// for (Sentence::const_iterator i = sent.begin() ; i != sent.end() ; ++i)
|
||||
// cout << *i << " " ;
|
||||
cout << endl ;
|
||||
|
||||
return sent ;
|
||||
}
|
||||
|
||||
// render a sentence in words
|
||||
void putSentence(const Wordlist& wlist, const Sentence sent)
|
||||
{
|
||||
for (Sentence::const_iterator i = sent.begin() ; i != sent.end() ; ++i) {
|
||||
if (*i != 0)
|
||||
cout << wlist[*i-1] << " " ;
|
||||
}
|
||||
cout << endl ;
|
||||
|
||||
}
|
||||
|
||||
|
||||
// Haskell words
|
||||
bool space(char c)
|
||||
{
|
||||
return isspace(c) ;
|
||||
}
|
||||
bool not_space(char c)
|
||||
{
|
||||
return !space(c) ;
|
||||
}
|
||||
|
||||
vector<string> words(const string& s)
|
||||
{
|
||||
typedef string::const_iterator iter ;
|
||||
vector<string> ws ;
|
||||
iter i = s.begin() ;
|
||||
while (i != s.end()) {
|
||||
// ignore space
|
||||
i = find_if(i, s.end(), not_space) ;
|
||||
// collect characters until space
|
||||
iter j = find_if(i, s.end(), space) ;
|
||||
|
||||
// add the string to the vector
|
||||
if (i != s.end())
|
||||
ws.push_back(string(i,j)) ;
|
||||
i = j ;
|
||||
}
|
||||
return ws ;
|
||||
}
|
||||
|
||||
|
||||
// the run-time grammar structure
|
||||
struct Grammar {
|
||||
vector<string> langnames ;
|
||||
int nwords ;
|
||||
int nlangs ;
|
||||
int nsents ;
|
||||
int smaxlen ;
|
||||
Wordlist wlist ;
|
||||
Lexicon lexicon ;
|
||||
vector<Linearizer> lin ;
|
||||
vector<Parser> parser ;
|
||||
} ;
|
||||
|
||||
|
||||
// read grammar from file or stdio
|
||||
Grammar readGrammar (istream& in)
|
||||
{
|
||||
Grammar g ;
|
||||
|
||||
in >> g.nwords >> g.nlangs >> g.nsents >> g.smaxlen ;
|
||||
|
||||
string tok ;
|
||||
|
||||
for (int ls = 0 ; ls != g.nlangs ; ++ls) {
|
||||
in >> tok ;
|
||||
g.langnames.push_back(tok) ;
|
||||
}
|
||||
|
||||
for (int ls = 0 ; ls != g.nwords ; ++ls) {
|
||||
in >> tok ;
|
||||
g.lexicon[tok] = ls + 1 ;
|
||||
g.wlist.push_back(tok) ;
|
||||
}
|
||||
|
||||
g.lin = vector<Linearizer>(g.nlangs) ;
|
||||
g.parser = vector<Parser>(g.nlangs) ;
|
||||
|
||||
int w ;
|
||||
Sentence temp ;
|
||||
|
||||
for (int ls = 0 ; ls != g.nlangs ; ++ls) {
|
||||
for (int ss = 0 ; ss != g.nsents ; ++ss) {
|
||||
temp = vector<int>() ;
|
||||
for (int ws = 0 ; ws != g.smaxlen ; ++ws) {
|
||||
|
||||
in >> w ;
|
||||
temp.push_back(w) ;
|
||||
}
|
||||
|
||||
g.lin[ls].push_back(temp) ;
|
||||
g.parser[ls][temp].push_back(ss) ;
|
||||
}
|
||||
}
|
||||
|
||||
cout << "Grammar ready with languages " ;
|
||||
for (int i = 0 ; i != g.nlangs ; ++i) cout << g.langnames[i] << " " ;
|
||||
cout << endl << endl ;
|
||||
|
||||
return g ;
|
||||
}
|
||||
|
||||
// translate string from any language to all other languages
|
||||
void translate (Grammar& g, const string input)
|
||||
{
|
||||
Sentence s ; // source
|
||||
|
||||
s = getSentence(g.lexicon,words(input),g.smaxlen) ;
|
||||
|
||||
Sentence t ; // target
|
||||
|
||||
for (int k = 0 ; k != g.nlangs ; ++k) {
|
||||
if (!g.parser[k][s].empty()) {
|
||||
for (int m = 0 ; m != g.nlangs ; ++m) {
|
||||
if (m != k) cout << "** " << g.langnames[m] << ":" << endl ;
|
||||
for (vector<Tree>::const_iterator i = g.parser[k][s].begin() ;
|
||||
i != g.parser[k][s].end() ; ++i){
|
||||
if (m != k) cout << "tree #" << *i << ": " ; // debug
|
||||
if (m != k) putSentence (g.wlist, g.lin[m][*i]) ;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
// balanced random generator
|
||||
inline int nrand(int n)
|
||||
{
|
||||
/// if (n <= 0 || n > RAND_MAX)
|
||||
const int bucket_size = RAND_MAX / n ;
|
||||
int r ;
|
||||
|
||||
// randomness from clock
|
||||
srand(time(NULL)) ;
|
||||
do r = (rand() + clock())/ bucket_size ;
|
||||
while (r >= n) ;
|
||||
|
||||
return r ;
|
||||
|
||||
}
|
||||
|
||||
// generate random sentence and show it in all languages
|
||||
void genRandom (const Grammar& g)
|
||||
{
|
||||
Tree t = nrand(g.nsents) ;
|
||||
|
||||
for (int k = 0 ; k != g.nlangs ; ++k) {
|
||||
cout << "** " << g.langnames[k] << ":" << endl ;
|
||||
putSentence (g.wlist, g.lin[k][t]) ;
|
||||
}
|
||||
}
|
||||
|
||||
// quiz of ten translation examples
|
||||
void quiz (Grammar& g, int src, int trg)
|
||||
{
|
||||
int score = 0 ;
|
||||
|
||||
for (int q = 0 ; q != 10 ; ++q) {
|
||||
Tree t = nrand(g.nsents) ;
|
||||
Sentence question = g.lin[src][t] ;
|
||||
putSentence (g.wlist, question) ;
|
||||
cout << "Translation:" << endl ;
|
||||
cout.flush() ;
|
||||
string answer ;
|
||||
/// if (q == 0) {string foo ; cin >> foo ; cin.clear() ;} ;
|
||||
getline (cin, answer) ;
|
||||
Sentence s = getSentence(g.lexicon,words(answer),g.smaxlen) ;
|
||||
|
||||
bool result = false ;
|
||||
vector<Sentence> corrects ;
|
||||
for (vector<Tree>::const_iterator i = g.parser[src][question].begin() ;
|
||||
i != g.parser[src][question].end() ; ++i){
|
||||
if (equal(s.begin(), s.end(), g.lin[trg][*i].begin())){
|
||||
result = true ;
|
||||
break ;
|
||||
} else {
|
||||
corrects.push_back(g.lin[trg][*i]) ;
|
||||
}
|
||||
}
|
||||
if (result) {
|
||||
++ score ;
|
||||
cout << "Correct." << endl ;
|
||||
} else {
|
||||
cout << "Incorrect. Correct answers are:" << endl ;
|
||||
for (int c = 0 ; c != corrects.size() ; ++c)
|
||||
putSentence(g.wlist, corrects[c]) ;
|
||||
}
|
||||
cout << "Score: " << score << "/" << q+1 << endl << endl ;
|
||||
}
|
||||
}
|
||||
|
||||
// generate all sentences in one language
|
||||
void genAll(const Grammar& g, int lang)
|
||||
{
|
||||
for (int i = 0 ; i != g.nsents ; ++i)
|
||||
putSentence(g.wlist, g.lin[lang][i]) ;
|
||||
}
|
||||
|
||||
// translate language name to index in language vector
|
||||
int getLang(const Grammar& g, const string lang)
|
||||
{
|
||||
int res = 0 ;
|
||||
for (vector<string>::const_iterator i = g.langnames.begin() ;
|
||||
i != g.langnames.end() ; ++i)
|
||||
if (*i == lang)
|
||||
return res ;
|
||||
else
|
||||
++res ;
|
||||
|
||||
}
|
||||
|
||||
void help ()
|
||||
{
|
||||
cout << "Commands:" << endl ;
|
||||
cout << " h print this help" << endl ;
|
||||
cout << " . quit" << endl ;
|
||||
cout << " ! generate random example" << endl ;
|
||||
cout << " ? <Lang1> <Lang2> translation quiz from Lang1 to Lang2" << endl ;
|
||||
cout << " * <Lang> generate all sentences of Lang" << endl ;
|
||||
cout << " <other sentence> translate" << endl ;
|
||||
cout << endl ;
|
||||
}
|
||||
|
||||
int main (int argc, char* argv[])
|
||||
{
|
||||
|
||||
if (argc != 2) {
|
||||
cout << "usage: gfex <grammarfile>" << endl ;
|
||||
return 1 ;
|
||||
}
|
||||
|
||||
std::ifstream from(argv[1]) ;
|
||||
|
||||
Grammar g = readGrammar (from) ;
|
||||
|
||||
help() ;
|
||||
|
||||
string input ;
|
||||
|
||||
while (getline (cin,input)){
|
||||
|
||||
if (input == ".") {
|
||||
cout << "bye" << endl ;
|
||||
return 0 ;
|
||||
}
|
||||
else if (input == "h")
|
||||
help() ;
|
||||
else if (input == "!")
|
||||
genRandom(g) ;
|
||||
else if (input[0] == '?') {
|
||||
string src = words(input)[1] ;
|
||||
string trg = words(input)[2] ;
|
||||
quiz(g,getLang(g,src), getLang(g,trg)) ;
|
||||
}
|
||||
else if (input[0] == '*') {
|
||||
string src = words(input)[1] ;
|
||||
genAll(g,getLang(g,src)) ;
|
||||
}
|
||||
else
|
||||
translate(g,input) ;
|
||||
|
||||
cin.clear() ;
|
||||
|
||||
// cout << clock()/10000 ;
|
||||
|
||||
cout << endl ;
|
||||
}
|
||||
|
||||
return 0 ;
|
||||
}
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,227 +0,0 @@
|
||||
{-# OPTIONS_GHC -fglasgow-exts #-}
|
||||
module GFCC.Abs (Tree(..), Grammar, Header, Abstract, Concrete, AbsDef, CncDef, Type, Exp, Atom, Term, Tokn, Variant, CId, johnMajorEq, module GFCC.ComposOp) where
|
||||
|
||||
import GFCC.ComposOp
|
||||
|
||||
import Data.Monoid
|
||||
|
||||
-- Haskell module generated by the BNF converter
|
||||
|
||||
data Grammar_
|
||||
type Grammar = Tree Grammar_
|
||||
data Header_
|
||||
type Header = Tree Header_
|
||||
data Abstract_
|
||||
type Abstract = Tree Abstract_
|
||||
data Concrete_
|
||||
type Concrete = Tree Concrete_
|
||||
data AbsDef_
|
||||
type AbsDef = Tree AbsDef_
|
||||
data CncDef_
|
||||
type CncDef = Tree CncDef_
|
||||
data Type_
|
||||
type Type = Tree Type_
|
||||
data Exp_
|
||||
type Exp = Tree Exp_
|
||||
data Atom_
|
||||
type Atom = Tree Atom_
|
||||
data Term_
|
||||
type Term = Tree Term_
|
||||
data Tokn_
|
||||
type Tokn = Tree Tokn_
|
||||
data Variant_
|
||||
type Variant = Tree Variant_
|
||||
data CId_
|
||||
type CId = Tree CId_
|
||||
|
||||
data Tree :: * -> * where
|
||||
Grm :: Header -> Abstract -> [Concrete] -> Tree Grammar_
|
||||
Hdr :: CId -> [CId] -> Tree Header_
|
||||
Abs :: [AbsDef] -> Tree Abstract_
|
||||
Cnc :: CId -> [CncDef] -> Tree Concrete_
|
||||
Fun :: CId -> Type -> Exp -> Tree AbsDef_
|
||||
Lin :: CId -> Term -> Tree CncDef_
|
||||
Typ :: [CId] -> CId -> Tree Type_
|
||||
Tr :: Atom -> [Exp] -> Tree Exp_
|
||||
AC :: CId -> Tree Atom_
|
||||
AS :: String -> Tree Atom_
|
||||
AI :: Integer -> Tree Atom_
|
||||
AF :: Double -> Tree Atom_
|
||||
AM :: Tree Atom_
|
||||
R :: [Term] -> Tree Term_
|
||||
P :: Term -> Term -> Tree Term_
|
||||
S :: [Term] -> Tree Term_
|
||||
K :: Tokn -> Tree Term_
|
||||
V :: Integer -> Tree Term_
|
||||
C :: Integer -> Tree Term_
|
||||
F :: CId -> Tree Term_
|
||||
FV :: [Term] -> Tree Term_
|
||||
W :: String -> Term -> Tree Term_
|
||||
RP :: Term -> Term -> Tree Term_
|
||||
TM :: Tree Term_
|
||||
L :: CId -> Term -> Tree Term_
|
||||
BV :: CId -> Tree Term_
|
||||
KS :: String -> Tree Tokn_
|
||||
KP :: [String] -> [Variant] -> Tree Tokn_
|
||||
Var :: [String] -> [String] -> Tree Variant_
|
||||
CId :: String -> Tree CId_
|
||||
|
||||
instance Compos Tree where
|
||||
compos r a f t = case t of
|
||||
Grm header abstract concretes -> r Grm `a` f header `a` f abstract `a` foldr (a . a (r (:)) . f) (r []) concretes
|
||||
Hdr cid cids -> r Hdr `a` f cid `a` foldr (a . a (r (:)) . f) (r []) cids
|
||||
Abs absdefs -> r Abs `a` foldr (a . a (r (:)) . f) (r []) absdefs
|
||||
Cnc cid cncdefs -> r Cnc `a` f cid `a` foldr (a . a (r (:)) . f) (r []) cncdefs
|
||||
Fun cid type' exp -> r Fun `a` f cid `a` f type' `a` f exp
|
||||
Lin cid term -> r Lin `a` f cid `a` f term
|
||||
Typ cids cid -> r Typ `a` foldr (a . a (r (:)) . f) (r []) cids `a` f cid
|
||||
Tr atom exps -> r Tr `a` f atom `a` foldr (a . a (r (:)) . f) (r []) exps
|
||||
AC cid -> r AC `a` f cid
|
||||
R terms -> r R `a` foldr (a . a (r (:)) . f) (r []) terms
|
||||
P term0 term1 -> r P `a` f term0 `a` f term1
|
||||
S terms -> r S `a` foldr (a . a (r (:)) . f) (r []) terms
|
||||
K tokn -> r K `a` f tokn
|
||||
F cid -> r F `a` f cid
|
||||
FV terms -> r FV `a` foldr (a . a (r (:)) . f) (r []) terms
|
||||
W str term -> r W `a` r str `a` f term
|
||||
RP term0 term1 -> r RP `a` f term0 `a` f term1
|
||||
L cid term -> r L `a` f cid `a` f term
|
||||
BV cid -> r BV `a` f cid
|
||||
KP strs variants -> r KP `a` r strs `a` foldr (a . a (r (:)) . f) (r []) variants
|
||||
_ -> r t
|
||||
|
||||
instance Show (Tree c) where
|
||||
showsPrec n t = case t of
|
||||
Grm header abstract concretes -> opar n . showString "Grm" . showChar ' ' . showsPrec 1 header . showChar ' ' . showsPrec 1 abstract . showChar ' ' . showsPrec 1 concretes . cpar n
|
||||
Hdr cid cids -> opar n . showString "Hdr" . showChar ' ' . showsPrec 1 cid . showChar ' ' . showsPrec 1 cids . cpar n
|
||||
Abs absdefs -> opar n . showString "Abs" . showChar ' ' . showsPrec 1 absdefs . cpar n
|
||||
Cnc cid cncdefs -> opar n . showString "Cnc" . showChar ' ' . showsPrec 1 cid . showChar ' ' . showsPrec 1 cncdefs . cpar n
|
||||
Fun cid type' exp -> opar n . showString "Fun" . showChar ' ' . showsPrec 1 cid . showChar ' ' . showsPrec 1 type' . showChar ' ' . showsPrec 1 exp . cpar n
|
||||
Lin cid term -> opar n . showString "Lin" . showChar ' ' . showsPrec 1 cid . showChar ' ' . showsPrec 1 term . cpar n
|
||||
Typ cids cid -> opar n . showString "Typ" . showChar ' ' . showsPrec 1 cids . showChar ' ' . showsPrec 1 cid . cpar n
|
||||
Tr atom exps -> opar n . showString "Tr" . showChar ' ' . showsPrec 1 atom . showChar ' ' . showsPrec 1 exps . cpar n
|
||||
AC cid -> opar n . showString "AC" . showChar ' ' . showsPrec 1 cid . cpar n
|
||||
AS str -> opar n . showString "AS" . showChar ' ' . showsPrec 1 str . cpar n
|
||||
AI n -> opar n . showString "AI" . showChar ' ' . showsPrec 1 n . cpar n
|
||||
AF d -> opar n . showString "AF" . showChar ' ' . showsPrec 1 d . cpar n
|
||||
AM -> showString "AM"
|
||||
R terms -> opar n . showString "R" . showChar ' ' . showsPrec 1 terms . cpar n
|
||||
P term0 term1 -> opar n . showString "P" . showChar ' ' . showsPrec 1 term0 . showChar ' ' . showsPrec 1 term1 . cpar n
|
||||
S terms -> opar n . showString "S" . showChar ' ' . showsPrec 1 terms . cpar n
|
||||
K tokn -> opar n . showString "K" . showChar ' ' . showsPrec 1 tokn . cpar n
|
||||
V n -> opar n . showString "V" . showChar ' ' . showsPrec 1 n . cpar n
|
||||
C n -> opar n . showString "C" . showChar ' ' . showsPrec 1 n . cpar n
|
||||
F cid -> opar n . showString "F" . showChar ' ' . showsPrec 1 cid . cpar n
|
||||
FV terms -> opar n . showString "FV" . showChar ' ' . showsPrec 1 terms . cpar n
|
||||
W str term -> opar n . showString "W" . showChar ' ' . showsPrec 1 str . showChar ' ' . showsPrec 1 term . cpar n
|
||||
RP term0 term1 -> opar n . showString "RP" . showChar ' ' . showsPrec 1 term0 . showChar ' ' . showsPrec 1 term1 . cpar n
|
||||
TM -> showString "TM"
|
||||
L cid term -> opar n . showString "L" . showChar ' ' . showsPrec 1 cid . showChar ' ' . showsPrec 1 term . cpar n
|
||||
BV cid -> opar n . showString "BV" . showChar ' ' . showsPrec 1 cid . cpar n
|
||||
KS str -> opar n . showString "KS" . showChar ' ' . showsPrec 1 str . cpar n
|
||||
KP strs variants -> opar n . showString "KP" . showChar ' ' . showsPrec 1 strs . showChar ' ' . showsPrec 1 variants . cpar n
|
||||
Var strs0 strs1 -> opar n . showString "Var" . showChar ' ' . showsPrec 1 strs0 . showChar ' ' . showsPrec 1 strs1 . cpar n
|
||||
CId str -> opar n . showString "CId" . showChar ' ' . showsPrec 1 str . cpar n
|
||||
where opar n = if n > 0 then showChar '(' else id
|
||||
cpar n = if n > 0 then showChar ')' else id
|
||||
|
||||
instance Eq (Tree c) where (==) = johnMajorEq
|
||||
|
||||
johnMajorEq :: Tree a -> Tree b -> Bool
|
||||
johnMajorEq (Grm header abstract concretes) (Grm header_ abstract_ concretes_) = header == header_ && abstract == abstract_ && concretes == concretes_
|
||||
johnMajorEq (Hdr cid cids) (Hdr cid_ cids_) = cid == cid_ && cids == cids_
|
||||
johnMajorEq (Abs absdefs) (Abs absdefs_) = absdefs == absdefs_
|
||||
johnMajorEq (Cnc cid cncdefs) (Cnc cid_ cncdefs_) = cid == cid_ && cncdefs == cncdefs_
|
||||
johnMajorEq (Fun cid type' exp) (Fun cid_ type'_ exp_) = cid == cid_ && type' == type'_ && exp == exp_
|
||||
johnMajorEq (Lin cid term) (Lin cid_ term_) = cid == cid_ && term == term_
|
||||
johnMajorEq (Typ cids cid) (Typ cids_ cid_) = cids == cids_ && cid == cid_
|
||||
johnMajorEq (Tr atom exps) (Tr atom_ exps_) = atom == atom_ && exps == exps_
|
||||
johnMajorEq (AC cid) (AC cid_) = cid == cid_
|
||||
johnMajorEq (AS str) (AS str_) = str == str_
|
||||
johnMajorEq (AI n) (AI n_) = n == n_
|
||||
johnMajorEq (AF d) (AF d_) = d == d_
|
||||
johnMajorEq AM AM = True
|
||||
johnMajorEq (R terms) (R terms_) = terms == terms_
|
||||
johnMajorEq (P term0 term1) (P term0_ term1_) = term0 == term0_ && term1 == term1_
|
||||
johnMajorEq (S terms) (S terms_) = terms == terms_
|
||||
johnMajorEq (K tokn) (K tokn_) = tokn == tokn_
|
||||
johnMajorEq (V n) (V n_) = n == n_
|
||||
johnMajorEq (C n) (C n_) = n == n_
|
||||
johnMajorEq (F cid) (F cid_) = cid == cid_
|
||||
johnMajorEq (FV terms) (FV terms_) = terms == terms_
|
||||
johnMajorEq (W str term) (W str_ term_) = str == str_ && term == term_
|
||||
johnMajorEq (RP term0 term1) (RP term0_ term1_) = term0 == term0_ && term1 == term1_
|
||||
johnMajorEq TM TM = True
|
||||
johnMajorEq (L cid term) (L cid_ term_) = cid == cid_ && term == term_
|
||||
johnMajorEq (BV cid) (BV cid_) = cid == cid_
|
||||
johnMajorEq (KS str) (KS str_) = str == str_
|
||||
johnMajorEq (KP strs variants) (KP strs_ variants_) = strs == strs_ && variants == variants_
|
||||
johnMajorEq (Var strs0 strs1) (Var strs0_ strs1_) = strs0 == strs0_ && strs1 == strs1_
|
||||
johnMajorEq (CId str) (CId str_) = str == str_
|
||||
johnMajorEq _ _ = False
|
||||
|
||||
instance Ord (Tree c) where
|
||||
compare x y = compare (index x) (index y) `mappend` compareSame x y
|
||||
index :: Tree c -> Int
|
||||
index (Grm _ _ _) = 0
|
||||
index (Hdr _ _) = 1
|
||||
index (Abs _) = 2
|
||||
index (Cnc _ _) = 3
|
||||
index (Fun _ _ _) = 4
|
||||
index (Lin _ _) = 5
|
||||
index (Typ _ _) = 6
|
||||
index (Tr _ _) = 7
|
||||
index (AC _) = 8
|
||||
index (AS _) = 9
|
||||
index (AI _) = 10
|
||||
index (AF _) = 11
|
||||
index (AM ) = 12
|
||||
index (R _) = 13
|
||||
index (P _ _) = 14
|
||||
index (S _) = 15
|
||||
index (K _) = 16
|
||||
index (V _) = 17
|
||||
index (C _) = 18
|
||||
index (F _) = 19
|
||||
index (FV _) = 20
|
||||
index (W _ _) = 21
|
||||
index (RP _ _) = 22
|
||||
index (TM ) = 23
|
||||
index (L _ _) = 24
|
||||
index (BV _) = 25
|
||||
index (KS _) = 26
|
||||
index (KP _ _) = 27
|
||||
index (Var _ _) = 28
|
||||
index (CId _) = 29
|
||||
compareSame :: Tree c -> Tree c -> Ordering
|
||||
compareSame (Grm header abstract concretes) (Grm header_ abstract_ concretes_) = mappend (compare header header_) (mappend (compare abstract abstract_) (compare concretes concretes_))
|
||||
compareSame (Hdr cid cids) (Hdr cid_ cids_) = mappend (compare cid cid_) (compare cids cids_)
|
||||
compareSame (Abs absdefs) (Abs absdefs_) = compare absdefs absdefs_
|
||||
compareSame (Cnc cid cncdefs) (Cnc cid_ cncdefs_) = mappend (compare cid cid_) (compare cncdefs cncdefs_)
|
||||
compareSame (Fun cid type' exp) (Fun cid_ type'_ exp_) = mappend (compare cid cid_) (mappend (compare type' type'_) (compare exp exp_))
|
||||
compareSame (Lin cid term) (Lin cid_ term_) = mappend (compare cid cid_) (compare term term_)
|
||||
compareSame (Typ cids cid) (Typ cids_ cid_) = mappend (compare cids cids_) (compare cid cid_)
|
||||
compareSame (Tr atom exps) (Tr atom_ exps_) = mappend (compare atom atom_) (compare exps exps_)
|
||||
compareSame (AC cid) (AC cid_) = compare cid cid_
|
||||
compareSame (AS str) (AS str_) = compare str str_
|
||||
compareSame (AI n) (AI n_) = compare n n_
|
||||
compareSame (AF d) (AF d_) = compare d d_
|
||||
compareSame AM AM = EQ
|
||||
compareSame (R terms) (R terms_) = compare terms terms_
|
||||
compareSame (P term0 term1) (P term0_ term1_) = mappend (compare term0 term0_) (compare term1 term1_)
|
||||
compareSame (S terms) (S terms_) = compare terms terms_
|
||||
compareSame (K tokn) (K tokn_) = compare tokn tokn_
|
||||
compareSame (V n) (V n_) = compare n n_
|
||||
compareSame (C n) (C n_) = compare n n_
|
||||
compareSame (F cid) (F cid_) = compare cid cid_
|
||||
compareSame (FV terms) (FV terms_) = compare terms terms_
|
||||
compareSame (W str term) (W str_ term_) = mappend (compare str str_) (compare term term_)
|
||||
compareSame (RP term0 term1) (RP term0_ term1_) = mappend (compare term0 term0_) (compare term1 term1_)
|
||||
compareSame TM TM = EQ
|
||||
compareSame (L cid term) (L cid_ term_) = mappend (compare cid cid_) (compare term term_)
|
||||
compareSame (BV cid) (BV cid_) = compare cid cid_
|
||||
compareSame (KS str) (KS str_) = compare str str_
|
||||
compareSame (KP strs variants) (KP strs_ variants_) = mappend (compare strs strs_) (compare variants variants_)
|
||||
compareSame (Var strs0 strs1) (Var strs0_ strs1_) = mappend (compare strs0 strs0_) (compare strs1 strs1_)
|
||||
compareSame (CId str) (CId str_) = compare str str_
|
||||
compareSame x y = error "BNFC error:" compareSame
|
||||
@@ -1,30 +0,0 @@
|
||||
{-# OPTIONS_GHC -fglasgow-exts #-}
|
||||
module GFCC.ComposOp (Compos(..),composOp,composOpM,composOpM_,composOpMonoid,
|
||||
composOpMPlus,composOpFold) where
|
||||
|
||||
import Control.Monad.Identity
|
||||
import Data.Monoid
|
||||
|
||||
class Compos t where
|
||||
compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b)
|
||||
-> (forall a. t a -> m (t a)) -> t c -> m (t c)
|
||||
|
||||
composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c
|
||||
composOp f = runIdentity . composOpM (Identity . f)
|
||||
|
||||
composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c)
|
||||
composOpM = compos return ap
|
||||
|
||||
composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m ()
|
||||
composOpM_ = composOpFold (return ()) (>>)
|
||||
|
||||
composOpMonoid :: (Compos t, Monoid m) => (forall a. t a -> m) -> t c -> m
|
||||
composOpMonoid = composOpFold mempty mappend
|
||||
|
||||
composOpMPlus :: (Compos t, MonadPlus m) => (forall a. t a -> m b) -> t c -> m b
|
||||
composOpMPlus = composOpFold mzero mplus
|
||||
|
||||
composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b
|
||||
composOpFold z c f = unC . compos (\_ -> C z) (\(C x) (C y) -> C (c x y)) (C . f)
|
||||
|
||||
newtype C b a = C { unC :: b }
|
||||
@@ -1,16 +0,0 @@
|
||||
-- BNF Converter: Error Monad
|
||||
-- Copyright (C) 2004 Author: Aarne Ranta
|
||||
|
||||
-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.
|
||||
module GFCC.ErrM where
|
||||
|
||||
-- the Error monad: like Maybe type with error msgs
|
||||
|
||||
data Err a = Ok a | Bad String
|
||||
deriving (Read, Show, Eq)
|
||||
|
||||
instance Monad Err where
|
||||
return = Ok
|
||||
fail = Bad
|
||||
Ok a >>= f = f a
|
||||
Bad s >>= f = Bad s
|
||||
File diff suppressed because one or more lines are too long
@@ -1,135 +0,0 @@
|
||||
-- -*- haskell -*-
|
||||
-- This Alex file was machine-generated by the BNF converter
|
||||
{
|
||||
{-# OPTIONS -fno-warn-incomplete-patterns #-}
|
||||
module GFCC.Lex where
|
||||
|
||||
|
||||
}
|
||||
|
||||
|
||||
$l = [a-zA-Z\192 - \255] # [\215 \247] -- isolatin1 letter FIXME
|
||||
$c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter FIXME
|
||||
$s = [a-z\222-\255] # [\247] -- small isolatin1 letter FIXME
|
||||
$d = [0-9] -- digit
|
||||
$i = [$l $d _ '] -- identifier character
|
||||
$u = [\0-\255] -- universal: any character
|
||||
|
||||
@rsyms = -- symbols and non-identifier-like reserved words
|
||||
\; | \( | \) | \{ | \} | \: | \= | \- \> | \? | \[ | \] | \! | \$ | \[ \| | \| \] | \+ | \@ | \# | \/ | \,
|
||||
|
||||
:-
|
||||
|
||||
$white+ ;
|
||||
@rsyms { tok (\p s -> PT p (TS $ share s)) }
|
||||
(\_ | $l)($l | $d | \' | \_)* { tok (\p s -> PT p (eitherResIdent (T_CId . share) s)) }
|
||||
|
||||
$l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
|
||||
\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
|
||||
|
||||
$d+ { tok (\p s -> PT p (TI $ share s)) }
|
||||
$d+ \. $d+ (e (\-)? $d+)? { tok (\p s -> PT p (TD $ share s)) }
|
||||
|
||||
{
|
||||
|
||||
tok f p s = f p s
|
||||
|
||||
share :: String -> String
|
||||
share = id
|
||||
|
||||
data Tok =
|
||||
TS !String -- reserved words and symbols
|
||||
| TL !String -- string literals
|
||||
| TI !String -- integer literals
|
||||
| TV !String -- identifiers
|
||||
| TD !String -- double precision float literals
|
||||
| TC !String -- character literals
|
||||
| T_CId !String
|
||||
|
||||
deriving (Eq,Show,Ord)
|
||||
|
||||
data Token =
|
||||
PT Posn Tok
|
||||
| Err Posn
|
||||
deriving (Eq,Show,Ord)
|
||||
|
||||
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
|
||||
PT _ (T_CId s) -> s
|
||||
|
||||
_ -> show t
|
||||
|
||||
data BTree = N | B String Tok BTree BTree deriving (Show)
|
||||
|
||||
eitherResIdent :: (String -> Tok) -> String -> Tok
|
||||
eitherResIdent tv s = treeFind resWords
|
||||
where
|
||||
treeFind N = tv s
|
||||
treeFind (B a t left right) | s < a = treeFind left
|
||||
| s > a = treeFind right
|
||||
| s == a = t
|
||||
|
||||
resWords = b "grammar" (b "concrete" (b "abstract" N N) N) (b "pre" N N)
|
||||
where b s = B s (TS s)
|
||||
|
||||
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
|
||||
_ -> []
|
||||
|
||||
-------------------------------------------------------------------
|
||||
-- Alex wrapper code.
|
||||
-- A modified "posn" wrapper.
|
||||
-------------------------------------------------------------------
|
||||
|
||||
data Posn = Pn !Int !Int !Int
|
||||
deriving (Eq, Show,Ord)
|
||||
|
||||
alexStartPos :: Posn
|
||||
alexStartPos = Pn 0 1 1
|
||||
|
||||
alexMove :: Posn -> Char -> Posn
|
||||
alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1)
|
||||
alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1
|
||||
alexMove (Pn a l c) _ = Pn (a+1) l (c+1)
|
||||
|
||||
type AlexInput = (Posn, -- current position,
|
||||
Char, -- previous char
|
||||
String) -- current input string
|
||||
|
||||
tokens :: String -> [Token]
|
||||
tokens str = go (alexStartPos, '\n', str)
|
||||
where
|
||||
go :: (Posn, Char, String) -> [Token]
|
||||
go inp@(pos, _, str) =
|
||||
case alexScan inp 0 of
|
||||
AlexEOF -> []
|
||||
AlexError (pos, _, _) -> [Err pos]
|
||||
AlexSkip inp' len -> go inp'
|
||||
AlexToken inp' len act -> act pos (take len str) : (go inp')
|
||||
|
||||
alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
|
||||
alexGetChar (p, c, []) = Nothing
|
||||
alexGetChar (p, _, (c:s)) =
|
||||
let p' = alexMove p c
|
||||
in p' `seq` Just (c, (p', c, s))
|
||||
|
||||
alexInputPrevChar :: AlexInput -> Char
|
||||
alexInputPrevChar (p, c, s) = c
|
||||
}
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,204 +0,0 @@
|
||||
-- This Happy file was machine-generated by the BNF converter
|
||||
{
|
||||
{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}
|
||||
module GFCC.Par where
|
||||
import GFCC.Abs
|
||||
import GFCC.Lex
|
||||
import GFCC.ErrM
|
||||
}
|
||||
|
||||
%name pGrammar Grammar
|
||||
%name pHeader Header
|
||||
%name pAbstract Abstract
|
||||
%name pConcrete Concrete
|
||||
%name pAbsDef AbsDef
|
||||
%name pCncDef CncDef
|
||||
%name pType Type
|
||||
%name pExp Exp
|
||||
%name pAtom Atom
|
||||
%name pTerm Term
|
||||
%name pTokn Tokn
|
||||
%name pVariant Variant
|
||||
%name pListConcrete ListConcrete
|
||||
%name pListAbsDef ListAbsDef
|
||||
%name pListCncDef ListCncDef
|
||||
%name pListCId ListCId
|
||||
%name pListTerm ListTerm
|
||||
%name pListExp ListExp
|
||||
%name pListString ListString
|
||||
%name pListVariant ListVariant
|
||||
|
||||
-- no lexer declaration
|
||||
%monad { Err } { thenM } { returnM }
|
||||
%tokentype { Token }
|
||||
|
||||
%token
|
||||
';' { PT _ (TS ";") }
|
||||
'(' { PT _ (TS "(") }
|
||||
')' { PT _ (TS ")") }
|
||||
'{' { PT _ (TS "{") }
|
||||
'}' { PT _ (TS "}") }
|
||||
':' { PT _ (TS ":") }
|
||||
'=' { PT _ (TS "=") }
|
||||
'->' { PT _ (TS "->") }
|
||||
'?' { PT _ (TS "?") }
|
||||
'[' { PT _ (TS "[") }
|
||||
']' { PT _ (TS "]") }
|
||||
'!' { PT _ (TS "!") }
|
||||
'$' { PT _ (TS "$") }
|
||||
'[|' { PT _ (TS "[|") }
|
||||
'|]' { PT _ (TS "|]") }
|
||||
'+' { PT _ (TS "+") }
|
||||
'@' { PT _ (TS "@") }
|
||||
'#' { PT _ (TS "#") }
|
||||
'/' { PT _ (TS "/") }
|
||||
',' { PT _ (TS ",") }
|
||||
'abstract' { PT _ (TS "abstract") }
|
||||
'concrete' { PT _ (TS "concrete") }
|
||||
'grammar' { PT _ (TS "grammar") }
|
||||
'pre' { PT _ (TS "pre") }
|
||||
|
||||
L_quoted { PT _ (TL $$) }
|
||||
L_integ { PT _ (TI $$) }
|
||||
L_doubl { PT _ (TD $$) }
|
||||
L_CId { PT _ (T_CId $$) }
|
||||
L_err { _ }
|
||||
|
||||
|
||||
%%
|
||||
|
||||
String :: { String } : L_quoted { $1 }
|
||||
Integer :: { Integer } : L_integ { (read $1) :: Integer }
|
||||
Double :: { Double } : L_doubl { (read $1) :: Double }
|
||||
CId :: { CId} : L_CId { CId ($1)}
|
||||
|
||||
Grammar :: { Grammar }
|
||||
Grammar : Header ';' Abstract ';' ListConcrete { Grm $1 $3 (reverse $5) }
|
||||
|
||||
|
||||
Header :: { Header }
|
||||
Header : 'grammar' CId '(' ListCId ')' { Hdr $2 $4 }
|
||||
|
||||
|
||||
Abstract :: { Abstract }
|
||||
Abstract : 'abstract' '{' ListAbsDef '}' { Abs (reverse $3) }
|
||||
|
||||
|
||||
Concrete :: { Concrete }
|
||||
Concrete : 'concrete' CId '{' ListCncDef '}' { Cnc $2 (reverse $4) }
|
||||
|
||||
|
||||
AbsDef :: { AbsDef }
|
||||
AbsDef : CId ':' Type '=' Exp { Fun $1 $3 $5 }
|
||||
|
||||
|
||||
CncDef :: { CncDef }
|
||||
CncDef : CId '=' Term { Lin $1 $3 }
|
||||
|
||||
|
||||
Type :: { Type }
|
||||
Type : ListCId '->' CId { Typ $1 $3 }
|
||||
|
||||
|
||||
Exp :: { Exp }
|
||||
Exp : '(' Atom ListExp ')' { Tr $2 (reverse $3) }
|
||||
| Atom { trA_ $1 }
|
||||
|
||||
|
||||
Atom :: { Atom }
|
||||
Atom : CId { AC $1 }
|
||||
| String { AS $1 }
|
||||
| Integer { AI $1 }
|
||||
| Double { AF $1 }
|
||||
| '?' { AM }
|
||||
|
||||
|
||||
Term :: { Term }
|
||||
Term : '[' ListTerm ']' { R $2 }
|
||||
| '(' Term '!' Term ')' { P $2 $4 }
|
||||
| '(' ListTerm ')' { S $2 }
|
||||
| Tokn { K $1 }
|
||||
| '$' Integer { V $2 }
|
||||
| Integer { C $1 }
|
||||
| CId { F $1 }
|
||||
| '[|' ListTerm '|]' { FV $2 }
|
||||
| '(' String '+' Term ')' { W $2 $4 }
|
||||
| '(' Term '@' Term ')' { RP $2 $4 }
|
||||
| '?' { TM }
|
||||
| '(' CId '->' Term ')' { L $2 $4 }
|
||||
| '#' CId { BV $2 }
|
||||
|
||||
|
||||
Tokn :: { Tokn }
|
||||
Tokn : String { KS $1 }
|
||||
| '[' 'pre' ListString '[' ListVariant ']' ']' { KP (reverse $3) $5 }
|
||||
|
||||
|
||||
Variant :: { Variant }
|
||||
Variant : ListString '/' ListString { Var (reverse $1) (reverse $3) }
|
||||
|
||||
|
||||
ListConcrete :: { [Concrete] }
|
||||
ListConcrete : {- empty -} { [] }
|
||||
| ListConcrete Concrete ';' { flip (:) $1 $2 }
|
||||
|
||||
|
||||
ListAbsDef :: { [AbsDef] }
|
||||
ListAbsDef : {- empty -} { [] }
|
||||
| ListAbsDef AbsDef ';' { flip (:) $1 $2 }
|
||||
|
||||
|
||||
ListCncDef :: { [CncDef] }
|
||||
ListCncDef : {- empty -} { [] }
|
||||
| ListCncDef CncDef ';' { flip (:) $1 $2 }
|
||||
|
||||
|
||||
ListCId :: { [CId] }
|
||||
ListCId : {- empty -} { [] }
|
||||
| CId { (:[]) $1 }
|
||||
| CId ',' ListCId { (:) $1 $3 }
|
||||
|
||||
|
||||
ListTerm :: { [Term] }
|
||||
ListTerm : {- empty -} { [] }
|
||||
| Term { (:[]) $1 }
|
||||
| Term ',' ListTerm { (:) $1 $3 }
|
||||
|
||||
|
||||
ListExp :: { [Exp] }
|
||||
ListExp : {- empty -} { [] }
|
||||
| ListExp Exp { flip (:) $1 $2 }
|
||||
|
||||
|
||||
ListString :: { [String] }
|
||||
ListString : {- empty -} { [] }
|
||||
| ListString String { flip (:) $1 $2 }
|
||||
|
||||
|
||||
ListVariant :: { [Variant] }
|
||||
ListVariant : {- empty -} { [] }
|
||||
| Variant { (:[]) $1 }
|
||||
| Variant ',' ListVariant { (:) $1 $3 }
|
||||
|
||||
|
||||
|
||||
{
|
||||
|
||||
returnM :: a -> Err a
|
||||
returnM = return
|
||||
|
||||
thenM :: Err a -> (a -> Err b) -> Err b
|
||||
thenM = (>>=)
|
||||
|
||||
happyError :: [Token] -> Err a
|
||||
happyError ts =
|
||||
Bad $ "syntax error at " ++ tokenPos ts ++
|
||||
case ts of
|
||||
[] -> []
|
||||
[Err _] -> " due to lexer error"
|
||||
_ -> " before " ++ unwords (map prToken (take 4 ts))
|
||||
|
||||
myLexer = tokens
|
||||
trA_ a_ = Tr a_ []
|
||||
}
|
||||
|
||||
@@ -1,148 +0,0 @@
|
||||
{-# OPTIONS_GHC -fglasgow-exts #-}
|
||||
module GFCC.Print where
|
||||
|
||||
-- pretty-printer generated by the BNF converter
|
||||
|
||||
import GFCC.Abs
|
||||
import Data.Char
|
||||
import Data.List (intersperse)
|
||||
|
||||
-- the top-level printing method
|
||||
printTree :: Print a => a -> String
|
||||
printTree = render . prt 0
|
||||
|
||||
type Doc = [ShowS] -> [ShowS]
|
||||
|
||||
doc :: ShowS -> Doc
|
||||
doc = (:)
|
||||
|
||||
render :: Doc -> String
|
||||
render d = rend 0 (map ($ "") $ d []) "" where
|
||||
rend i ss = case ss of
|
||||
"[" :ts -> showChar '[' . rend i ts
|
||||
"(" :ts -> showChar '(' . rend i ts
|
||||
"{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts
|
||||
"}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
|
||||
"}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
|
||||
";" :ts -> showChar ';' . new i . rend i ts
|
||||
t : "," :ts -> showString t . space "," . rend i ts
|
||||
t : ")" :ts -> showString t . showChar ')' . rend i ts
|
||||
t : "]" :ts -> showString t . showChar ']' . rend i ts
|
||||
t :ts -> space t . rend i ts
|
||||
_ -> id
|
||||
new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
|
||||
space t = showString t . (\s -> if null s then "" else (' ':s))
|
||||
|
||||
parenth :: Doc -> Doc
|
||||
parenth ss = doc (showChar '(') . ss . doc (showChar ')')
|
||||
|
||||
concatS :: [ShowS] -> ShowS
|
||||
concatS = foldr (.) id
|
||||
|
||||
concatD :: [Doc] -> Doc
|
||||
concatD = foldr (.) id
|
||||
|
||||
unwordsD :: [Doc] -> Doc
|
||||
unwordsD = concatD . intersperse (doc (showChar ' '))
|
||||
|
||||
replicateS :: Int -> ShowS -> ShowS
|
||||
replicateS n f = concatS (replicate n f)
|
||||
|
||||
-- the printer class does the job
|
||||
class Print a where
|
||||
prt :: Int -> a -> Doc
|
||||
|
||||
instance Print Char where
|
||||
prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
|
||||
|
||||
instance Print String where
|
||||
prt _ s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
|
||||
|
||||
mkEsc :: Char -> Char -> ShowS
|
||||
mkEsc q s = case s of
|
||||
_ | s == q -> showChar '\\' . showChar s
|
||||
'\\'-> showString "\\\\"
|
||||
'\n' -> showString "\\n"
|
||||
'\t' -> showString "\\t"
|
||||
_ -> showChar s
|
||||
|
||||
prPrec :: Int -> Int -> Doc -> Doc
|
||||
prPrec i j = if j<i then parenth else id
|
||||
|
||||
|
||||
instance Print Integer where
|
||||
prt _ x = doc (shows x)
|
||||
|
||||
|
||||
instance Print Double where
|
||||
prt _ x = doc (shows x)
|
||||
|
||||
|
||||
instance Print (Tree c) where
|
||||
prt _i e = case e of
|
||||
Grm header abstract concretes -> prPrec _i 0 (concatD [prt 0 header , doc (showString ";") , prt 0 abstract , doc (showString ";") , prt 0 concretes])
|
||||
Hdr cid cids -> prPrec _i 0 (concatD [doc (showString "grammar") , prt 0 cid , doc (showString "(") , prt 0 cids , doc (showString ")")])
|
||||
Abs absdefs -> prPrec _i 0 (concatD [doc (showString "abstract") , doc (showString "{") , prt 0 absdefs , doc (showString "}")])
|
||||
Cnc cid cncdefs -> prPrec _i 0 (concatD [doc (showString "concrete") , prt 0 cid , doc (showString "{") , prt 0 cncdefs , doc (showString "}")])
|
||||
Fun cid type' exp -> prPrec _i 0 (concatD [prt 0 cid , doc (showString ":") , prt 0 type' , doc (showString "=") , prt 0 exp])
|
||||
Lin cid term -> prPrec _i 0 (concatD [prt 0 cid , doc (showString "=") , prt 0 term])
|
||||
Typ cids cid -> prPrec _i 0 (concatD [prt 0 cids , doc (showString "->") , prt 0 cid])
|
||||
Tr atom exps -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 atom , prt 0 exps , doc (showString ")")])
|
||||
AC cid -> prPrec _i 0 (concatD [prt 0 cid])
|
||||
AS str -> prPrec _i 0 (concatD [prt 0 str])
|
||||
AI n -> prPrec _i 0 (concatD [prt 0 n])
|
||||
AF d -> prPrec _i 0 (concatD [prt 0 d])
|
||||
AM -> prPrec _i 0 (concatD [doc (showString "?")])
|
||||
R terms -> prPrec _i 0 (concatD [doc (showString "[") , prt 0 terms , doc (showString "]")])
|
||||
P term0 term1 -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 term0 , doc (showString "!") , prt 0 term1 , doc (showString ")")])
|
||||
S terms -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 terms , doc (showString ")")])
|
||||
K tokn -> prPrec _i 0 (concatD [prt 0 tokn])
|
||||
V n -> prPrec _i 0 (concatD [doc (showString "$") , prt 0 n])
|
||||
C n -> prPrec _i 0 (concatD [prt 0 n])
|
||||
F cid -> prPrec _i 0 (concatD [prt 0 cid])
|
||||
FV terms -> prPrec _i 0 (concatD [doc (showString "[|") , prt 0 terms , doc (showString "|]")])
|
||||
W str term -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 str , doc (showString "+") , prt 0 term , doc (showString ")")])
|
||||
RP term0 term1 -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 term0 , doc (showString "@") , prt 0 term1 , doc (showString ")")])
|
||||
TM -> prPrec _i 0 (concatD [doc (showString "?")])
|
||||
L cid term -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 cid , doc (showString "->") , prt 0 term , doc (showString ")")])
|
||||
BV cid -> prPrec _i 0 (concatD [doc (showString "#") , prt 0 cid])
|
||||
KS str -> prPrec _i 0 (concatD [prt 0 str])
|
||||
KP strs variants -> prPrec _i 0 (concatD [doc (showString "[") , doc (showString "pre") , prt 0 strs , doc (showString "[") , prt 0 variants , doc (showString "]") , doc (showString "]")])
|
||||
Var strs0 strs1 -> prPrec _i 0 (concatD [prt 0 strs0 , doc (showString "/") , prt 0 strs1])
|
||||
CId str -> prPrec _i 0 (doc (showString str))
|
||||
|
||||
instance Print [Concrete] where
|
||||
prt _ es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
instance Print [AbsDef] where
|
||||
prt _ es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
instance Print [CncDef] where
|
||||
prt _ es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
instance Print [CId] where
|
||||
prt _ es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
|
||||
instance Print [Term] where
|
||||
prt _ es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
|
||||
instance Print [Exp] where
|
||||
prt _ es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , prt 0 xs])
|
||||
instance Print [String] where
|
||||
prt _ es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , prt 0 xs])
|
||||
instance Print [Variant] where
|
||||
prt _ es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
|
||||
@@ -1,58 +0,0 @@
|
||||
-- automatically generated by BNF Converter
|
||||
module Main where
|
||||
|
||||
|
||||
import IO ( stdin, hGetContents )
|
||||
import System ( getArgs, getProgName )
|
||||
|
||||
import GFCC.Lex
|
||||
import GFCC.Par
|
||||
import GFCC.Skel
|
||||
import GFCC.Print
|
||||
import GFCC.Abs
|
||||
|
||||
|
||||
|
||||
|
||||
import GFCC.ErrM
|
||||
|
||||
type ParseFun a = [Token] -> Err a
|
||||
|
||||
myLLexer = myLexer
|
||||
|
||||
type Verbosity = Int
|
||||
|
||||
putStrV :: Verbosity -> String -> IO ()
|
||||
putStrV v s = if v > 1 then putStrLn s else return ()
|
||||
|
||||
runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()
|
||||
runFile v p f = putStrLn f >> readFile f >>= run v p
|
||||
|
||||
run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()
|
||||
run v p s = let ts = myLLexer s in case p ts of
|
||||
Bad s -> do putStrLn "\nParse Failed...\n"
|
||||
putStrV v "Tokens:"
|
||||
putStrV v $ show ts
|
||||
putStrLn s
|
||||
Ok tree -> do putStrLn "\nParse Successful!"
|
||||
showTree v tree
|
||||
|
||||
|
||||
|
||||
showTree :: (Show a, Print a) => Int -> a -> IO ()
|
||||
showTree v tree
|
||||
= do
|
||||
putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree
|
||||
putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree
|
||||
|
||||
main :: IO ()
|
||||
main = do args <- getArgs
|
||||
case args of
|
||||
[] -> hGetContents stdin >>= run 2 pGrammar
|
||||
"-s":fs -> mapM_ (runFile 0 pGrammar) fs
|
||||
fs -> mapM_ (runFile 2 pGrammar) fs
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -1,25 +0,0 @@
|
||||
GHC = ghc
|
||||
GHCFLAGS =
|
||||
|
||||
.PHONY: all gfcc2c clean
|
||||
|
||||
all: gfcc2c
|
||||
|
||||
gfcc2c:
|
||||
$(GHC) $(GHCFLAGS) --make -o $@ gfcc2c.hs
|
||||
|
||||
bnfc:
|
||||
bnfc -gadt -d ../../GF/Canon/GFCC/GFCC.cf
|
||||
-rm -f GFCC/Doc.tex GFCC/Skel.hs
|
||||
happy -gca GFCC/Par.y
|
||||
alex -g GFCC/Lex.x
|
||||
|
||||
clean:
|
||||
-rm -f gfcc2c
|
||||
-rm -f *.o *.hi
|
||||
-rm -f GFCC/*.hi GFCC/*.o
|
||||
|
||||
bnfcclean: clean
|
||||
-rm -f GFCC/*.bak
|
||||
-rm -f GFCC/Lex.* GFCC/Par.* GFCC/Layout.* GFCC/Skel.* GFCC/Print.* GFCC/Test.* GFCC/Abs.* GFCC/ComposOp.* GFCC/Test GFCC/ErrM.* GFCC/SharedString.*
|
||||
-rmdir -p GFCC/
|
||||
@@ -1,47 +0,0 @@
|
||||
|
||||
GFDIR=../../../../../
|
||||
|
||||
LIBGFCC_INCLUDES = $(GFDIR)/lib/c
|
||||
LIBGFCC_LIBDIR = $(GFDIR)/lib/c
|
||||
|
||||
GFCC2C = $(GFDIR)/bin/gfcc2c
|
||||
|
||||
TEST_PROG = bronzeage-test
|
||||
|
||||
GRAMMAR_DIR = $(GFDIR)/examples/bronzeage
|
||||
|
||||
GRAMMAR_MODULES = Bronzeage BronzeageEng BronzeageSwe
|
||||
|
||||
GRAMMAR_H_FILES = $(addsuffix .h, $(GRAMMAR_MODULES))
|
||||
GRAMMAR_C_FILES = $(addsuffix .c, $(GRAMMAR_MODULES))
|
||||
GRAMMAR_O_FILES = $(addsuffix .o, $(GRAMMAR_MODULES))
|
||||
|
||||
CFLAGS += -O2
|
||||
CPPFLAGS += -I$(LIBGFCC_INCLUDES)
|
||||
|
||||
.PHONY: clean
|
||||
|
||||
all: bronzeage.gfcc $(TEST_PROG)
|
||||
|
||||
$(TEST_PROG): $(GRAMMAR_O_FILES) $(TEST_PROG).o $(LIBGFCC_LIBDIR)/libgfcc.a
|
||||
|
||||
$(TEST_PROG).o: $(GRAMMAR_H_FILES) $(GRAMMAR_O_FILES) $(TEST_PROG).c
|
||||
|
||||
$(GRAMMAR_H_FILES) $(GRAMMAR_C_FILES): $(GFCC2C) bronzeage.gfcc
|
||||
$(GFCC2C) bronzeage.gfcc
|
||||
|
||||
bronzeage.gfcc:
|
||||
echo "i -optimize=all $(GRAMMAR_DIR)/BronzeageEng.gf" > mkBronzeage.gfs
|
||||
echo "i -optimize=all $(GRAMMAR_DIR)/BronzeageSwe.gf" >> mkBronzeage.gfs
|
||||
echo "s" >> mkBronzeage.gfs
|
||||
echo "pm -printer=gfcc | wf bronzeage.gfcc" >> mkBronzeage.gfs
|
||||
cat mkBronzeage.gfs | gf
|
||||
rm -f mkBronzeage.gfs
|
||||
|
||||
clean:
|
||||
-rm -f $(TEST_PROG) *.o
|
||||
|
||||
|
||||
distclean: clean
|
||||
-rm -f $(GRAMMAR_H_FILES) $(GRAMMAR_C_FILES)
|
||||
-rm -f bronzeage.gfcc
|
||||
@@ -1,31 +0,0 @@
|
||||
#include "Bronzeage.h"
|
||||
|
||||
#include "BronzeageEng.h"
|
||||
|
||||
#include <unistd.h>
|
||||
|
||||
int main() {
|
||||
Tree *tree =
|
||||
mk_PhrPos(
|
||||
mk_SentV(
|
||||
mk_lie_V(),
|
||||
mk_NumCN(
|
||||
mk_two_Num(),
|
||||
mk_UseN(mk_wife_N())
|
||||
)
|
||||
)
|
||||
);
|
||||
|
||||
int i;
|
||||
|
||||
for (i = 0; i < 1000; i++) {
|
||||
Term *term;
|
||||
term = BronzeageEng_lin(tree);
|
||||
term_print(stdout, term);
|
||||
fputs("\n", stdout);
|
||||
}
|
||||
|
||||
tree_free(tree);
|
||||
|
||||
return 0;
|
||||
}
|
||||
@@ -1,223 +0,0 @@
|
||||
import GFCC.Abs
|
||||
import GFCC.ErrM
|
||||
import GFCC.Lex
|
||||
import GFCC.Par
|
||||
|
||||
import Control.Monad
|
||||
import Data.Char
|
||||
import Data.List
|
||||
import Numeric
|
||||
import System.Environment
|
||||
import System.Exit
|
||||
import System.IO
|
||||
|
||||
constrType :: Grammar -> String
|
||||
constrType g = unlines $
|
||||
["typedef enum { "]
|
||||
++ map (\x -> " " ++ x ++ "," ) ds
|
||||
++ ["} Fun;"]
|
||||
where fs = [id2c n | (n,_) <- constructors g ]
|
||||
ds = case fs of
|
||||
[] -> []
|
||||
(x:xs) -> (x ++ " = ATOM_FIRST_FUN"):xs
|
||||
|
||||
mkFunSigs :: Grammar -> String
|
||||
mkFunSigs g = unlines [mkFunSig n ats | (n,(ats,_)) <- constructors g]
|
||||
|
||||
mkFunSig :: CId -> [CId] -> String
|
||||
mkFunSig n ats =
|
||||
"extern Tree *mk_" ++ id2c n ++ "(" ++ commaSep adecls ++ ");"
|
||||
where
|
||||
adecls = map ("Tree *" ++) args
|
||||
args = [ "x" ++ show x | x <- [0..c-1] ]
|
||||
c = length ats
|
||||
|
||||
mkFuns :: Grammar -> String
|
||||
mkFuns g = unlines [mkFun n ats | (n,(ats,_)) <- constructors g]
|
||||
|
||||
mkFun :: CId -> [CId] -> String
|
||||
mkFun n ats = unlines $
|
||||
["extern Tree *mk_" ++ id2c n ++ "(" ++ commaSep adecls ++ ") {",
|
||||
" Tree *t = tree_fun(" ++ id2c n ++ "," ++ show c ++ ");"]
|
||||
++ [" tree_set_child(" ++ commaSep ["t",show i, args!!i] ++ ");" | i <- [0..c-1]]
|
||||
++ [" return t;",
|
||||
"}"]
|
||||
where
|
||||
adecls = map ("Tree *" ++) args
|
||||
args = [ "x" ++ show x | x <- [0..c-1] ]
|
||||
c = length ats
|
||||
|
||||
doDie :: String -> [String] -> [String]
|
||||
doDie s args = ["fprintf(" ++ commaSep ("stderr":show s':args) ++ ");",
|
||||
"exit(1);"]
|
||||
where s' = "Error: " ++ s ++ "\n"
|
||||
|
||||
mkLin :: Grammar -> CId -> String
|
||||
mkLin g l = unlines $
|
||||
["extern Term *" ++ langLinName_ l ++ "(Tree *t) {",
|
||||
" Term **cs = NULL;",
|
||||
" int n = arity(t);",
|
||||
" if (n > 0) {",
|
||||
" int i;",
|
||||
" cs = (Term**)term_alloc(n * sizeof(Term *));", -- FIXME: handle failure
|
||||
" for (i = 0; i < n; i++) {",
|
||||
" cs[i] = " ++ langLinName_ l ++ "(tree_get_child(t,i));",
|
||||
" }",
|
||||
" }",
|
||||
"",
|
||||
" switch (t->type) {",
|
||||
" case ATOM_STRING: return term_str(t->value.string_value);",
|
||||
-- " case ATOM_INTEGER: return NULL;", -- FIXME!
|
||||
-- " case ATOM_DOUBLE: return NULL;", -- FIXME!
|
||||
" case ATOM_META: return term_meta();"]
|
||||
++ [" case " ++ id2c n ++ ": return " ++ linFunName n ++ "(cs);"
|
||||
| (n,_) <- constructors g]
|
||||
++ [" default: "]
|
||||
++ map (" " ++) (doDie (langLinName_ l ++ " %d") ["t->type"])
|
||||
++ [" return NULL;",
|
||||
" }",
|
||||
"}",
|
||||
"",
|
||||
"extern Term *" ++ langLinName l ++ "(Tree *t) {",
|
||||
" Term *r;",
|
||||
" term_alloc_pool(1000000);", -- FIXME: size?
|
||||
" r = " ++ langLinName_ l ++ "(t);",
|
||||
" /* term_free_pool(); */", -- FIXME: copy term?
|
||||
" return r;",
|
||||
"}"]
|
||||
|
||||
langLinName :: CId -> String
|
||||
langLinName n = id2c n ++ "_lin"
|
||||
|
||||
langLinName_ :: CId -> String
|
||||
langLinName_ n = id2c n ++ "_lin_"
|
||||
|
||||
linFunName :: CId -> String
|
||||
linFunName n = "lin_" ++ id2c n
|
||||
|
||||
|
||||
mkLinFuns :: [CncDef] -> String
|
||||
mkLinFuns cs = unlines $ map mkLinFunSig cs ++ [""] ++ map mkLinFun cs
|
||||
|
||||
mkLinFunSig :: CncDef -> String
|
||||
mkLinFunSig (Lin n t) =
|
||||
"static Term *" ++ linFunName n ++ "(Term **cs);"
|
||||
|
||||
mkLinFun :: CncDef -> String
|
||||
mkLinFun (Lin (CId n) t) | "__" `isPrefixOf` n = ""
|
||||
mkLinFun (Lin n t) = unlines [
|
||||
"static Term *" ++ linFunName n ++ "(Term **cs) {",
|
||||
" return " ++ term2c t ++ ";",
|
||||
"}"
|
||||
]
|
||||
|
||||
term2c :: Tree a -> String
|
||||
term2c t = case t of
|
||||
-- terms
|
||||
R terms -> fun "term_array" terms
|
||||
-- an optimization of t!n where n is a constant int
|
||||
P term0 (C n) -> "term_sel_int("++ term2c term0 ++ "," ++ show n ++ ")"
|
||||
P term0 term1 -> "term_sel(" ++ term2c term0 ++ "," ++ term2c term1 ++ ")"
|
||||
S terms -> fun "term_seq" terms
|
||||
K tokn -> term2c tokn
|
||||
V n -> "cs[" ++ show n ++ "]"
|
||||
C n -> "term_int(" ++ show n ++ ")"
|
||||
F cid -> linFunName cid ++ "(cs)"
|
||||
FV terms -> fun "term_variants" terms
|
||||
W str term -> "term_suffix(" ++ string2c str ++ "," ++ term2c term ++ ")"
|
||||
RP term0 term1 -> "term_rp(" ++ term2c term0 ++ "," ++ term2c term1 ++ ")"
|
||||
TM -> "term_meta()"
|
||||
-- tokens
|
||||
KS s -> "term_str(" ++ string2c s ++ ")"
|
||||
KP strs vars -> error $ show t -- FIXME: pre token
|
||||
_ -> error $ show t
|
||||
where fun f ts = f ++ "(" ++ commaSep (show (length ts):map term2c ts) ++ ")"
|
||||
|
||||
commaSep = concat . intersperse ","
|
||||
|
||||
|
||||
id2c :: CId -> String
|
||||
id2c (CId s) = s -- FIXME: convert ticks
|
||||
|
||||
string2c :: String -> String
|
||||
string2c s = "\"" ++ concatEsc (map esc s) ++ "\""
|
||||
where
|
||||
esc c | isAscii c && isPrint c = [c]
|
||||
esc '\n' = "\\n"
|
||||
esc c = "\\x" ++ map toUpper (showHex (ord c) "")
|
||||
concatEsc [] = ""
|
||||
concatEsc (x:xs) | length x <= 2 = x ++ concatEsc xs
|
||||
| otherwise = x ++ "\" \"" ++ concatEsc xs
|
||||
|
||||
lang2file :: CId -> String -> String
|
||||
lang2file n ext = id2c n ++ "." ++ ext
|
||||
|
||||
constructors :: Grammar -> [(CId, ([CId],CId))]
|
||||
constructors (Grm _ (Abs ads) _) = [(n,(ats,rt)) | Fun n (Typ ats rt) _ <- ads]
|
||||
|
||||
absHFile :: Grammar -> FilePath
|
||||
absHFile (Grm (Hdr a _) _ _) = lang2file a "h"
|
||||
|
||||
cncHFile :: Concrete -> FilePath
|
||||
cncHFile (Cnc l _) = lang2file l "h"
|
||||
|
||||
mkAbsH :: Grammar -> String
|
||||
mkAbsH g = unlines ["#include \"gfcc-tree.h\"",
|
||||
"#include \"gfcc-term.h\"",
|
||||
constrType g,
|
||||
"",
|
||||
mkFunSigs g]
|
||||
|
||||
mkAbsC :: Grammar -> String
|
||||
mkAbsC g = unlines [include (absHFile g),
|
||||
"",
|
||||
mkFuns g]
|
||||
|
||||
mkCncH :: Grammar -> Concrete -> String
|
||||
mkCncH g (Cnc l _) = unlines
|
||||
[include (absHFile g),
|
||||
"",
|
||||
"extern Term *" ++ langLinName l ++ "(Tree *);"]
|
||||
|
||||
mkCncC :: Grammar -> Concrete -> String
|
||||
mkCncC g c@(Cnc l cds) = unlines $
|
||||
["#include <stdio.h>",
|
||||
"#include <stdlib.h>",
|
||||
include (cncHFile c),
|
||||
""]
|
||||
++ [mkLinFuns cds, mkLin g l]
|
||||
|
||||
mkH :: FilePath -> String -> (FilePath, String)
|
||||
mkH f c = (f, c')
|
||||
where c' = unlines ["#ifndef " ++ s, "#define " ++ s, "", c, "#endif"]
|
||||
s = [if x=='.' then '_' else toUpper x | x <- f]
|
||||
|
||||
include :: FilePath -> String
|
||||
include f = "#include " ++ show f
|
||||
|
||||
-- returns list of file name, file contents
|
||||
gfcc2c :: Grammar -> [(FilePath, String)]
|
||||
gfcc2c g@(Grm (Hdr a _) _ cs) =
|
||||
[mkH (absHFile g) (mkAbsH g), (lang2file a "c", mkAbsC g)]
|
||||
++ concat [[mkH (cncHFile cnc) (mkCncH g cnc),(lang2file c "c", mkCncC g cnc)] | cnc@(Cnc c _) <- cs]
|
||||
|
||||
parse :: String -> Err Grammar
|
||||
parse = pGrammar . myLexer
|
||||
|
||||
die :: String -> IO ()
|
||||
die s = do hPutStrLn stderr "Usage: gfcc2c <gfcc file>"
|
||||
exitFailure
|
||||
|
||||
createFile :: FilePath -> String -> IO ()
|
||||
createFile f c = do hPutStrLn stderr $ "Writing " ++ f ++ "..."
|
||||
writeFile f c
|
||||
|
||||
main :: IO ()
|
||||
main = do args <- getArgs
|
||||
case args of
|
||||
[file] -> do c <- readFile file
|
||||
case parse c of
|
||||
Bad err -> die err
|
||||
Ok g -> do let fs = gfcc2c g
|
||||
mapM_ (uncurry createFile) fs
|
||||
_ -> die "Usage: gfcc2c <gfcc file>"
|
||||
@@ -1,49 +0,0 @@
|
||||
|
||||
$infile = $#ARGV >= 0 ? '@'.join('@, @', @ARGV).'@' : '/the input file/';
|
||||
|
||||
print <<EOF;
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : HelpFile
|
||||
-- Maintainer : Aarne Ranta
|
||||
-- Stability : Stable (Autogenerated)
|
||||
-- Portability : Haskell 98
|
||||
--
|
||||
-- > CVS \$Date \$
|
||||
-- > CVS \$Author \$
|
||||
-- > CVS \$Revision \$
|
||||
--
|
||||
-- Help on shell commands. Generated from $infile by invoking the
|
||||
-- perl script \@mkHelpFile.perl\@.
|
||||
-- Automatically generated -- PLEASE DON'T EDIT THIS FILE,
|
||||
-- edit $infile instead.
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module HelpFile (txtHelpFileSummary, txtHelpCommand, txtHelpFile) where
|
||||
|
||||
import Operations
|
||||
|
||||
txtHelpFileSummary :: String
|
||||
txtHelpFileSummary =
|
||||
unlines \$ map (concat . take 1 . lines) \$ paragraphs txtHelpFile
|
||||
|
||||
txtHelpCommand :: String -> String
|
||||
txtHelpCommand c =
|
||||
case lookup c [(takeWhile (/=',') p,p) | p <- paragraphs txtHelpFile] of
|
||||
Just s -> s
|
||||
_ -> "Command not found."
|
||||
|
||||
txtHelpFile :: String
|
||||
txtHelpFile =
|
||||
EOF
|
||||
|
||||
while (<>) {
|
||||
chop;
|
||||
s/([\"\\])/\\$1/g;
|
||||
$pref = /^ / ? "\\n" : "\\n";
|
||||
print " \"$pref$_\" ++\n";
|
||||
}
|
||||
|
||||
print " []\n";
|
||||
|
||||
|
||||
Reference in New Issue
Block a user