blob: 4a44ac58618a26f2547847bada5ff11364f7f992 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
|
----------------------------------------------------------------------
-- |
-- Module : GFCCAPI
-- Maintainer : Aarne Ranta
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date:
-- > CVS $Author:
-- > CVS $Revision:
--
-- Reduced Application Programmer's Interface to GF, meant for
-- embedded GF systems. AR 19/9/2007
-----------------------------------------------------------------------------
module PGF where
import PGF.CId
import PGF.Linearize
import PGF.Generate
import PGF.Macros
import PGF.Data
import PGF.Raw.Convert
import PGF.Raw.Parse
import PGF.Parsing.FCFG
import GF.Data.ErrM
import Data.Char
import qualified Data.Map as Map
import Control.Monad
import System.Random (newStdGen)
import System.Directory (doesFileExist)
import qualified Text.PrettyPrint as PP
import qualified Text.ParserCombinators.ReadP as RP
-- This API is meant to be used when embedding GF grammars in Haskell
-- programs. The embedded system is supposed to use the
-- .gfcc grammar format, which is first produced by the gf program.
---------------------------------------------------
-- Interface
---------------------------------------------------
data MultiGrammar = MultiGrammar {gfcc :: GFCC}
type Language = String
type Category = String
type Tree = Exp
file2grammar :: FilePath -> IO MultiGrammar
linearize :: MultiGrammar -> Language -> Tree -> String
parse :: MultiGrammar -> Language -> Category -> String -> [Tree]
linearizeAll :: MultiGrammar -> Tree -> [String]
linearizeAllLang :: MultiGrammar -> Tree -> [(Language,String)]
parseAll :: MultiGrammar -> Category -> String -> [[Tree]]
parseAllLang :: MultiGrammar -> Category -> String -> [(Language,[Tree])]
generateAll :: MultiGrammar -> Category -> [Tree]
generateRandom :: MultiGrammar -> Category -> IO [Tree]
generateAllDepth :: MultiGrammar -> Category -> Maybe Int -> [Tree]
readTree :: String -> Tree
showTree :: Tree -> String
languages :: MultiGrammar -> [Language]
categories :: MultiGrammar -> [Category]
startCat :: MultiGrammar -> Category
---------------------------------------------------
-- Implementation
---------------------------------------------------
file2grammar f = do
gfcc <- file2gfcc f
return (MultiGrammar gfcc)
file2gfcc f = do
s <- readFileIf f
g <- parseGrammar s
return $ toGFCC g
linearize mgr lang = PGF.Linearize.linearize (gfcc mgr) (mkCId lang)
parse mgr lang cat s =
case lookParser (gfcc mgr) (mkCId lang) of
Nothing -> error "no parser"
Just pinfo -> case parseFCF "bottomup" pinfo (mkCId cat) (words s) of
Ok x -> x
Bad s -> error s
linearizeAll mgr = map snd . linearizeAllLang mgr
linearizeAllLang mgr t =
[(lang,PGF.linearize mgr lang t) | lang <- languages mgr]
parseAll mgr cat = map snd . parseAllLang mgr cat
parseAllLang mgr cat s =
[(lang,ts) | lang <- languages mgr, let ts = parse mgr lang cat s, not (null ts)]
generateRandom mgr cat = do
gen <- newStdGen
return $ genRandom gen (gfcc mgr) (mkCId cat)
generateAll mgr cat = generate (gfcc mgr) (mkCId cat) Nothing
generateAllDepth mgr cat = generate (gfcc mgr) (mkCId cat)
readTree s = case RP.readP_to_S (pExp 0) s of
[(x,"")] -> x
_ -> error "no parse"
pExps :: RP.ReadP [Exp]
pExps = liftM2 (:) (pExp 1) pExps RP.<++ (RP.skipSpaces >> return [])
pExp :: Int -> RP.ReadP Exp
pExp n = RP.skipSpaces >> (pParen RP.<++ pApp RP.<++ pNum RP.<++ pStr RP.<++ pMeta)
where
pParen = RP.between (RP.char '(') (RP.char ')') (pExp 0)
pApp = do xs <- RP.option [] (RP.between (RP.char '\\') (RP.string "->") (RP.sepBy1 pIdent (RP.char ',')))
f <- pIdent
ts <- (if n == 0 then pExps else return [])
return (DTr xs (AC f) ts)
pStr = RP.char '"' >> liftM (\s -> DTr [] (AS s) []) (RP.manyTill (pEsc RP.<++ RP.get) (RP.char '"'))
pEsc = RP.char '\\' >> RP.get
pNum = do x <- RP.munch1 isDigit
((RP.char '.' >> RP.munch1 isDigit >>= \y -> return (DTr [] (AF (read (x++"."++y))) []))
RP.<++
(return (DTr [] (AI (read x)) [])))
pMeta = do RP.char '?'
x <- RP.munch1 isDigit
return (DTr [] (AM (read x)) [])
pIdent = fmap mkCId (liftM2 (:) (RP.satisfy isIdentFirst) (RP.munch isIdentRest))
isIdentFirst c = c == '_' || isLetter c
isIdentRest c = c == '_' || c == '\'' || isAlphaNum c
showTree = PP.render . ppExp False
ppExp isNested (DTr [] at []) = ppAtom at
ppExp isNested (DTr xs at ts) = ppParens isNested (ppLambdas xs PP.<+> ppAtom at PP.<+> PP.hsep (map (ppExp True) ts))
where
ppLambdas [] = PP.empty
ppLambdas xs = PP.char '\\' PP.<>
PP.hsep (PP.punctuate PP.comma (map (PP.text . prCId) xs)) PP.<+>
PP.text "->"
ppParens True = PP.parens
ppParens False = id
ppAtom (AC id) = PP.text (prCId id)
ppAtom (AS s) = PP.text (show s)
ppAtom (AI n) = PP.integer n
ppAtom (AF d) = PP.double d
ppAtom (AM n) = PP.char '?' PP.<> PP.integer n
ppAtom (AV id) = PP.text (prCId id)
abstractName mgr = prCId (absname (gfcc mgr))
languages mgr = [prCId l | l <- cncnames (gfcc mgr)]
categories mgr = [prCId c | c <- Map.keys (cats (abstract (gfcc mgr)))]
startCat mgr = lookStartCat (gfcc mgr)
emptyMultiGrammar = MultiGrammar emptyGFCC
------------ for internal use only
err f g ex = case ex of
Ok x -> g x
Bad s -> f s
readFileIf f = do
b <- doesFileExist f
if b then readFile f
else putStrLn ("file " ++ f ++ " not found") >> return ""
|
