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
|
-- | Read PGF files created with GF 3.5 and a few older releases
module PGF.OldBinary(getPGF,getPGF',version) where
import PGF.CId
import PGF.Data
import PGF.Optimize
import Data.Binary
import Data.Binary.Get
import Data.Array.IArray
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import qualified Data.Set as Set
import Control.Monad
pgfMajorVersion, pgfMinorVersion :: Word16
version@(pgfMajorVersion, pgfMinorVersion) = (1,0)
getPGF = do v1 <- getWord16be
v2 <- getWord16be
let v=(v1,v2)
if v==version
then getPGF'
else decodingError ("version "++show v++"/="++show version)
getPGF'=do gflags <- getFlags
absname <- getCId
abstract <- getAbstract
concretes <- getMap getCId getConcr
return $ updateProductionIndices $
(PGF{ gflags=gflags
, absname=absname, abstract=abstract
, concretes=concretes
})
getCId = liftM CId get
getAbstract =
do aflags <- getFlags
funs <- getMap getCId getFun
cats <- getMap getCId getCat
return (Abstr{ aflags=aflags
, funs=fmap (\(w,x,y,z) -> (w,x,fmap (flip (,) []) y,z)) funs
, cats=fmap (\(x,y) -> (x,y,0)) cats
})
getFun :: Get (Type,Int,Maybe [Equation],Double)
getFun = (,,,) `fmap` getType `ap` get `ap` getMaybe (getList getEquation) `ap` get
getCat :: Get ([Hypo],[(Double, CId)])
getCat = getPair (getList getHypo) (getList (getPair get getCId))
getFlags = getMap getCId getLiteral
getConcr =
do cflags <- getFlags
printnames <- getMap getCId get
(scnt,seqs) <- getList' getSequence
(fcnt,cncfuns) <- getList' getCncFun
lindefs <- get
productions <- getIntMap (getSet getProduction)
cnccats <- getMap getCId getCncCat
totalCats <- get
let rseq = listToArray [SymCat 0 0]
rfun = CncFun (mkCId "linref") (listToArray [scnt])
linrefs = IntMap.fromList [(i,[fcnt])|i<-[0..totalCats-1]]
return (Concr{ cflags=cflags, printnames=printnames
, sequences=toArray (scnt+1,seqs++[rseq])
, cncfuns=toArray (fcnt+1,cncfuns++[rfun])
, lindefs=lindefs, linrefs=linrefs
, productions=productions
, pproductions = IntMap.empty
, lproductions = Map.empty
, lexicon = IntMap.empty
, cnccats=cnccats, totalCats=totalCats
})
getExpr =
do tag <- getWord8
case tag of
0 -> liftM3 EAbs getBindType getCId getExpr
1 -> liftM2 EApp getExpr getExpr
2 -> liftM ELit getLiteral
3 -> liftM EMeta get
4 -> liftM EFun getCId
5 -> liftM EVar get
6 -> liftM2 ETyped getExpr getType
7 -> liftM EImplArg getExpr
_ -> decodingError "getExpr"
getPatt =
do tag <- getWord8
case tag of
0 -> liftM2 PApp getCId (getList getPatt)
1 -> liftM PVar getCId
2 -> liftM2 PAs getCId getPatt
3 -> return PWild
4 -> liftM PLit getLiteral
5 -> liftM PImplArg getPatt
6 -> liftM PTilde getExpr
_ -> decodingError "getPatt"
getEquation = liftM2 Equ (getList getPatt) getExpr
getType = liftM3 DTyp (getList getHypo) getCId (getList getExpr)
getHypo = (,,) `fmap` getBindType `ap` getCId `ap` getType
getBindType =
do tag <- getWord8
case tag of
0 -> return Explicit
1 -> return Implicit
_ -> decodingError "getBindType"
getCncFun = liftM2 CncFun getCId (getArray get)
getCncCat = liftM3 CncCat get get (getArray get)
getSequence = listToArray `fmap` getSymbols
getSymbols = concat `fmap` getList getSymbol
getSymbol :: Get [Symbol]
getSymbol =
do tag <- getWord8
case tag of
0 -> (:[]) `fmap` liftM2 SymCat get get
1 -> (:[]) `fmap` liftM2 SymLit get get
2 -> (:[]) `fmap` liftM2 SymVar get get
3 -> liftM (map SymKS) get
4 -> (:[]) `fmap` liftM2 SymKP (getList getTokenSymbol) getAlternatives
_ -> decodingError ("getSymbol "++show tag)
getAlternatives = getList (getPair (getList getTokenSymbol) get)
:: Get [([Symbol],[String])]
getTokenSymbol = fmap SymKS get
--getTokens = unwords `fmap` get
getPArg = get >>= \(hypos,fid) -> return (PArg (zip (repeat fidVar) hypos) fid)
getProduction =
do tag <- getWord8
case tag of
0 -> liftM2 PApply get (getList getPArg)
1 -> liftM PCoerce get
_ -> decodingError "getProduction"
getLiteral =
do tag <- getWord8
case tag of
0 -> liftM LStr get
1 -> liftM LInt get
2 -> liftM LFlt get
_ -> decodingError "getLiteral"
getArray :: IArray a e => Get e -> Get (a Int e)
getArray get1 = toArray `fmap` getList' get1
toArray (n,xs) = listArray (0::Int,n-1) xs
listToArray xs = toArray (length xs,xs)
--getArray2 :: (IArray a1 (a2 Int e), IArray a2 e) => Get e -> Get (a1 Int (a2 Int e))
--getArray2 get1 = getArray (getArray get1)
getList get1 = snd `fmap` getList' get1
getList' get1 = do n <- get :: Get Int
xs <- replicateM n get1
return (n,xs)
getMaybe get1 =
do isJust <- get
if isJust then fmap Just get1 else return Nothing
getMap getK getV = Map.fromDistinctAscList `fmap` getList (getPair getK getV)
getIntMap getV = IntMap.fromDistinctAscList `fmap` getList (getPair get getV)
getSet getV = Set.fromDistinctAscList `fmap` getList getV
getPair get1 get2 = (,) `fmap` get1 `ap` get2
decodingError explain = fail $ "Unable to read PGF file ("++explain++")"
|
