mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
Merge branch 'master' of https://github.com/GrammaticalFramework/gf-core
This commit is contained in:
krangelov
12
debian/changelog
vendored
12
debian/changelog
vendored
@@ -1,3 +1,15 @@
|
||||
gf (3.10.3-1) xenial bionic cosmic; urgency=low
|
||||
|
||||
* GF 3.10.3
|
||||
|
||||
-- Thomas Hallgren <hallgren@chalmers.se> Fri, 5 Mar 2019 19:30:00 +0100
|
||||
|
||||
gf (3.10-2) xenial bionic cosmic; urgency=low
|
||||
|
||||
* GF 3.10
|
||||
|
||||
-- Thomas Hallgren <hallgren@chalmers.se> Fri, 5 Mar 2019 16:00:00 +0100
|
||||
|
||||
gf (3.10-1) xenial bionic cosmic; urgency=low
|
||||
|
||||
* GF 3.10
|
||||
|
||||
35
debian/rules
vendored
35
debian/rules
vendored
@@ -13,21 +13,6 @@
|
||||
override_dh_shlibdeps:
|
||||
dh_shlibdeps --dpkg-shlibdeps-params=--ignore-missing-info
|
||||
|
||||
override_dh_auto_build:
|
||||
cd src/runtime/python && EXTRA_INCLUDE_DIRS=$(CURDIR)/src/runtime/c EXTRA_LIB_DIRS=$(CURDIR)/src/runtime/c/.libs python setup.py build
|
||||
cd src/runtime/java && make CFLAGS="-I$(CURDIR)/src/runtime/c -L$(CURDIR)/src/runtime/c/.libs" INSTALL_PATH=/usr/lib
|
||||
echo LD_LIBRARY_PATH=$$LD_LIBRARY_PATH:$(CURDIR)/src/runtime/c/.libs
|
||||
LD_LIBRARY_PATH=$$LD_LIBRARY_PATH:$(CURDIR)/src/runtime/c/.libs cabal build
|
||||
LD_LIBRARY_PATH=$$LD_LIBRARY_PATH:$(CURDIR)/src/runtime/c/.libs cabal copy --destdir=$(CURDIR)/debian/gf # create www directory
|
||||
PATH=$(CURDIR)/dist/build/gf:$$PATH && export GF_LIB_PATH="$$(dirname $$(find "$(CURDIR)/debian/gf" -name www))/lib" && echo "GF_LIB_PATH=$$GF_LIB_PATH" && mkdir -p "$$GF_LIB_PATH" && ( cd ../gf-rgl && make build && make copy ) && LD_LIBRARY_PATH=$$LD_LIBRARY_PATH:$(CURDIR)/src/runtime/c/.libs cabal build
|
||||
make html
|
||||
|
||||
override_dh_auto_clean:
|
||||
rm -fr dist/build
|
||||
-cd src/runtime/python && rm -fr build
|
||||
-cd src/runtime/java && make clean
|
||||
-cd src/runtime/c && make clean
|
||||
|
||||
override_dh_auto_configure:
|
||||
cd src/runtime/c && bash setup.sh configure --prefix=/usr
|
||||
cd src/runtime/c && bash setup.sh build
|
||||
@@ -35,13 +20,31 @@ override_dh_auto_configure:
|
||||
cabal install --only-dependencies
|
||||
cabal configure --prefix=/usr -fserver -fc-runtime --extra-lib-dirs=$(CURDIR)/src/runtime/c/.libs --extra-include-dirs=$(CURDIR)/src/runtime/c
|
||||
|
||||
SET_LDL=LD_LIBRARY_PATH=$$LD_LIBRARY_PATH:$(CURDIR)/src/runtime/c/.libs
|
||||
|
||||
override_dh_auto_build:
|
||||
cd src/runtime/python && EXTRA_INCLUDE_DIRS=$(CURDIR)/src/runtime/c EXTRA_LIB_DIRS=$(CURDIR)/src/runtime/c/.libs python setup.py build
|
||||
cd src/runtime/java && make CFLAGS="-I$(CURDIR)/src/runtime/c -L$(CURDIR)/src/runtime/c/.libs" INSTALL_PATH=/usr/lib
|
||||
echo $(SET_LDL)
|
||||
$(SET_LDL) cabal build # builds gf, fails to build example grammars
|
||||
PATH=$(CURDIR)/dist/build/gf:$$PATH && make -C ../gf-rgl build
|
||||
GF_LIB_PATH=$(CURDIR)/../gf-rgl/dist $(SET_LDL) cabal build # have RGL now, ok to build example grammars
|
||||
make html
|
||||
|
||||
override_dh_auto_install:
|
||||
LD_LIBRARY_PATH=$$LD_LIBRARY_PATH:$(CURDIR)/src/runtime/c/.libs cabal copy --destdir=$(CURDIR)/debian/gf
|
||||
$(SET_LDL) cabal copy --destdir=$(CURDIR)/debian/gf # creates www directory
|
||||
export GF_LIB_PATH="$$(dirname $$(find "$(CURDIR)/debian/gf" -name www))/lib" && echo "GF_LIB_PATH=$$GF_LIB_PATH" && mkdir -p "$$GF_LIB_PATH" && make -C ../gf-rgl copy
|
||||
cd src/runtime/c && bash setup.sh copy prefix=$(CURDIR)/debian/gf/usr
|
||||
cd src/runtime/python && python setup.py install --prefix=$(CURDIR)/debian/gf/usr
|
||||
cd src/runtime/java && make INSTALL_PATH=$(CURDIR)/debian/gf/usr/lib install
|
||||
D="`find debian/gf -name site-packages`" && [ -n "$$D" ] && cd $$D && cd .. && mv site-packages dist-packages
|
||||
|
||||
override_dh_auto_clean:
|
||||
rm -fr dist/build
|
||||
-cd src/runtime/python && rm -fr build
|
||||
-cd src/runtime/java && make clean
|
||||
-cd src/runtime/c && make clean
|
||||
|
||||
override_dh_auto_test:
|
||||
ifneq (nocheck,$(filter nocheck,$(DEB_BUILD_OPTIONS)))
|
||||
true
|
||||
|
||||
@@ -13,8 +13,8 @@ These binary packages include both the GF core (compiler and runtime) as well as
|
||||
| Platform | Download | Features | How to install |
|
||||
|:----------------|:---------------------------------------------------|:---------------|:-----------------------------------|
|
||||
| macOS | [gf-3.10.pkg](gf-3.10.pkg) | GF, S, C, J, P | Double-click on the package icon |
|
||||
| Ubuntu (32-bit) | [gf\_3.10-1\_i386.deb](gf_3.10-1_i386.deb) | GF, S, C, J, P | `sudo dpkg -i gf_3.10-1_i386.deb` |
|
||||
| Ubuntu (64-bit) | [gf\_3.10-1\_amd64.deb](gf_3.10-1_amd64.deb) | GF, S, C, J, P | `sudo dpkg -i gf_3.10-1_amd64.deb` |
|
||||
| Ubuntu (32-bit) | [gf\_3.10-2\_i386.deb](gf_3.10-2_i386.deb) | GF, S, C, J, P | `sudo dpkg -i gf_3.10-2_i386.deb` |
|
||||
| Ubuntu (64-bit) | [gf\_3.10-2\_amd64.deb](gf_3.10-2_amd64.deb) | GF, S, C, J, P | `sudo dpkg -i gf_3.10-2_amd64.deb` |
|
||||
| Windows | [gf-3.10-bin-windows.zip](gf-3.10-bin-windows.zip) | GF, S | `unzip gf-3.10-bin-windows.zip` |
|
||||
|
||||
<!--
|
||||
@@ -36,7 +36,10 @@ probably need to set the `PATH` and `GF_LIB_PATH` environment variables,
|
||||
see Inari's notes on [Installing GF on Windows](http://www.grammaticalframework.org/~inari/gf-windows.html#toc3).
|
||||
|
||||
The Ubuntu `.deb` packages should work on Ubuntu 16.04 and 18.04 and
|
||||
similar Linux distributions.
|
||||
similar Linux distributions. The `.deb` packages were updated
|
||||
to version 3.10-2 after the release of GF 3.10.
|
||||
(Because of a packaging bug the Resource Grammar Library was missing
|
||||
in the 3.10-1 packages.)
|
||||
|
||||
<!-- The Raspbian `.deb` package was created on a Raspberry Pi 3 and will
|
||||
probably work on other ARM-based systems running Debian 9 (stretch) or
|
||||
|
||||
6
gf.cabal
6
gf.cabal
@@ -1,5 +1,5 @@
|
||||
name: gf
|
||||
version: 3.10
|
||||
version: 3.10.3-git
|
||||
|
||||
cabal-version: >= 1.22
|
||||
build-type: Custom
|
||||
@@ -151,6 +151,7 @@ Library
|
||||
GF.Support
|
||||
GF.Text.Pretty
|
||||
GF.Text.Lexing
|
||||
GF.Grammar.Canonical
|
||||
|
||||
other-modules:
|
||||
GF.Main GF.Compiler GF.Interactive
|
||||
@@ -189,8 +190,7 @@ Library
|
||||
GF.Compile.PGFtoJava
|
||||
GF.Haskell
|
||||
GF.Compile.ConcreteToHaskell
|
||||
GF.Compile.ConcreteToCanonical
|
||||
GF.Grammar.Canonical
|
||||
GF.Compile.GrammarToCanonical
|
||||
GF.Grammar.CanonicalJSON
|
||||
GF.Compile.PGFtoJS
|
||||
GF.Compile.PGFtoProlog
|
||||
|
||||
@@ -19,7 +19,9 @@ module GF(
|
||||
module GF.Grammar.Printer,
|
||||
module GF.Infra.Ident,
|
||||
-- ** Binary serialisation
|
||||
module GF.Grammar.Binary
|
||||
module GF.Grammar.Binary,
|
||||
-- * Canonical GF
|
||||
module GF.Compile.GrammarToCanonical
|
||||
) where
|
||||
import GF.Main
|
||||
import GF.Compiler
|
||||
@@ -36,3 +38,5 @@ import GF.Grammar.Macros
|
||||
import GF.Grammar.Printer
|
||||
import GF.Infra.Ident
|
||||
import GF.Grammar.Binary
|
||||
|
||||
import GF.Compile.GrammarToCanonical
|
||||
|
||||
@@ -11,7 +11,7 @@ import GF.Infra.Ident(Ident,identS,identW,prefixIdent)
|
||||
import GF.Infra.Option
|
||||
import GF.Haskell as H
|
||||
import GF.Grammar.Canonical as C
|
||||
import GF.Compile.ConcreteToCanonical
|
||||
import GF.Compile.GrammarToCanonical
|
||||
import Debug.Trace(trace)
|
||||
|
||||
-- | Generate Haskell code for the all concrete syntaxes associated with
|
||||
@@ -142,8 +142,8 @@ concrete2haskell opts
|
||||
rhs = lets (zipWith letlin args absctx)
|
||||
(convert vs (coerce env lincat rhs0))
|
||||
where
|
||||
vs = [(VarValueId x,a)|(VarId x,a)<-zip xs args]
|
||||
env= [(VarValueId x,lc)|(VarId x,lc)<-zip xs (map arglincat absctx)]
|
||||
vs = [(VarValueId (Unqual x),a)|(VarId x,a)<-zip xs args]
|
||||
env= [(VarValueId (Unqual x),lc)|(VarId x,lc)<-zip xs (map arglincat absctx)]
|
||||
|
||||
letlin a (TypeBinding _ (C.Type _ (TypeApp acat _))) =
|
||||
(a,Ap (Var (linfunName acat)) (Var (abs_arg a)))
|
||||
@@ -173,15 +173,20 @@ concrete2haskell opts
|
||||
VariantValue [] -> empty
|
||||
VariantValue ts@(_:_) -> variants ts
|
||||
VarValue x -> maybe (Var (gId x)) (pure . Var) $ lookup x vs
|
||||
IntConstant n -> pure (lit n)
|
||||
StrConstant s -> pure (token s)
|
||||
PreValue vs t' -> pure (alts t' vs)
|
||||
ParamConstant (Param c vs) -> aps (Var (pId c)) (map ppT vs)
|
||||
ErrorValue s -> ap (Const "error") (Const (show s)) -- !!
|
||||
LiteralValue l -> ppL l
|
||||
_ -> error ("convert "++show t)
|
||||
|
||||
ppL l =
|
||||
case l of
|
||||
FloatConstant x -> pure (lit x)
|
||||
IntConstant n -> pure (lit n)
|
||||
StrConstant s -> pure (token s)
|
||||
|
||||
pId p@(ParamId s) =
|
||||
if "to_R_" `isPrefixOf` s then toIdent p else gId p -- !! a hack
|
||||
if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack
|
||||
|
||||
table cs =
|
||||
if all (null.patVars) ps
|
||||
@@ -189,8 +194,8 @@ concrete2haskell opts
|
||||
else LambdaCase (map ppCase cs)
|
||||
where
|
||||
(ds,ts') = dedup ts
|
||||
(ps,ts) = unzip [(p,t)|TableRowValue p t<-cs]
|
||||
ppCase (TableRowValue p t) = (ppP p,ppTv (patVars p++vs) t)
|
||||
(ps,ts) = unzip [(p,t)|TableRow p t<-cs]
|
||||
ppCase (TableRow p t) = (ppP p,ppTv (patVars p++vs) t)
|
||||
{-
|
||||
ppPredef n =
|
||||
case predef n of
|
||||
@@ -304,8 +309,8 @@ instance Records LinValue where
|
||||
Selection v1 v2 -> records (v1,v2)
|
||||
_ -> S.empty
|
||||
|
||||
instance Records TableRowValue where
|
||||
records (TableRowValue _ v) = records v
|
||||
instance Records rhs => Records (TableRow rhs) where
|
||||
records (TableRow _ v) = records v
|
||||
|
||||
|
||||
-- | Record subtyping is converted into explicit coercions in Haskell
|
||||
@@ -313,7 +318,7 @@ coerce env ty t =
|
||||
case (ty,t) of
|
||||
(_,VariantValue ts) -> VariantValue (map (coerce env ty) ts)
|
||||
(TableType ti tv,TableValue _ cs) ->
|
||||
TableValue ti [TableRowValue p (coerce env tv t)|TableRowValue p t<-cs]
|
||||
TableValue ti [TableRow p (coerce env tv t)|TableRow p t<-cs]
|
||||
(RecordType rt,RecordValue r) ->
|
||||
RecordValue [RecordRow l (coerce env ft f) |
|
||||
RecordRow l f<-r,ft<-[ft|RecordRow l' ft<-rt,l'==l]]
|
||||
@@ -329,7 +334,7 @@ coerce env ty t =
|
||||
_ -> t
|
||||
where
|
||||
app f ts = ParamConstant (Param f ts) -- !! a hack
|
||||
to_rcon = ParamId . to_rcon' . labels
|
||||
to_rcon = ParamId . Unqual . to_rcon' . labels
|
||||
|
||||
patVars p = []
|
||||
|
||||
@@ -395,11 +400,16 @@ linfunName c = prefixIdent "lin" (toIdent c)
|
||||
|
||||
class ToIdent i where toIdent :: i -> Ident
|
||||
|
||||
instance ToIdent ParamId where toIdent (ParamId s) = identS s
|
||||
instance ToIdent ParamId where toIdent (ParamId q) = qIdentS q
|
||||
instance ToIdent PredefId where toIdent (PredefId s) = identS s
|
||||
instance ToIdent CatId where toIdent (CatId s) = identS s
|
||||
instance ToIdent C.FunId where toIdent (FunId s) = identS s
|
||||
instance ToIdent VarValueId where toIdent (VarValueId s) = identS s
|
||||
instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentS q
|
||||
|
||||
qIdentS = identS . unqual
|
||||
|
||||
unqual (Qual (ModId m) n) = m++"_"++n
|
||||
unqual (Unqual n) = n
|
||||
|
||||
instance ToIdent VarId where
|
||||
toIdent Anonymous = identW
|
||||
|
||||
@@ -1,6 +1,6 @@
|
||||
-- | Translate grammars to Canonical form
|
||||
-- (a common intermediate representation to simplify export to other formats)
|
||||
module GF.Compile.ConcreteToCanonical(grammar2canonical,abstract2canonical,concretes2canonical) where
|
||||
module GF.Compile.GrammarToCanonical(grammar2canonical,abstract2canonical,concretes2canonical) where
|
||||
import Data.List(nub,partition)
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as S
|
||||
@@ -55,7 +55,7 @@ abstract2canonical absname gr =
|
||||
-- | Generate Canonical code for the all concrete syntaxes associated with
|
||||
-- the named abstract syntax in given the grammar.
|
||||
concretes2canonical opts absname gr =
|
||||
[(cncname,concrete2canonical opts gr cenv absname cnc cncmod)
|
||||
[(cncname,concrete2canonical gr cenv absname cnc cncmod)
|
||||
| let cenv = resourceValues opts gr,
|
||||
cnc<-allConcretes gr absname,
|
||||
let cncname = "canonical/"++render cnc ++ ".gf" :: FilePath
|
||||
@@ -63,9 +63,7 @@ concretes2canonical opts absname gr =
|
||||
]
|
||||
|
||||
-- | Generate Canonical GF for the given concrete module.
|
||||
-- The only options that make a difference are
|
||||
-- @-haskell=noprefix@ and @-haskell=variants@.
|
||||
concrete2canonical opts gr cenv absname cnc modinfo =
|
||||
concrete2canonical gr cenv absname cnc modinfo =
|
||||
Concrete (modId cnc) (modId absname) (convFlags gr cnc)
|
||||
(neededParamTypes S.empty (params defs))
|
||||
[lincat|(_,Left lincat)<-defs]
|
||||
@@ -153,7 +151,7 @@ convert' gr vs = ppT
|
||||
case t of
|
||||
-- Abs b x t -> ...
|
||||
-- V ty ts -> VTableValue (convType ty) (map ppT ts)
|
||||
V ty ts -> TableValue (convType ty) [TableRowValue (ppP p) (ppT t)|(p,t)<-zip ps ts]
|
||||
V ty ts -> TableValue (convType ty) [TableRow (ppP p) (ppT t)|(p,t)<-zip ps ts]
|
||||
where
|
||||
Ok pts = allParamValues gr ty
|
||||
Ok ps = mapM term2patt pts
|
||||
@@ -167,16 +165,16 @@ convert' gr vs = ppT
|
||||
Cn x -> VarValue (gId x) -- hmm
|
||||
Con c -> ParamConstant (Param (gId c) [])
|
||||
Sort k -> VarValue (gId k)
|
||||
EInt n -> IntConstant n
|
||||
Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gId (qual m n))
|
||||
QC (m,n) -> ParamConstant (Param (gId (qual m n)) [])
|
||||
K s -> StrConstant s
|
||||
Empty -> StrConstant ""
|
||||
EInt n -> LiteralValue (IntConstant n)
|
||||
Q (m,n) -> if m==cPredef then ppPredef n else VarValue ((gQId m n))
|
||||
QC (m,n) -> ParamConstant (Param ((gQId m n)) [])
|
||||
K s -> LiteralValue (StrConstant s)
|
||||
Empty -> LiteralValue (StrConstant "")
|
||||
FV ts -> VariantValue (map ppT ts)
|
||||
Alts t' vs -> alts vs (ppT t')
|
||||
_ -> error $ "convert' "++show t
|
||||
|
||||
ppCase (p,t) = TableRowValue (ppP p) (ppTv (patVars p++vs) t)
|
||||
ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t)
|
||||
|
||||
ppPredef n =
|
||||
case predef n of
|
||||
@@ -185,14 +183,14 @@ convert' gr vs = ppT
|
||||
Ok SOFT_SPACE -> p "SOFT_SPACE"
|
||||
Ok CAPIT -> p "CAPIT"
|
||||
Ok ALL_CAPIT -> p "ALL_CAPIT"
|
||||
_ -> VarValue (gId n)
|
||||
_ -> VarValue (gQId cPredef n) -- hmm
|
||||
where
|
||||
p = PredefValue . PredefId
|
||||
|
||||
ppP p =
|
||||
case p of
|
||||
PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
|
||||
PP (m,c) ps -> ParamPattern (Param (gId (qual m c)) (map ppP ps))
|
||||
PP (m,c) ps -> ParamPattern (Param ((gQId m c)) (map ppP ps))
|
||||
PR r -> RecordPattern (fields r) {-
|
||||
PW -> WildPattern
|
||||
PV x -> VarP x
|
||||
@@ -220,6 +218,7 @@ convert' gr vs = ppT
|
||||
|
||||
pat (PString s) = [s]
|
||||
pat (PAlt p1 p2) = pat p1++pat p2
|
||||
pat (PSeq p1 p2) = [s1++s2 | s1<-pat p1, s2<-pat p2]
|
||||
pat p = error $ "pat "++show p
|
||||
|
||||
fields = map field . filter (not.isLockLabel.fst)
|
||||
@@ -235,8 +234,8 @@ convert' gr vs = ppT
|
||||
|
||||
concatValue v1 v2 =
|
||||
case (v1,v2) of
|
||||
(StrConstant "",_) -> v2
|
||||
(_,StrConstant "") -> v1
|
||||
(LiteralValue (StrConstant ""),_) -> v2
|
||||
(_,LiteralValue (StrConstant "")) -> v1
|
||||
_ -> ConcatValue v1 v2
|
||||
|
||||
projection r l = maybe (Projection r l) id (proj r l)
|
||||
@@ -251,19 +250,19 @@ proj r l =
|
||||
selection t v =
|
||||
case t of
|
||||
TableValue tt r ->
|
||||
case nub [rv|TableRowValue _ rv<-keep] of
|
||||
case nub [rv|TableRow _ rv<-keep] of
|
||||
[rv] -> rv
|
||||
_ -> Selection (TableValue tt r') v
|
||||
where
|
||||
r' = if null discard
|
||||
then r
|
||||
else keep++[TableRowValue WildPattern impossible]
|
||||
else keep++[TableRow WildPattern impossible]
|
||||
(keep,discard) = partition (mightMatchRow v) r
|
||||
_ -> Selection t v
|
||||
|
||||
impossible = ErrorValue "impossible"
|
||||
|
||||
mightMatchRow v (TableRowValue p _) =
|
||||
mightMatchRow v (TableRow p _) =
|
||||
case p of
|
||||
WildPattern -> True
|
||||
_ -> mightMatch v p
|
||||
@@ -300,8 +299,8 @@ convType = ppT
|
||||
Sort k -> convSort k
|
||||
-- EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal
|
||||
FV (t:ts) -> ppT t -- !!
|
||||
QC (m,n) -> ParamType (ParamTypeId (gId (qual m n)))
|
||||
Q (m,n) -> ParamType (ParamTypeId (gId (qual m n)))
|
||||
QC (m,n) -> ParamType (ParamTypeId ((gQId m n)))
|
||||
Q (m,n) -> ParamType (ParamTypeId ((gQId m n)))
|
||||
_ -> error $ "Missing case in convType for: "++show t
|
||||
|
||||
convFields = map convField . filter (not.isLockLabel.fst)
|
||||
@@ -327,25 +326,21 @@ paramType gr q@(_,n) =
|
||||
((S.singleton (m,n),argTypes ps),
|
||||
[ParamDef name (map (param m) ps)]
|
||||
)
|
||||
where name = gId (qual m n)
|
||||
where name = (gQId m n)
|
||||
Ok (m,ResOper _ (Just (L _ t)))
|
||||
| m==cPredef && n==cInts ->
|
||||
((S.empty,S.empty),[]) {-
|
||||
((S.singleton (m,n),S.empty),
|
||||
[Type (ConAp (gId (qual m n)) [identS "n"]) (TId (identS "Int"))])-}
|
||||
[Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-}
|
||||
| otherwise ->
|
||||
((S.singleton (m,n),paramTypes gr t),
|
||||
[ParamAliasDef (gId (qual m n)) (convType t)])
|
||||
[ParamAliasDef ((gQId m n)) (convType t)])
|
||||
_ -> ((S.empty,S.empty),[])
|
||||
where
|
||||
param m (n,ctx) = Param (gId (qual m n)) [toParamId t|(_,_,t)<-ctx]
|
||||
param m (n,ctx) = Param ((gQId m n)) [toParamId t|(_,_,t)<-ctx]
|
||||
argTypes = S.unions . map argTypes1
|
||||
argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
|
||||
|
||||
qual :: ModuleName -> Ident -> Ident
|
||||
qual m = prefixIdent (render m++"_")
|
||||
|
||||
|
||||
lblId = LabelId . render -- hmm
|
||||
modId (MN m) = ModId (showIdent m)
|
||||
|
||||
@@ -356,8 +351,16 @@ instance FromIdent VarId where
|
||||
|
||||
instance FromIdent C.FunId where gId = C.FunId . showIdent
|
||||
instance FromIdent CatId where gId = CatId . showIdent
|
||||
instance FromIdent ParamId where gId = ParamId . showIdent
|
||||
instance FromIdent VarValueId where gId = VarValueId . showIdent
|
||||
instance FromIdent ParamId where gId = ParamId . unqual
|
||||
instance FromIdent VarValueId where gId = VarValueId . unqual
|
||||
|
||||
class FromIdent i => QualIdent i where gQId :: ModuleName -> Ident -> i
|
||||
|
||||
instance QualIdent ParamId where gQId m n = ParamId (qual m n)
|
||||
instance QualIdent VarValueId where gQId m n = VarValueId (qual m n)
|
||||
|
||||
qual m n = Qual (modId m) (showIdent n)
|
||||
unqual n = Unqual (showIdent n)
|
||||
|
||||
convFlags gr mn =
|
||||
Flags [(n,convLit v) |
|
||||
@@ -7,7 +7,7 @@ import GF.Compile as S(batchCompile,link,srcAbsName)
|
||||
import GF.CompileInParallel as P(parallelBatchCompile)
|
||||
import GF.Compile.Export
|
||||
import GF.Compile.ConcreteToHaskell(concretes2haskell)
|
||||
import GF.Compile.ConcreteToCanonical--(concretes2canonical)
|
||||
import GF.Compile.GrammarToCanonical--(concretes2canonical)
|
||||
import GF.Compile.CFGtoPGF
|
||||
import GF.Compile.GetGrammar
|
||||
import GF.Grammar.BNFC
|
||||
|
||||
@@ -1,7 +1,13 @@
|
||||
-- | Abstract syntax for canonical GF grammars, i.e. what's left after
|
||||
-- |
|
||||
-- Module : GF.Grammar.Canonical
|
||||
-- Stability : provisional
|
||||
--
|
||||
-- Abstract syntax for canonical GF grammars, i.e. what's left after
|
||||
-- high-level constructions such as functors and opers have been eliminated
|
||||
-- by partial evaluation. This is intended as a common intermediate
|
||||
-- representation to simplify export to other formats.
|
||||
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
module GF.Grammar.Canonical where
|
||||
import Prelude hiding ((<>))
|
||||
import GF.Text.Pretty
|
||||
@@ -51,13 +57,11 @@ newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
|
||||
|
||||
-- | Linearization value, RHS of @lin@
|
||||
data LinValue = ConcatValue LinValue LinValue
|
||||
| LiteralValue LinLiteral
|
||||
| ErrorValue String
|
||||
| FloatConstant Float
|
||||
| IntConstant Int
|
||||
| ParamConstant ParamValue
|
||||
| PredefValue PredefId
|
||||
| RecordValue [RecordRowValue]
|
||||
| StrConstant String
|
||||
| TableValue LinType [TableRowValue]
|
||||
--- | VTableValue LinType [LinValue]
|
||||
| TupleValue [LinValue]
|
||||
@@ -66,10 +70,17 @@ data LinValue = ConcatValue LinValue LinValue
|
||||
| PreValue [([String], LinValue)] LinValue
|
||||
| Projection LinValue LabelId
|
||||
| Selection LinValue LinValue
|
||||
deriving (Eq,Ord,Show)
|
||||
| CommentedValue String LinValue
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data LinLiteral = FloatConstant Float
|
||||
| IntConstant Int
|
||||
| StrConstant String
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data LinPattern = ParamPattern ParamPattern
|
||||
| RecordPattern [RecordRow LinPattern]
|
||||
| TuplePattern [LinPattern]
|
||||
| WildPattern
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
@@ -77,37 +88,47 @@ type ParamValue = Param LinValue
|
||||
type ParamPattern = Param LinPattern
|
||||
type ParamValueDef = Param ParamId
|
||||
|
||||
data Param arg = Param ParamId [arg] deriving (Eq,Ord,Show)
|
||||
data Param arg = Param ParamId [arg]
|
||||
deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
|
||||
|
||||
type RecordRowType = RecordRow LinType
|
||||
type RecordRowType = RecordRow LinType
|
||||
type RecordRowValue = RecordRow LinValue
|
||||
type TableRowValue = TableRow LinValue
|
||||
|
||||
data RecordRow rhs = RecordRow LabelId rhs deriving (Eq,Ord,Show)
|
||||
data TableRowValue = TableRowValue LinPattern LinValue deriving (Eq,Ord,Show)
|
||||
data RecordRow rhs = RecordRow LabelId rhs
|
||||
deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
|
||||
data TableRow rhs = TableRow LinPattern rhs
|
||||
deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
|
||||
|
||||
-- *** Identifiers in Concrete Syntax
|
||||
|
||||
newtype PredefId = PredefId String deriving (Eq,Ord,Show)
|
||||
newtype LabelId = LabelId String deriving (Eq,Ord,Show)
|
||||
data VarValueId = VarValueId String deriving (Eq,Ord,Show)
|
||||
newtype PredefId = PredefId Id deriving (Eq,Ord,Show)
|
||||
newtype LabelId = LabelId Id deriving (Eq,Ord,Show)
|
||||
data VarValueId = VarValueId QualId deriving (Eq,Ord,Show)
|
||||
|
||||
-- | Name of param type or param value
|
||||
newtype ParamId = ParamId String deriving (Eq,Ord,Show)
|
||||
newtype ParamId = ParamId QualId deriving (Eq,Ord,Show)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- ** Used in both Abstract and Concrete Syntax
|
||||
|
||||
newtype ModId = ModId String deriving (Eq,Show)
|
||||
newtype ModId = ModId Id deriving (Eq,Ord,Show)
|
||||
|
||||
newtype CatId = CatId String deriving (Eq,Ord,Show)
|
||||
newtype FunId = FunId String deriving (Eq,Show)
|
||||
newtype CatId = CatId Id deriving (Eq,Ord,Show)
|
||||
newtype FunId = FunId Id deriving (Eq,Show)
|
||||
|
||||
data VarId = Anonymous | VarId String deriving Show
|
||||
data VarId = Anonymous | VarId Id deriving Show
|
||||
|
||||
newtype Flags = Flags [(FlagName,FlagValue)] deriving Show
|
||||
type FlagName = String
|
||||
type FlagName = Id
|
||||
data FlagValue = Str String | Int Int | Flt Double deriving Show
|
||||
|
||||
|
||||
-- *** Identifiers
|
||||
|
||||
type Id = String
|
||||
data QualId = Qual ModId Id | Unqual Id deriving (Eq,Ord,Show)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- ** Pretty printing
|
||||
|
||||
@@ -199,12 +220,12 @@ instance Pretty LinValue where
|
||||
Projection lv l -> ppA lv<>"."<>l
|
||||
Selection tv pv -> ppA tv<>"!"<>ppA pv
|
||||
VariantValue vs -> "variants"<+>block vs
|
||||
CommentedValue s v -> "{-" <+> s <+> "-}" $$ v
|
||||
_ -> ppA lv
|
||||
|
||||
instance PPA LinValue where
|
||||
ppA lv = case lv of
|
||||
FloatConstant f -> pp f
|
||||
IntConstant n -> pp n
|
||||
LiteralValue l -> ppA l
|
||||
ParamConstant pv -> ppA pv
|
||||
PredefValue p -> ppA p
|
||||
RecordValue [] -> pp "<>"
|
||||
@@ -214,13 +235,20 @@ instance PPA LinValue where
|
||||
where
|
||||
alt (ss,lv) = hang (hcat (punctuate "|" (map doubleQuotes ss)))
|
||||
2 ("=>"<+>lv)
|
||||
StrConstant s -> doubleQuotes s -- hmm
|
||||
TableValue _ tvs -> "table"<+>block tvs
|
||||
-- VTableValue t ts -> "table"<+>t<+>brackets (semiSep ts)
|
||||
TupleValue lvs -> "<"<>punctuate "," lvs<>">"
|
||||
VarValue v -> pp v
|
||||
_ -> parens lv
|
||||
|
||||
instance Pretty LinLiteral where pp = ppA
|
||||
|
||||
instance PPA LinLiteral where
|
||||
ppA l = case l of
|
||||
FloatConstant f -> pp f
|
||||
IntConstant n -> pp n
|
||||
StrConstant s -> doubleQuotes s -- hmm
|
||||
|
||||
instance RhsSeparator LinValue where rhsSep _ = pp "="
|
||||
|
||||
instance Pretty LinPattern where
|
||||
@@ -233,6 +261,7 @@ instance PPA LinPattern where
|
||||
ppA p =
|
||||
case p of
|
||||
RecordPattern r -> block r
|
||||
TuplePattern ps -> "<"<>punctuate "," ps<>">"
|
||||
WildPattern -> pp "_"
|
||||
_ -> parens p
|
||||
|
||||
@@ -241,8 +270,8 @@ instance RhsSeparator LinPattern where rhsSep _ = pp "="
|
||||
instance RhsSeparator rhs => Pretty (RecordRow rhs) where
|
||||
pp (RecordRow l v) = hang (l<+>rhsSep v) 2 v
|
||||
|
||||
instance Pretty TableRowValue where
|
||||
pp (TableRowValue l v) = hang (l<+>"=>") 2 v
|
||||
instance Pretty rhs => Pretty (TableRow rhs) where
|
||||
pp (TableRow l v) = hang (l<+>"=>") 2 v
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
instance Pretty ModId where pp (ModId s) = pp s
|
||||
@@ -250,11 +279,17 @@ instance Pretty CatId where pp (CatId s) = pp s
|
||||
instance Pretty FunId where pp (FunId s) = pp s
|
||||
instance Pretty LabelId where pp (LabelId s) = pp s
|
||||
instance Pretty PredefId where pp = ppA
|
||||
instance PPA PredefId where ppA (PredefId s) = pp s
|
||||
instance PPA PredefId where ppA (PredefId s) = "Predef."<>s
|
||||
instance Pretty ParamId where pp = ppA
|
||||
instance PPA ParamId where ppA (ParamId s) = pp s
|
||||
instance Pretty VarValueId where pp (VarValueId s) = pp s
|
||||
|
||||
instance Pretty QualId where pp = ppA
|
||||
|
||||
instance PPA QualId where
|
||||
ppA (Qual m n) = m<>"_"<>n -- hmm
|
||||
ppA (Unqual n) = pp n
|
||||
|
||||
instance Pretty Flags where
|
||||
pp (Flags []) = empty
|
||||
pp (Flags flags) = "flags" <+> vcat (map ppFlag flags)
|
||||
|
||||
@@ -3,7 +3,8 @@ module GF.Grammar.CanonicalJSON (
|
||||
) where
|
||||
|
||||
import Text.JSON
|
||||
import qualified Control.Monad as CM (mapM, msum)
|
||||
import Control.Applicative ((<|>))
|
||||
import Data.Ratio (denominator, numerator)
|
||||
import GF.Grammar.Canonical
|
||||
|
||||
|
||||
@@ -20,6 +21,8 @@ encodeJSON fpath g = writeFile fpath (encode g)
|
||||
instance JSON Grammar where
|
||||
showJSON (Grammar abs cncs) = makeObj [("abstract", showJSON abs), ("concretes", showJSON cncs)]
|
||||
|
||||
readJSON o = Grammar <$> o!"abstract" <*> o!"concretes"
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- ** Abstract Syntax
|
||||
@@ -31,30 +34,46 @@ instance JSON Abstract where
|
||||
("cats", showJSON cats),
|
||||
("funs", showJSON funs)]
|
||||
|
||||
readJSON o = Abstract
|
||||
<$> o!"abs"
|
||||
<*>(o!"flags" <|> return (Flags []))
|
||||
<*> o!"cats"
|
||||
<*> o!"funs"
|
||||
|
||||
instance JSON CatDef where
|
||||
-- non-dependent categories are encoded as simple strings:
|
||||
showJSON (CatDef c []) = showJSON c
|
||||
showJSON (CatDef c cs) = makeObj [("cat", showJSON c), ("args", showJSON cs)]
|
||||
|
||||
readJSON o = CatDef <$> readJSON o <*> return []
|
||||
<|> CatDef <$> o!"cat" <*> o!"args"
|
||||
|
||||
instance JSON FunDef where
|
||||
showJSON (FunDef f ty) = makeObj [("fun", showJSON f), ("type", showJSON ty)]
|
||||
{-
|
||||
instance FromJSON FunDef where
|
||||
parseJSON = withObject "FunDef" $ \o -> FunDef <$> o .: "fun" <*> o .: "type"
|
||||
-}
|
||||
|
||||
readJSON o = FunDef <$> o!"fun" <*> o!"type"
|
||||
|
||||
instance JSON Type where
|
||||
showJSON (Type bs ty) = makeObj [("args", showJSON bs), ("result", showJSON ty)]
|
||||
showJSON (Type bs ty) = makeObj [(".args", showJSON bs), (".result", showJSON ty)]
|
||||
|
||||
readJSON o = Type <$> o!".args" <*> o!".result"
|
||||
|
||||
instance JSON TypeApp where
|
||||
-- non-dependent categories are encoded as simple strings:
|
||||
showJSON (TypeApp c []) = showJSON c
|
||||
showJSON (TypeApp c args) = makeObj [("cat", showJSON c), ("args", showJSON args)]
|
||||
showJSON (TypeApp c args) = makeObj [(".cat", showJSON c), (".args", showJSON args)]
|
||||
|
||||
readJSON o = TypeApp <$> readJSON o <*> return []
|
||||
<|> TypeApp <$> o!".cat" <*> o!".args"
|
||||
|
||||
instance JSON TypeBinding where
|
||||
-- non-dependent categories are encoded as simple strings:
|
||||
showJSON (TypeBinding Anonymous (Type [] (TypeApp c []))) = showJSON c
|
||||
showJSON (TypeBinding x ty) = makeObj [("var", showJSON x), ("type", showJSON ty)]
|
||||
showJSON (TypeBinding x ty) = makeObj [(".var", showJSON x), (".type", showJSON ty)]
|
||||
|
||||
readJSON o = do c <- readJSON o
|
||||
return (TypeBinding Anonymous (Type [] (TypeApp c [])))
|
||||
<|> TypeBinding <$> o!".var" <*> o!".type"
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
@@ -69,101 +88,173 @@ instance JSON Concrete where
|
||||
("lincats", showJSON lincats),
|
||||
("lins", showJSON lins)]
|
||||
|
||||
readJSON o = Concrete
|
||||
<$> o!"cnc"
|
||||
<*> o!"abs"
|
||||
<*>(o!"flags" <|> return (Flags []))
|
||||
<*> o!"params"
|
||||
<*> o!"lincats"
|
||||
<*> o!"lins"
|
||||
|
||||
instance JSON ParamDef where
|
||||
showJSON (ParamDef p pvs) = makeObj [("param", showJSON p), ("values", showJSON pvs)]
|
||||
showJSON (ParamAliasDef p t) = makeObj [("param", showJSON p), ("alias", showJSON t)]
|
||||
|
||||
readJSON o = ParamDef <$> o!"param" <*> o!"values"
|
||||
<|> ParamAliasDef <$> o!"param" <*> o!"alias"
|
||||
|
||||
instance JSON LincatDef where
|
||||
showJSON (LincatDef c lt) = makeObj [("cat", showJSON c), ("lintype", showJSON lt)]
|
||||
|
||||
readJSON o = LincatDef <$> o!"cat" <*> o!"lintype"
|
||||
|
||||
instance JSON LinDef where
|
||||
showJSON (LinDef f xs lv) = makeObj [("fun", showJSON f), ("args", showJSON xs), ("lin", showJSON lv)]
|
||||
|
||||
readJSON o = LinDef <$> o!"fun" <*> o!"args" <*> o!"lin"
|
||||
|
||||
instance JSON LinType where
|
||||
showJSON lt = case lt of
|
||||
-- the basic types (Str, Float, Int) are encoded as strings:
|
||||
StrType -> showJSON "Str"
|
||||
FloatType -> showJSON "Float"
|
||||
IntType -> showJSON "Int"
|
||||
-- parameters are also encoded as strings:
|
||||
ParamType pt -> showJSON pt
|
||||
-- tables/tuples are encoded as JSON objects:
|
||||
TableType pt lt -> makeObj [("tblarg", showJSON pt), ("tblval", showJSON lt)]
|
||||
TupleType lts -> makeObj [("tuple", showJSON lts)]
|
||||
-- records are encoded as records:
|
||||
RecordType rows -> showJSON rows
|
||||
-- the basic types (Str, Float, Int) are encoded as strings:
|
||||
showJSON (StrType) = showJSON "Str"
|
||||
showJSON (FloatType) = showJSON "Float"
|
||||
showJSON (IntType) = showJSON "Int"
|
||||
-- parameters are also encoded as strings:
|
||||
showJSON (ParamType pt) = showJSON pt
|
||||
-- tables/tuples are encoded as JSON objects:
|
||||
showJSON (TableType pt lt) = makeObj [(".tblarg", showJSON pt), (".tblval", showJSON lt)]
|
||||
showJSON (TupleType lts) = makeObj [(".tuple", showJSON lts)]
|
||||
-- records are encoded as records:
|
||||
showJSON (RecordType rows) = showJSON rows
|
||||
|
||||
readJSON o = do "Str" <- readJSON o; return StrType
|
||||
<|> do "Float" <- readJSON o; return FloatType
|
||||
<|> do "Int" <- readJSON o; return IntType
|
||||
<|> do ptype <- readJSON o; return (ParamType ptype)
|
||||
<|> TableType <$> o!".tblarg" <*> o!".tblval"
|
||||
<|> TupleType <$> o!".tuple"
|
||||
<|> RecordType <$> readJSON o
|
||||
|
||||
instance JSON LinValue where
|
||||
showJSON lv = case lv of
|
||||
-- basic values (Str, Float, Int) are encoded as JSON strings/numbers:
|
||||
StrConstant s -> showJSON s
|
||||
FloatConstant f -> showJSON f
|
||||
IntConstant n -> showJSON n
|
||||
-- concatenation is encoded as a JSON array:
|
||||
ConcatValue v v' -> showJSON [showJSON v, showJSON v']
|
||||
-- most values are encoded as JSON objects:
|
||||
ParamConstant pv -> makeObj [("param", showJSON pv)]
|
||||
PredefValue p -> makeObj [("predef", showJSON p)]
|
||||
TableValue t tvs -> makeObj [("tblarg", showJSON t), ("tblrows", showJSON tvs)]
|
||||
TupleValue lvs -> makeObj [("tuple", showJSON lvs)]
|
||||
VarValue v -> makeObj [("var", showJSON v)]
|
||||
ErrorValue s -> makeObj [("error", showJSON s)]
|
||||
Projection lv l -> makeObj [("project", showJSON lv), ("label", showJSON l)]
|
||||
Selection tv pv -> makeObj [("select", showJSON tv), ("key", showJSON pv)]
|
||||
VariantValue vs -> makeObj [("variants", showJSON vs)]
|
||||
PreValue alts def -> makeObj [("pre", showJSON alts), ("default", showJSON def)]
|
||||
-- records are encoded directly as JSON records:
|
||||
RecordValue rows -> showJSON rows
|
||||
showJSON (LiteralValue l ) = showJSON l
|
||||
-- most values are encoded as JSON objects:
|
||||
showJSON (ParamConstant pv) = makeObj [(".param", showJSON pv)]
|
||||
showJSON (PredefValue p ) = makeObj [(".predef", showJSON p)]
|
||||
showJSON (TableValue t tvs) = makeObj [(".tblarg", showJSON t), (".tblrows", showJSON tvs)]
|
||||
showJSON (TupleValue lvs) = makeObj [(".tuple", showJSON lvs)]
|
||||
showJSON (VarValue v ) = makeObj [(".var", showJSON v)]
|
||||
showJSON (ErrorValue s ) = makeObj [(".error", showJSON s)]
|
||||
showJSON (Projection lv l ) = makeObj [(".project", showJSON lv), (".label", showJSON l)]
|
||||
showJSON (Selection tv pv) = makeObj [(".select", showJSON tv), (".key", showJSON pv)]
|
||||
showJSON (VariantValue vs) = makeObj [(".variants", showJSON vs)]
|
||||
showJSON (PreValue pre def) = makeObj [(".pre", showJSON pre),(".default", showJSON def)]
|
||||
-- records are encoded directly as JSON records:
|
||||
showJSON (RecordValue rows) = showJSON rows
|
||||
-- concatenation is encoded as a JSON array:
|
||||
showJSON v@(ConcatValue _ _) = showJSON (flatten v [])
|
||||
where flatten (ConcatValue v v') = flatten v . flatten v'
|
||||
flatten v = (v :)
|
||||
|
||||
readJSON o = LiteralValue <$> readJSON o
|
||||
<|> ParamConstant <$> o!".param"
|
||||
<|> PredefValue <$> o!".predef"
|
||||
<|> TableValue <$> o!".tblarg" <*> o!".tblrows"
|
||||
<|> TupleValue <$> o!".tuple"
|
||||
<|> VarValue <$> o!".var"
|
||||
<|> ErrorValue <$> o!".error"
|
||||
<|> Projection <$> o!".project" <*> o!".label"
|
||||
<|> Selection <$> o!".select" <*> o!".key"
|
||||
<|> VariantValue <$> o!".variants"
|
||||
<|> PreValue <$> o!".pre" <*> o!".default"
|
||||
<|> RecordValue <$> readJSON o
|
||||
<|> do vs <- readJSON o :: Result [LinValue]
|
||||
return (foldr1 ConcatValue vs)
|
||||
|
||||
instance JSON LinLiteral where
|
||||
-- basic values (Str, Float, Int) are encoded as JSON strings/numbers:
|
||||
showJSON (StrConstant s) = showJSON s
|
||||
showJSON (FloatConstant f) = showJSON f
|
||||
showJSON (IntConstant n) = showJSON n
|
||||
|
||||
readJSON = readBasicJSON StrConstant IntConstant FloatConstant
|
||||
|
||||
instance JSON LinPattern where
|
||||
showJSON linpat = case linpat of
|
||||
-- wildcards and patterns without arguments are encoded as strings:
|
||||
WildPattern -> showJSON "_"
|
||||
ParamPattern (Param p []) -> showJSON p
|
||||
-- complex patterns are encoded as JSON objects:
|
||||
ParamPattern pv -> showJSON pv
|
||||
-- and records as records:
|
||||
RecordPattern r -> showJSON r
|
||||
-- wildcards and patterns without arguments are encoded as strings:
|
||||
showJSON (WildPattern) = showJSON "_"
|
||||
showJSON (ParamPattern (Param p [])) = showJSON p
|
||||
-- complex patterns are encoded as JSON objects:
|
||||
showJSON (ParamPattern pv) = showJSON pv
|
||||
-- and records as records:
|
||||
showJSON (RecordPattern r) = showJSON r
|
||||
|
||||
readJSON o = do "_" <- readJSON o; return WildPattern
|
||||
<|> do p <- readJSON o; return (ParamPattern (Param p []))
|
||||
<|> ParamPattern <$> readJSON o
|
||||
<|> RecordPattern <$> readJSON o
|
||||
|
||||
instance JSON arg => JSON (Param arg) where
|
||||
-- parameters without arguments are encoded as strings:
|
||||
showJSON (Param p []) = showJSON p
|
||||
showJSON (Param p args) = makeObj [("paramid", showJSON p), ("args", showJSON args)]
|
||||
showJSON (Param p args) = makeObj [(".paramid", showJSON p), (".args", showJSON args)]
|
||||
|
||||
readJSON o = Param <$> readJSON o <*> return []
|
||||
<|> Param <$> o!".paramid" <*> o!".args"
|
||||
|
||||
instance JSON a => JSON (RecordRow a) where
|
||||
-- record rows and lists of record rows are both encoded as JSON records (i.e., objects)
|
||||
showJSON row = makeObj [toJSONRecordRow row]
|
||||
showJSON row = showJSONs [row]
|
||||
showJSONs rows = makeObj (map toRow rows)
|
||||
where toRow (RecordRow (LabelId lbl) val) = (lbl, showJSON val)
|
||||
|
||||
toJSONRecordRow :: JSON a => RecordRow a -> (String,JSValue)
|
||||
toJSONRecordRow (RecordRow (LabelId lbl) val) = (lbl, showJSON val)
|
||||
readJSON obj = head <$> readJSONs obj
|
||||
readJSONs obj = mapM fromRow (assocsJSObject obj)
|
||||
where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
|
||||
return (RecordRow (LabelId lbl) value)
|
||||
|
||||
instance JSON TableRowValue where
|
||||
showJSON (TableRowValue l v) = makeObj [("pattern", showJSON l), ("value", showJSON l)]
|
||||
instance JSON rhs => JSON (TableRow rhs) where
|
||||
showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)]
|
||||
|
||||
readJSON o = TableRow <$> o!".pattern" <*> o!".value"
|
||||
|
||||
|
||||
-- *** Identifiers in Concrete Syntax
|
||||
|
||||
instance JSON PredefId where showJSON (PredefId s) = showJSON s
|
||||
instance JSON LabelId where showJSON (LabelId s) = showJSON s
|
||||
instance JSON VarValueId where showJSON (VarValueId s) = showJSON s
|
||||
instance JSON ParamId where showJSON (ParamId s) = showJSON s
|
||||
instance JSON ParamType where showJSON (ParamTypeId s) = showJSON s
|
||||
instance JSON PredefId where showJSON (PredefId s) = showJSON s ; readJSON = fmap PredefId . readJSON
|
||||
instance JSON LabelId where showJSON (LabelId s) = showJSON s ; readJSON = fmap LabelId . readJSON
|
||||
instance JSON VarValueId where showJSON (VarValueId s) = showJSON s ; readJSON = fmap VarValueId . readJSON
|
||||
instance JSON ParamId where showJSON (ParamId s) = showJSON s ; readJSON = fmap ParamId . readJSON
|
||||
instance JSON ParamType where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- ** Used in both Abstract and Concrete Syntax
|
||||
|
||||
instance JSON ModId where showJSON (ModId s) = showJSON s
|
||||
instance JSON CatId where showJSON (CatId s) = showJSON s
|
||||
instance JSON FunId where showJSON (FunId s) = showJSON s
|
||||
instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON
|
||||
instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON
|
||||
instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON
|
||||
|
||||
instance JSON VarId where
|
||||
-- the anonymous variable is the underscore:
|
||||
showJSON Anonymous = showJSON "_"
|
||||
showJSON (VarId x) = showJSON x
|
||||
|
||||
readJSON o = do "_" <- readJSON o; return Anonymous
|
||||
<|> VarId <$> readJSON o
|
||||
|
||||
instance JSON QualId where
|
||||
showJSON (Qual (ModId m) n) = showJSON (m++"."++n)
|
||||
showJSON (Unqual n) = showJSON n
|
||||
|
||||
readJSON o = do qualid <- readJSON o
|
||||
let (mod, id) = span (/= '.') qualid
|
||||
return $ if null mod then Unqual id else Qual (ModId mod) id
|
||||
|
||||
instance JSON Flags where
|
||||
-- flags are encoded directly as JSON records (i.e., objects):
|
||||
showJSON (Flags fs) = makeObj [(f,showJSON v) | (f, v) <- fs]
|
||||
showJSON (Flags fs) = makeObj [(f, showJSON v) | (f, v) <- fs]
|
||||
|
||||
readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj)
|
||||
where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
|
||||
return (lbl, value)
|
||||
|
||||
instance JSON FlagValue where
|
||||
-- flag values are encoded as basic JSON types:
|
||||
@@ -171,3 +262,28 @@ instance JSON FlagValue where
|
||||
showJSON (Int i) = showJSON i
|
||||
showJSON (Flt f) = showJSON f
|
||||
|
||||
readJSON = readBasicJSON Str Int Flt
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- ** Convenience functions
|
||||
|
||||
(!) :: JSON a => JSValue -> String -> Result a
|
||||
obj ! key = maybe (fail $ "CanonicalJSON.(!): Could not find key: " ++ show key)
|
||||
readJSON
|
||||
(lookup key (assocsJSObject obj))
|
||||
|
||||
assocsJSObject :: JSValue -> [(String, JSValue)]
|
||||
assocsJSObject (JSObject o) = fromJSObject o
|
||||
assocsJSObject (JSArray _) = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found an Array"
|
||||
assocsJSObject jsvalue = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found " ++ show jsvalue
|
||||
|
||||
|
||||
readBasicJSON :: (JSON int, Integral int, JSON flt, RealFloat flt) =>
|
||||
(String -> v) -> (int -> v) -> (flt -> v) -> JSValue -> Result v
|
||||
readBasicJSON str int flt o
|
||||
= str <$> readJSON o
|
||||
<|> int_or_flt <$> readJSON o
|
||||
where int_or_flt f | f == fromIntegral n = int n
|
||||
| otherwise = flt f
|
||||
where n = round f
|
||||
|
||||
@@ -327,7 +327,7 @@ optDescr =
|
||||
Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').",
|
||||
Option ['f'] ["output-format"] (ReqArg outFmt "FMT")
|
||||
(unlines ["Output format. FMT can be one of:",
|
||||
"Canonical GF grammar: canonical_gf, canonical_json, canonical_yaml, (and haskell with option --haskell=concrete)",
|
||||
"Canonical GF grammar: canonical_gf, canonical_json, (and haskell with option --haskell=concrete)",
|
||||
"Multiple concrete: pgf (default), js, pgf_pretty, prolog, python, ...", -- gar,
|
||||
"Single concrete only: bnf, ebnf, fa, gsl, jsgf, regexp, slf, srgs_xml, srgs_abnf, vxml, ....", -- cf, lbnf,
|
||||
"Abstract only: haskell, ..."]), -- prolog_abs,
|
||||
|
||||
@@ -100,7 +100,7 @@ hspgf_predict_callback(PgfOracleCallback* self,
|
||||
size_t offset)
|
||||
{
|
||||
HSPgfOracleCallback* oracle = gu_container(self, HSPgfOracleCallback, oracle);
|
||||
oracle->predict(cat,label,hspgf_offset2hs(oracle->sentence, offset));
|
||||
return oracle->predict(cat,label,hspgf_offset2hs(oracle->sentence, offset));
|
||||
}
|
||||
|
||||
static bool
|
||||
@@ -110,7 +110,7 @@ hspgf_complete_callback(PgfOracleCallback* self,
|
||||
size_t offset)
|
||||
{
|
||||
HSPgfOracleCallback* oracle = gu_container(self, HSPgfOracleCallback, oracle);
|
||||
oracle->complete(cat,label,hspgf_offset2hs(oracle->sentence, offset));
|
||||
return oracle->complete(cat,label,hspgf_offset2hs(oracle->sentence, offset));
|
||||
}
|
||||
|
||||
static PgfExprProb*
|
||||
|
||||
Reference in New Issue
Block a user