mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-08 20:59:30 -06:00
Merge branch 'master' into concrete-new
This commit is contained in:
Inari Listenmaa
@@ -15,6 +15,7 @@ import GF.Command.Abstract --(isOpt,valStrOpts,prOpt)
|
||||
import GF.Text.Pretty
|
||||
import GF.Text.Transliterations
|
||||
import GF.Text.Lexing(stringOp,opInEnv)
|
||||
import Data.Char (isSpace)
|
||||
|
||||
import qualified PGF as H(showCId,showExpr,toATree,toTrie,Trie(..))
|
||||
|
||||
@@ -170,7 +171,8 @@ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [
|
||||
restrictedSystem $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo
|
||||
fmap fromString $ restricted $ readFile tmpo,
|
||||
-}
|
||||
fmap fromString . restricted . readShellProcess syst $ toString arg,
|
||||
fmap (fromStrings . lines) . restricted . readShellProcess syst . unlines . map (dropWhile (=='\n')) $ toStrings $ arg,
|
||||
|
||||
flags = [
|
||||
("command","the system command applied to the argument")
|
||||
],
|
||||
|
||||
@@ -7,7 +7,7 @@ import GF.Text.Pretty
|
||||
--import GF.Grammar.Predef(cPredef,cInts)
|
||||
--import GF.Compile.Compute.Predef(predef)
|
||||
--import GF.Compile.Compute.Value(Predefined(..))
|
||||
import GF.Infra.Ident(Ident,identS,identW,prefixIdent)
|
||||
import GF.Infra.Ident(Ident,identC,identS,identW,prefixIdent,showRawIdent,rawIdentS)
|
||||
import GF.Infra.Option
|
||||
import GF.Haskell as H
|
||||
import GF.Grammar.Canonical as C
|
||||
@@ -21,7 +21,7 @@ concretes2haskell opts absname gr =
|
||||
| let Grammar abstr cncs = grammar2canonical opts absname gr,
|
||||
cncmod<-cncs,
|
||||
let ModId name = concName cncmod
|
||||
filename = name ++ ".hs" :: FilePath
|
||||
filename = showRawIdent name ++ ".hs" :: FilePath
|
||||
]
|
||||
|
||||
-- | Generate Haskell code for the given concrete module.
|
||||
@@ -53,7 +53,7 @@ concrete2haskell opts
|
||||
labels = S.difference (S.unions (map S.fromList recs)) common_labels
|
||||
common_records = S.fromList [[label_s]]
|
||||
common_labels = S.fromList [label_s]
|
||||
label_s = LabelId "s"
|
||||
label_s = LabelId (rawIdentS "s")
|
||||
|
||||
signature (CatDef c _) = TypeSig lf (Fun abs (pure lin))
|
||||
where
|
||||
@@ -69,7 +69,7 @@ concrete2haskell opts
|
||||
where
|
||||
--funcats = S.fromList [c | FunDef f (C.Type _ (TypeApp c _))<-funs]
|
||||
allcats = S.fromList [c | CatDef c _<-cats]
|
||||
|
||||
|
||||
gId :: ToIdent i => i -> Ident
|
||||
gId = (if haskellOption opts HaskellNoPrefix then id else prefixIdent "G")
|
||||
. toIdent
|
||||
@@ -116,7 +116,7 @@ concrete2haskell opts
|
||||
where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-rs]
|
||||
StrType -> tcon0 (identS "Str")
|
||||
TableType pt lt -> Fun (ppT pt) (ppT lt)
|
||||
-- TupleType lts ->
|
||||
-- TupleType lts ->
|
||||
|
||||
lincatDef (LincatDef c t) = tsyn0 (lincatName c) (convLinType t)
|
||||
|
||||
@@ -126,7 +126,7 @@ concrete2haskell opts
|
||||
linDefs = map eqn . sortOn fst . map linDef
|
||||
where eqn (cat,(f,(ps,rhs))) = (cat,Eqn (f,ps) rhs)
|
||||
|
||||
linDef (LinDef f xs rhs0) =
|
||||
linDef (LinDef f xs rhs0) =
|
||||
(cat,(linfunName cat,(lhs,rhs)))
|
||||
where
|
||||
lhs = [ConP (aId f) (map VarP abs_args)]
|
||||
@@ -144,7 +144,7 @@ concrete2haskell opts
|
||||
where
|
||||
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)))
|
||||
|
||||
@@ -187,7 +187,7 @@ concrete2haskell opts
|
||||
|
||||
pId p@(ParamId s) =
|
||||
if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack
|
||||
|
||||
|
||||
table cs =
|
||||
if all (null.patVars) ps
|
||||
then lets ds (LambdaCase [(ppP p,t')|(p,t')<-zip ps ts'])
|
||||
@@ -315,13 +315,13 @@ instance Records rhs => Records (TableRow rhs) where
|
||||
|
||||
-- | Record subtyping is converted into explicit coercions in Haskell
|
||||
coerce env ty t =
|
||||
case (ty,t) of
|
||||
case (ty,t) of
|
||||
(_,VariantValue ts) -> VariantValue (map (coerce env ty) ts)
|
||||
(TableType ti tv,TableValue _ 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]]
|
||||
RecordRow l f<-r,ft<-[ft | RecordRow l' ft <- rt, l'==l]]
|
||||
(RecordType rt,VarValue x)->
|
||||
case lookup x env of
|
||||
Just ty' | ty'/=ty -> -- better to compare to normal form of ty'
|
||||
@@ -334,18 +334,17 @@ coerce env ty t =
|
||||
_ -> t
|
||||
where
|
||||
app f ts = ParamConstant (Param f ts) -- !! a hack
|
||||
to_rcon = ParamId . Unqual . to_rcon' . labels
|
||||
to_rcon = ParamId . Unqual . rawIdentS . to_rcon' . labels
|
||||
|
||||
patVars p = []
|
||||
|
||||
labels r = [l|RecordRow l _<-r]
|
||||
labels r = [l | RecordRow l _ <- r]
|
||||
|
||||
proj = Var . identS . proj'
|
||||
proj' (LabelId l) = "proj_"++l
|
||||
proj' (LabelId l) = "proj_" ++ showRawIdent l
|
||||
rcon = Var . rcon'
|
||||
rcon' = identS . rcon_name
|
||||
rcon_name ls = "R"++concat (sort ['_':l|LabelId l<-ls])
|
||||
|
||||
rcon_name ls = "R"++concat (sort ['_':showRawIdent l | LabelId l <- ls])
|
||||
to_rcon' = ("to_"++) . rcon_name
|
||||
|
||||
recordType ls =
|
||||
@@ -400,17 +399,17 @@ linfunName c = prefixIdent "lin" (toIdent c)
|
||||
|
||||
class ToIdent i where toIdent :: i -> Ident
|
||||
|
||||
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 q) = qIdentS q
|
||||
instance ToIdent ParamId where toIdent (ParamId q) = qIdentC q
|
||||
instance ToIdent PredefId where toIdent (PredefId s) = identC s
|
||||
instance ToIdent CatId where toIdent (CatId s) = identC s
|
||||
instance ToIdent C.FunId where toIdent (FunId s) = identC s
|
||||
instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentC q
|
||||
|
||||
qIdentS = identS . unqual
|
||||
qIdentC = identS . unqual
|
||||
|
||||
unqual (Qual (ModId m) n) = m++"_"++n
|
||||
unqual (Unqual n) = n
|
||||
unqual (Qual (ModId m) n) = showRawIdent m++"_"++ showRawIdent n
|
||||
unqual (Unqual n) = showRawIdent n
|
||||
|
||||
instance ToIdent VarId where
|
||||
toIdent Anonymous = identW
|
||||
toIdent (VarId s) = identS s
|
||||
toIdent (VarId s) = identC s
|
||||
|
||||
@@ -6,30 +6,35 @@ module GF.Compile.GrammarToCanonical(
|
||||
) where
|
||||
import Data.List(nub,partition)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe(fromMaybe)
|
||||
import qualified Data.Set as S
|
||||
import GF.Data.ErrM
|
||||
import GF.Text.Pretty
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Grammar as G
|
||||
import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
|
||||
import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt)
|
||||
import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,composSafeOp,mkAbs,mkApp,term2patt,sortRec)
|
||||
import GF.Grammar.Lockfield(isLockLabel)
|
||||
import GF.Grammar.Predef(cPredef,cInts)
|
||||
import GF.Compile.Compute.Predef(predef)
|
||||
import GF.Compile.Compute.Value(Predefined(..))
|
||||
import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent)
|
||||
import GF.Infra.Option(optionsPGF)
|
||||
import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent)
|
||||
import GF.Infra.Option(Options,optionsPGF)
|
||||
import PGF.Internal(Literal(..))
|
||||
import GF.Compile.Compute.Concrete(normalForm,resourceValues)
|
||||
import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues)
|
||||
import GF.Grammar.Canonical as C
|
||||
import Debug.Trace
|
||||
import System.FilePath ((</>), (<.>))
|
||||
import qualified Debug.Trace as T
|
||||
|
||||
|
||||
-- | Generate Canonical code for the named abstract syntax and all associated
|
||||
-- concrete syntaxes
|
||||
grammar2canonical :: Options -> ModuleName -> G.Grammar -> C.Grammar
|
||||
grammar2canonical opts absname gr =
|
||||
Grammar (abstract2canonical absname gr)
|
||||
(map snd (concretes2canonical opts absname gr))
|
||||
|
||||
-- | Generate Canonical code for the named abstract syntax
|
||||
abstract2canonical :: ModuleName -> G.Grammar -> Abstract
|
||||
abstract2canonical absname gr =
|
||||
Abstract (modId absname) (convFlags gr absname) cats funs
|
||||
where
|
||||
@@ -44,6 +49,7 @@ abstract2canonical absname gr =
|
||||
convHypo (bt,name,t) =
|
||||
case typeForm t of
|
||||
([],(_,cat),[]) -> gId cat -- !!
|
||||
tf -> error $ "abstract2canonical convHypo: " ++ show tf
|
||||
|
||||
convType t =
|
||||
case typeForm t of
|
||||
@@ -54,23 +60,24 @@ abstract2canonical absname gr =
|
||||
|
||||
convHypo' (bt,name,t) = TypeBinding (gId name) (convType t)
|
||||
|
||||
|
||||
-- | Generate Canonical code for the all concrete syntaxes associated with
|
||||
-- the named abstract syntax in given the grammar.
|
||||
concretes2canonical :: Options -> ModuleName -> G.Grammar -> [(FilePath, Concrete)]
|
||||
concretes2canonical opts absname gr =
|
||||
[(cncname,concrete2canonical gr cenv absname cnc cncmod)
|
||||
| let cenv = resourceValues opts gr,
|
||||
cnc<-allConcretes gr absname,
|
||||
let cncname = "canonical/"++render cnc ++ ".gf" :: FilePath
|
||||
let cncname = "canonical" </> render cnc <.> "gf"
|
||||
Ok cncmod = lookupModule gr cnc
|
||||
]
|
||||
|
||||
-- | Generate Canonical GF for the given concrete module.
|
||||
concrete2canonical :: G.Grammar -> GlobalEnv -> ModuleName -> ModuleName -> ModuleInfo -> Concrete
|
||||
concrete2canonical gr cenv absname cnc modinfo =
|
||||
Concrete (modId cnc) (modId absname) (convFlags gr cnc)
|
||||
(neededParamTypes S.empty (params defs))
|
||||
[lincat|(_,Left lincat)<-defs]
|
||||
[lin|(_,Right lin)<-defs]
|
||||
[lincat | (_,Left lincat) <- defs]
|
||||
[lin | (_,Right lin) <- defs]
|
||||
where
|
||||
defs = concatMap (toCanonical gr absname cenv) .
|
||||
M.toList $
|
||||
@@ -85,6 +92,7 @@ concrete2canonical gr cenv absname cnc modinfo =
|
||||
else let ((got,need),def) = paramType gr q
|
||||
in def++neededParamTypes (S.union got have) (S.toList need++qs)
|
||||
|
||||
toCanonical :: G.Grammar -> ModuleName -> GlobalEnv -> (Ident, Info) -> [(S.Set QIdent, Either LincatDef LinDef)]
|
||||
toCanonical gr absname cenv (name,jment) =
|
||||
case jment of
|
||||
CncCat (Just (L loc typ)) _ _ pprn _ ->
|
||||
@@ -97,7 +105,8 @@ toCanonical gr absname cenv (name,jment) =
|
||||
where
|
||||
tts = tableTypes gr [e']
|
||||
|
||||
e' = unAbs (length params) $
|
||||
e' = cleanupRecordFields lincat $
|
||||
unAbs (length params) $
|
||||
nf loc (mkAbs params (mkApp def (map Vr args)))
|
||||
params = [(b,x)|(b,x,_)<-ctx]
|
||||
args = map snd params
|
||||
@@ -108,12 +117,12 @@ toCanonical gr absname cenv (name,jment) =
|
||||
_ -> []
|
||||
where
|
||||
nf loc = normalForm cenv (L loc name)
|
||||
-- aId n = prefixIdent "A." (gId n)
|
||||
|
||||
unAbs 0 t = t
|
||||
unAbs n (Abs _ _ t) = unAbs (n-1) t
|
||||
unAbs _ t = t
|
||||
|
||||
tableTypes :: G.Grammar -> [Term] -> S.Set QIdent
|
||||
tableTypes gr ts = S.unions (map tabtys ts)
|
||||
where
|
||||
tabtys t =
|
||||
@@ -122,6 +131,7 @@ tableTypes gr ts = S.unions (map tabtys ts)
|
||||
T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs))
|
||||
_ -> collectOp tabtys t
|
||||
|
||||
paramTypes :: G.Grammar -> G.Type -> S.Set QIdent
|
||||
paramTypes gr t =
|
||||
case t of
|
||||
RecType fs -> S.unions (map (paramTypes gr.snd) fs)
|
||||
@@ -140,11 +150,26 @@ paramTypes gr t =
|
||||
Ok (_,ResParam {}) -> S.singleton q
|
||||
_ -> ignore
|
||||
|
||||
ignore = trace ("Ignore: "++show t) S.empty
|
||||
ignore = T.trace ("Ignore: " ++ show t) S.empty
|
||||
|
||||
-- | Filter out record fields from definitions which don't appear in lincat.
|
||||
cleanupRecordFields :: G.Type -> Term -> Term
|
||||
cleanupRecordFields (RecType ls) (R as) =
|
||||
let defnFields = M.fromList ls
|
||||
in R
|
||||
[ (lbl, (mty, t'))
|
||||
| (lbl, (mty, t)) <- as
|
||||
, M.member lbl defnFields
|
||||
, let Just ty = M.lookup lbl defnFields
|
||||
, let t' = cleanupRecordFields ty t
|
||||
]
|
||||
cleanupRecordFields ty t@(FV _) = composSafeOp (cleanupRecordFields ty) t
|
||||
cleanupRecordFields _ t = t
|
||||
|
||||
convert :: G.Grammar -> Term -> LinValue
|
||||
convert gr = convert' gr []
|
||||
|
||||
convert' :: G.Grammar -> [Ident] -> Term -> LinValue
|
||||
convert' gr vs = ppT
|
||||
where
|
||||
ppT0 = convert' gr vs
|
||||
@@ -162,20 +187,20 @@ convert' gr vs = ppT
|
||||
S t p -> selection (ppT t) (ppT p)
|
||||
C t1 t2 -> concatValue (ppT t1) (ppT t2)
|
||||
App f a -> ap (ppT f) (ppT a)
|
||||
R r -> RecordValue (fields r)
|
||||
R r -> RecordValue (fields (sortRec r))
|
||||
P t l -> projection (ppT t) (lblId l)
|
||||
Vr x -> VarValue (gId x)
|
||||
Cn x -> VarValue (gId x) -- hmm
|
||||
Con c -> ParamConstant (Param (gId c) [])
|
||||
Sort k -> VarValue (gId k)
|
||||
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)) [])
|
||||
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
|
||||
_ -> error $ "convert' ppT: " ++ show t
|
||||
|
||||
ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t)
|
||||
|
||||
@@ -188,12 +213,12 @@ convert' gr vs = ppT
|
||||
Ok ALL_CAPIT -> p "ALL_CAPIT"
|
||||
_ -> VarValue (gQId cPredef n) -- hmm
|
||||
where
|
||||
p = PredefValue . PredefId
|
||||
p = PredefValue . PredefId . rawIdentS
|
||||
|
||||
ppP p =
|
||||
case p of
|
||||
PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
|
||||
PP (m,c) ps -> ParamPattern (Param ((gQId 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
|
||||
@@ -202,6 +227,7 @@ convert' gr vs = ppT
|
||||
PFloat x -> Lit (show x)
|
||||
PT _ p -> ppP p
|
||||
PAs x p -> AsP x (ppP p) -}
|
||||
_ -> error $ "convert' ppP: " ++ show p
|
||||
where
|
||||
fields = map field . filter (not.isLockLabel.fst)
|
||||
field (l,p) = RecordRow (lblId l) (ppP p)
|
||||
@@ -218,12 +244,12 @@ convert' gr vs = ppT
|
||||
pre Empty = [""] -- Empty == K ""
|
||||
pre (Strs ts) = concatMap pre ts
|
||||
pre (EPatt p) = pat p
|
||||
pre t = error $ "pre "++show t
|
||||
pre t = error $ "convert' alts pre: " ++ show t
|
||||
|
||||
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
|
||||
pat p = error $ "convert' alts pat: "++show p
|
||||
|
||||
fields = map field . filter (not.isLockLabel.fst)
|
||||
field (l,(_,t)) = RecordRow (lblId l) (ppT t)
|
||||
@@ -236,6 +262,7 @@ convert' gr vs = ppT
|
||||
ParamConstant (Param p (ps++[a]))
|
||||
_ -> error $ "convert' ap: "++render (ppA f <+> ppA a)
|
||||
|
||||
concatValue :: LinValue -> LinValue -> LinValue
|
||||
concatValue v1 v2 =
|
||||
case (v1,v2) of
|
||||
(LiteralValue (StrConstant ""),_) -> v2
|
||||
@@ -243,21 +270,24 @@ concatValue v1 v2 =
|
||||
_ -> ConcatValue v1 v2
|
||||
|
||||
-- | Smart constructor for projections
|
||||
projection r l = maybe (Projection r l) id (proj r l)
|
||||
projection :: LinValue -> LabelId -> LinValue
|
||||
projection r l = fromMaybe (Projection r l) (proj r l)
|
||||
|
||||
proj :: LinValue -> LabelId -> Maybe LinValue
|
||||
proj r l =
|
||||
case r of
|
||||
RecordValue r -> case [v|RecordRow l' v<-r,l'==l] of
|
||||
RecordValue r -> case [v | RecordRow l' v <- r, l'==l] of
|
||||
[v] -> Just v
|
||||
_ -> Nothing
|
||||
_ -> Nothing
|
||||
|
||||
-- | Smart constructor for selections
|
||||
selection :: LinValue -> LinValue -> LinValue
|
||||
selection t v =
|
||||
-- Note: impossible cases can become possible after grammar transformation
|
||||
case t of
|
||||
TableValue tt r ->
|
||||
case nub [rv|TableRow _ rv<-keep] of
|
||||
case nub [rv | TableRow _ rv <- keep] of
|
||||
[rv] -> rv
|
||||
_ -> Selection (TableValue tt r') v
|
||||
where
|
||||
@@ -276,13 +306,16 @@ selection t v =
|
||||
(keep,discard) = partition (mightMatchRow v) r
|
||||
_ -> Selection t v
|
||||
|
||||
impossible :: LinValue -> LinValue
|
||||
impossible = CommentedValue "impossible"
|
||||
|
||||
mightMatchRow :: LinValue -> TableRow rhs -> Bool
|
||||
mightMatchRow v (TableRow p _) =
|
||||
case p of
|
||||
WildPattern -> True
|
||||
_ -> mightMatch v p
|
||||
|
||||
mightMatch :: LinValue -> LinPattern -> Bool
|
||||
mightMatch v p =
|
||||
case v of
|
||||
ConcatValue _ _ -> False
|
||||
@@ -294,16 +327,18 @@ mightMatch v p =
|
||||
RecordValue rv ->
|
||||
case p of
|
||||
RecordPattern rp ->
|
||||
and [maybe False (flip mightMatch p) (proj v l) | RecordRow l p<-rp]
|
||||
and [maybe False (`mightMatch` p) (proj v l) | RecordRow l p<-rp]
|
||||
_ -> False
|
||||
_ -> True
|
||||
|
||||
patVars :: Patt -> [Ident]
|
||||
patVars p =
|
||||
case p of
|
||||
PV x -> [x]
|
||||
PAs x p -> x:patVars p
|
||||
_ -> collectPattOp patVars p
|
||||
|
||||
convType :: Term -> LinType
|
||||
convType = ppT
|
||||
where
|
||||
ppT t =
|
||||
@@ -315,9 +350,9 @@ 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 ((gQId m n)))
|
||||
Q (m,n) -> ParamType (ParamTypeId ((gQId m n)))
|
||||
_ -> error $ "Missing case in convType for: "++show t
|
||||
QC (m,n) -> ParamType (ParamTypeId (gQId m n))
|
||||
Q (m,n) -> ParamType (ParamTypeId (gQId m n))
|
||||
_ -> error $ "convType ppT: " ++ show t
|
||||
|
||||
convFields = map convField . filter (not.isLockLabel.fst)
|
||||
convField (l,r) = RecordRow (lblId l) (ppT r)
|
||||
@@ -326,15 +361,20 @@ convType = ppT
|
||||
"Float" -> FloatType
|
||||
"Int" -> IntType
|
||||
"Str" -> StrType
|
||||
_ -> error ("convSort "++show k)
|
||||
_ -> error $ "convType convSort: " ++ show k
|
||||
|
||||
toParamType :: Term -> ParamType
|
||||
toParamType t = case convType t of
|
||||
ParamType pt -> pt
|
||||
_ -> error ("toParamType "++show t)
|
||||
_ -> error $ "toParamType: " ++ show t
|
||||
|
||||
toParamId :: Term -> ParamId
|
||||
toParamId t = case toParamType t of
|
||||
ParamTypeId p -> p
|
||||
|
||||
paramType :: G.Grammar
|
||||
-> (ModuleName, Ident)
|
||||
-> ((S.Set (ModuleName, Ident), S.Set QIdent), [ParamDef])
|
||||
paramType gr q@(_,n) =
|
||||
case lookupOrigInfo gr q of
|
||||
Ok (m,ResParam (Just (L _ ps)) _)
|
||||
@@ -342,7 +382,7 @@ paramType gr q@(_,n) =
|
||||
((S.singleton (m,n),argTypes ps),
|
||||
[ParamDef name (map (param m) ps)]
|
||||
)
|
||||
where name = (gQId m n)
|
||||
where name = gQId m n
|
||||
Ok (m,ResOper _ (Just (L _ t)))
|
||||
| m==cPredef && n==cInts ->
|
||||
((S.empty,S.empty),[]) {-
|
||||
@@ -350,36 +390,46 @@ paramType gr q@(_,n) =
|
||||
[Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-}
|
||||
| otherwise ->
|
||||
((S.singleton (m,n),paramTypes gr t),
|
||||
[ParamAliasDef ((gQId m n)) (convType t)])
|
||||
[ParamAliasDef (gQId m n) (convType t)])
|
||||
_ -> ((S.empty,S.empty),[])
|
||||
where
|
||||
param m (n,ctx) = Param ((gQId 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]
|
||||
|
||||
lblId = LabelId . render -- hmm
|
||||
modId (MN m) = ModId (showIdent m)
|
||||
lblId :: Label -> C.LabelId
|
||||
lblId (LIdent ri) = LabelId ri
|
||||
lblId (LVar i) = LabelId (rawIdentS (show i)) -- hmm
|
||||
|
||||
class FromIdent i where gId :: Ident -> i
|
||||
modId :: ModuleName -> C.ModId
|
||||
modId (MN m) = ModId (ident2raw m)
|
||||
|
||||
class FromIdent i where
|
||||
gId :: Ident -> i
|
||||
|
||||
instance FromIdent VarId where
|
||||
gId i = if isWildIdent i then Anonymous else VarId (showIdent i)
|
||||
gId i = if isWildIdent i then Anonymous else VarId (ident2raw i)
|
||||
|
||||
instance FromIdent C.FunId where gId = C.FunId . showIdent
|
||||
instance FromIdent CatId where gId = CatId . showIdent
|
||||
instance FromIdent C.FunId where gId = C.FunId . ident2raw
|
||||
instance FromIdent CatId where gId = CatId . ident2raw
|
||||
instance FromIdent ParamId where gId = ParamId . unqual
|
||||
instance FromIdent VarValueId where gId = VarValueId . unqual
|
||||
|
||||
class FromIdent i => QualIdent i where gQId :: ModuleName -> Ident -> i
|
||||
class FromIdent i => QualIdent i where
|
||||
gQId :: ModuleName -> Ident -> i
|
||||
|
||||
instance QualIdent ParamId where gQId m n = ParamId (qual m n)
|
||||
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)
|
||||
qual :: ModuleName -> Ident -> QualId
|
||||
qual m n = Qual (modId m) (ident2raw n)
|
||||
|
||||
unqual :: Ident -> QualId
|
||||
unqual n = Unqual (ident2raw n)
|
||||
|
||||
convFlags :: G.Grammar -> ModuleName -> Flags
|
||||
convFlags gr mn =
|
||||
Flags [(n,convLit v) |
|
||||
Flags [(rawIdentS n,convLit v) |
|
||||
(n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]
|
||||
where
|
||||
convLit l =
|
||||
|
||||
@@ -5,7 +5,7 @@
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/06/17 12:39:07 $
|
||||
-- > CVS $Date: 2005/06/17 12:39:07 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.8 $
|
||||
--
|
||||
@@ -22,7 +22,7 @@ import PGF.Internal
|
||||
import GF.Data.Operations
|
||||
import GF.Infra.Option
|
||||
|
||||
import Data.List --(isPrefixOf, find, intersperse)
|
||||
import Data.List(isPrefixOf,find,intercalate,intersperse,groupBy,sortBy)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
type Prefix = String -> String
|
||||
@@ -34,11 +34,12 @@ grammar2haskell :: Options
|
||||
-> PGF
|
||||
-> String
|
||||
grammar2haskell opts name gr = foldr (++++) [] $
|
||||
pragmas ++ haskPreamble gadt name derivingClause extraImports ++
|
||||
pragmas ++ haskPreamble gadt name derivingClause (extraImports ++ pgfImports) ++
|
||||
[types, gfinstances gId lexical gr'] ++ compos
|
||||
where gr' = hSkeleton gr
|
||||
gadt = haskellOption opts HaskellGADT
|
||||
dataExt = haskellOption opts HaskellData
|
||||
pgf2 = haskellOption opts HaskellPGF2
|
||||
lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat
|
||||
gId | haskellOption opts HaskellNoPrefix = rmForbiddenChars
|
||||
| otherwise = ("G"++) . rmForbiddenChars
|
||||
@@ -50,21 +51,23 @@ grammar2haskell opts name gr = foldr (++++) [] $
|
||||
derivingClause
|
||||
| dataExt = "deriving (Show,Data)"
|
||||
| otherwise = "deriving Show"
|
||||
extraImports | gadt = ["import Control.Monad.Identity",
|
||||
"import Data.Monoid"]
|
||||
extraImports | gadt = ["import Control.Monad.Identity", "import Data.Monoid"]
|
||||
| dataExt = ["import Data.Data"]
|
||||
| otherwise = []
|
||||
pgfImports | pgf2 = ["import PGF2 hiding (Tree)", "", "showCId :: CId -> String", "showCId = id"]
|
||||
| otherwise = ["import PGF hiding (Tree)"]
|
||||
types | gadt = datatypesGADT gId lexical gr'
|
||||
| otherwise = datatypes gId derivingClause lexical gr'
|
||||
compos | gadt = prCompos gId lexical gr' ++ composClass
|
||||
| otherwise = []
|
||||
|
||||
haskPreamble gadt name derivingClause extraImports =
|
||||
haskPreamble :: Bool -> String -> String -> [String] -> [String]
|
||||
haskPreamble gadt name derivingClause imports =
|
||||
[
|
||||
"module " ++ name ++ " where",
|
||||
""
|
||||
] ++ extraImports ++ [
|
||||
"import PGF hiding (Tree)",
|
||||
] ++ imports ++ [
|
||||
"",
|
||||
"----------------------------------------------------",
|
||||
"-- automatic translation from GF to Haskell",
|
||||
"----------------------------------------------------",
|
||||
@@ -85,10 +88,11 @@ haskPreamble gadt name derivingClause extraImports =
|
||||
""
|
||||
]
|
||||
|
||||
predefInst :: Bool -> String -> String -> String -> String -> String -> String
|
||||
predefInst gadt derivingClause gtyp typ destr consr =
|
||||
(if gadt
|
||||
then []
|
||||
else ("newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n")
|
||||
else "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n"
|
||||
)
|
||||
++
|
||||
"instance Gf" +++ gtyp +++ "where" ++++
|
||||
@@ -103,10 +107,10 @@ type OIdent = String
|
||||
type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
|
||||
|
||||
datatypes :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (String,HSkeleton) -> String
|
||||
datatypes gId derivingClause lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId derivingClause lexical)) . snd
|
||||
datatypes gId derivingClause lexical = foldr (+++++) "" . filter (/="") . map (hDatatype gId derivingClause lexical) . snd
|
||||
|
||||
gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
|
||||
gfinstances gId lexical (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance gId lexical m)) g
|
||||
gfinstances gId lexical (m,g) = foldr (+++++) "" $ filter (/="") $ map (gfInstance gId lexical m) g
|
||||
|
||||
|
||||
hDatatype :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String
|
||||
@@ -131,16 +135,17 @@ nonLexicalRules True rules = [r | r@(f,t) <- rules, not (null t)]
|
||||
lexicalConstructor :: OIdent -> String
|
||||
lexicalConstructor cat = "Lex" ++ cat
|
||||
|
||||
predefTypeSkel :: HSkeleton
|
||||
predefTypeSkel = [(c,[]) | c <- ["String", "Int", "Float"]]
|
||||
|
||||
-- GADT version of data types
|
||||
datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
|
||||
datatypesGADT gId lexical (_,skel) = unlines $
|
||||
datatypesGADT gId lexical (_,skel) = unlines $
|
||||
concatMap (hCatTypeGADT gId) (skel ++ predefTypeSkel) ++
|
||||
[
|
||||
"",
|
||||
[
|
||||
"",
|
||||
"data Tree :: * -> * where"
|
||||
] ++
|
||||
] ++
|
||||
concatMap (map (" "++) . hDatatypeGADT gId lexical) skel ++
|
||||
[
|
||||
" GString :: String -> Tree GString_",
|
||||
@@ -164,23 +169,23 @@ hCatTypeGADT gId (cat,rules)
|
||||
"data"+++gId cat++"_"]
|
||||
|
||||
hDatatypeGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
|
||||
hDatatypeGADT gId lexical (cat, rules)
|
||||
hDatatypeGADT gId lexical (cat, rules)
|
||||
| isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t]
|
||||
| otherwise =
|
||||
[ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t
|
||||
[ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t
|
||||
| (f,args) <- nonLexicalRules (lexical cat) rules ]
|
||||
++ if lexical cat then [lexicalConstructor cat +++ ":: String ->"+++ t] else []
|
||||
where t = "Tree" +++ gId cat ++ "_"
|
||||
|
||||
hEqGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
|
||||
hEqGADT gId lexical (cat, rules)
|
||||
| isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs]
|
||||
| isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs]
|
||||
| otherwise = ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ eqs r | r <- nonLexicalRules (lexical cat) rules]
|
||||
++ if lexical cat then ["(" ++ lexicalConstructor cat +++ "x" ++ "," ++ lexicalConstructor cat +++ "y" ++ ") -> x == y"] else []
|
||||
|
||||
where
|
||||
patt s (f,xs) = unwords (gId f : mkSVars s (length xs))
|
||||
eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y |
|
||||
eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y |
|
||||
(x,y) <- zip (mkSVars "x" (length xs)) (mkSVars "y" (length xs)) ] ++ ["]"])
|
||||
listr c = (c,["foo"]) -- foo just for length = 1
|
||||
listeqs = "and [x == y | (x,y) <- zip x1 y1]"
|
||||
@@ -189,25 +194,26 @@ prCompos :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> [String]
|
||||
prCompos gId lexical (_,catrules) =
|
||||
["instance Compos Tree where",
|
||||
" compos r a f t = case t of"]
|
||||
++
|
||||
++
|
||||
[" " ++ prComposCons (gId f) xs | (c,rs) <- catrules, not (isListCat (c,rs)),
|
||||
(f,xs) <- rs, not (null xs)]
|
||||
++
|
||||
(f,xs) <- rs, not (null xs)]
|
||||
++
|
||||
[" " ++ prComposCons (gId c) ["x1"] | (c,rs) <- catrules, isListCat (c,rs)]
|
||||
++
|
||||
++
|
||||
[" _ -> r t"]
|
||||
where
|
||||
prComposCons f xs = let vs = mkVars (length xs) in
|
||||
prComposCons f xs = let vs = mkVars (length xs) in
|
||||
f +++ unwords vs +++ "->" +++ rhs f (zip vs xs)
|
||||
rhs f vcs = "r" +++ f +++ unwords (map (prRec f) vcs)
|
||||
prRec f (v,c)
|
||||
prRec f (v,c)
|
||||
| isList f = "`a` foldr (a . a (r (:)) . f) (r [])" +++ v
|
||||
| otherwise = "`a`" +++ "f" +++ v
|
||||
isList f = (gId "List") `isPrefixOf` f
|
||||
isList f = gId "List" `isPrefixOf` f
|
||||
|
||||
gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String
|
||||
gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs
|
||||
|
||||
hInstance :: (String -> String) -> (String -> Bool) -> String -> (String, [(OIdent, [OIdent])]) -> String
|
||||
----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
|
||||
hInstance gId _ m (cat,[]) = unlines [
|
||||
"instance Show" +++ gId cat,
|
||||
@@ -216,15 +222,15 @@ hInstance gId _ m (cat,[]) = unlines [
|
||||
" gf _ = undefined",
|
||||
" fg _ = undefined"
|
||||
]
|
||||
hInstance gId lexical m (cat,rules)
|
||||
hInstance gId lexical m (cat,rules)
|
||||
| isListCat (cat,rules) =
|
||||
"instance Gf" +++ gId cat +++ "where" ++++
|
||||
" gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])"
|
||||
" gf (" ++ gId cat +++ "[" ++ intercalate "," baseVars ++ "])"
|
||||
+++ "=" +++ mkRHS ("Base"++ec) baseVars ++++
|
||||
" gf (" ++ gId cat +++ "(x:xs)) = "
|
||||
++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")]
|
||||
" gf (" ++ gId cat +++ "(x:xs)) = "
|
||||
++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")]
|
||||
-- no show for GADTs
|
||||
-- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)"
|
||||
-- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)"
|
||||
| otherwise =
|
||||
"instance Gf" +++ gId cat +++ "where\n" ++
|
||||
unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules]
|
||||
@@ -233,19 +239,22 @@ hInstance gId lexical m (cat,rules)
|
||||
ec = elemCat cat
|
||||
baseVars = mkVars (baseSize (cat,rules))
|
||||
mkInst f xx = let xx' = mkVars (length xx) in " gf " ++
|
||||
(if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
|
||||
(if null xx then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
|
||||
"=" +++ mkRHS f xx'
|
||||
mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++
|
||||
"[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
|
||||
mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++
|
||||
"[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
|
||||
|
||||
mkVars :: Int -> [String]
|
||||
mkVars = mkSVars "x"
|
||||
|
||||
mkSVars :: String -> Int -> [String]
|
||||
mkSVars s n = [s ++ show i | i <- [1..n]]
|
||||
|
||||
----fInstance m ("Cn",_) = "" ---
|
||||
fInstance _ _ m (cat,[]) = ""
|
||||
fInstance gId lexical m (cat,rules) =
|
||||
" fg t =" ++++
|
||||
(if isList
|
||||
(if isList
|
||||
then " " ++ gId cat ++ " (fgs t) where\n fgs t = case unApp t of"
|
||||
else " case unApp t of") ++++
|
||||
unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++
|
||||
@@ -257,27 +266,28 @@ fInstance gId lexical m (cat,rules) =
|
||||
" Just (i," ++
|
||||
"[" ++ prTList "," xx' ++ "])" +++
|
||||
"| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx'
|
||||
where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
|
||||
mkRHS f vars
|
||||
| isList =
|
||||
if "Base" `isPrefixOf` f
|
||||
then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
|
||||
else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1)
|
||||
| otherwise =
|
||||
gId f +++
|
||||
prTList " " [prParenth ("fg" +++ x) | x <- vars]
|
||||
where
|
||||
xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
|
||||
mkRHS f vars
|
||||
| isList =
|
||||
if "Base" `isPrefixOf` f
|
||||
then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
|
||||
else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1)
|
||||
| otherwise =
|
||||
gId f +++
|
||||
prTList " " [prParenth ("fg" +++ x) | x <- vars]
|
||||
|
||||
--type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
|
||||
hSkeleton :: PGF -> (String,HSkeleton)
|
||||
hSkeleton gr =
|
||||
(showCId (absname gr),
|
||||
let fs =
|
||||
[(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) |
|
||||
hSkeleton gr =
|
||||
(showCId (absname gr),
|
||||
let fs =
|
||||
[(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) |
|
||||
fs@((_, (_,c)):_) <- fns]
|
||||
in fs ++ [(sc, []) | c <- cts, let sc = showCId c, notElem sc (["Int", "Float", "String"] ++ map fst fs)]
|
||||
in fs ++ [(sc, []) | c <- cts, let sc = showCId c, sc `notElem` (["Int", "Float", "String"] ++ map fst fs)]
|
||||
)
|
||||
where
|
||||
cts = Map.keys (cats (abstract gr))
|
||||
cts = Map.keys (cats (abstract gr))
|
||||
fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
|
||||
valtyps (_, (_,x)) (_, (_,y)) = compare x y
|
||||
valtypg (_, (_,x)) (_, (_,y)) = x == y
|
||||
@@ -291,9 +301,10 @@ updateSkeleton cat skel rule =
|
||||
-}
|
||||
isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool
|
||||
isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2
|
||||
&& ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
|
||||
where c = elemCat cat
|
||||
fs = map fst rules
|
||||
&& ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
|
||||
where
|
||||
c = elemCat cat
|
||||
fs = map fst rules
|
||||
|
||||
-- | Gets the element category of a list category.
|
||||
elemCat :: OIdent -> OIdent
|
||||
@@ -310,7 +321,7 @@ baseSize (_,rules) = length bs
|
||||
where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules
|
||||
|
||||
composClass :: [String]
|
||||
composClass =
|
||||
composClass =
|
||||
[
|
||||
"",
|
||||
"class Compos t where",
|
||||
@@ -337,4 +348,3 @@ composClass =
|
||||
"",
|
||||
"newtype C b a = C { unC :: b }"
|
||||
]
|
||||
|
||||
|
||||
@@ -39,6 +39,7 @@ import GF.Data.Operations
|
||||
|
||||
import Control.Monad
|
||||
import Data.List (nub,(\\))
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe(mapMaybe)
|
||||
import GF.Text.Pretty
|
||||
@@ -105,7 +106,26 @@ renameIdentTerm' env@(act,imps) t0 =
|
||||
ts@(t:_) -> do checkWarn ("atomic term" <+> ppTerm Qualified 0 t0 $$
|
||||
"conflict" <+> hsep (punctuate ',' (map (ppTerm Qualified 0) ts)) $$
|
||||
"given" <+> fsep (punctuate ',' (map fst qualifs)))
|
||||
return t
|
||||
return (bestTerm ts) -- Heuristic for resource grammar. Returns t for all others.
|
||||
where
|
||||
-- Hotfix for https://github.com/GrammaticalFramework/gf-core/issues/56
|
||||
-- Real bug is probably somewhere deeper in recognising excluded functions. /IL 2020-06-06
|
||||
notFromCommonModule :: Term -> Bool
|
||||
notFromCommonModule term =
|
||||
let t = render $ ppTerm Qualified 0 term :: String
|
||||
in not $ any (\moduleName -> moduleName `L.isPrefixOf` t)
|
||||
["CommonX", "ConstructX", "ExtendFunctor"
|
||||
,"MarkHTMLX", "ParamX", "TenseX", "TextX"]
|
||||
|
||||
-- If one of the terms comes from the common modules,
|
||||
-- we choose the other one, because that's defined in the grammar.
|
||||
bestTerm :: [Term] -> Term
|
||||
bestTerm [] = error "constant not found" -- not reached: bestTerm is only called for case ts@(t:_)
|
||||
bestTerm ts@(t:_) =
|
||||
let notCommon = [t | t <- ts, notFromCommonModule t]
|
||||
in case notCommon of
|
||||
[] -> t -- All terms are from common modules, return first of original list
|
||||
(u:_) -> u -- ≥1 terms are not from common modules, return first of those
|
||||
|
||||
info2status :: Maybe ModuleName -> Ident -> Info -> StatusInfo
|
||||
info2status mq c i = case i of
|
||||
|
||||
@@ -11,6 +11,7 @@
|
||||
module GF.Grammar.Canonical where
|
||||
import Prelude hiding ((<>))
|
||||
import GF.Text.Pretty
|
||||
import GF.Infra.Ident (RawIdent)
|
||||
|
||||
-- | A Complete grammar
|
||||
data Grammar = Grammar Abstract [Concrete] deriving Show
|
||||
@@ -126,7 +127,7 @@ data FlagValue = Str String | Int Int | Flt Double deriving Show
|
||||
|
||||
-- *** Identifiers
|
||||
|
||||
type Id = String
|
||||
type Id = RawIdent
|
||||
data QualId = Qual ModId Id | Unqual Id deriving (Eq,Ord,Show)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
@@ -7,6 +7,7 @@ import Control.Applicative ((<|>))
|
||||
import Data.Ratio (denominator, numerator)
|
||||
import GF.Grammar.Canonical
|
||||
import Control.Monad (guard)
|
||||
import GF.Infra.Ident (RawIdent,showRawIdent,rawIdentS)
|
||||
|
||||
|
||||
encodeJSON :: FilePath -> Grammar -> IO ()
|
||||
@@ -29,7 +30,7 @@ instance JSON Grammar where
|
||||
-- ** Abstract Syntax
|
||||
|
||||
instance JSON Abstract where
|
||||
showJSON (Abstract absid flags cats funs)
|
||||
showJSON (Abstract absid flags cats funs)
|
||||
= makeObj [("abs", showJSON absid),
|
||||
("flags", showJSON flags),
|
||||
("cats", showJSON cats),
|
||||
@@ -81,7 +82,7 @@ instance JSON TypeBinding where
|
||||
-- ** Concrete syntax
|
||||
|
||||
instance JSON Concrete where
|
||||
showJSON (Concrete cncid absid flags params lincats lins)
|
||||
showJSON (Concrete cncid absid flags params lincats lins)
|
||||
= makeObj [("cnc", showJSON cncid),
|
||||
("abs", showJSON absid),
|
||||
("flags", showJSON flags),
|
||||
@@ -204,12 +205,12 @@ 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 = showJSONs [row]
|
||||
showJSONs rows = makeObj (map toRow rows)
|
||||
where toRow (RecordRow (LabelId lbl) val) = (lbl, showJSON val)
|
||||
where toRow (RecordRow (LabelId lbl) val) = (showRawIdent 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)
|
||||
return (RecordRow (LabelId (rawIdentS lbl)) value)
|
||||
|
||||
instance JSON rhs => JSON (TableRow rhs) where
|
||||
showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)]
|
||||
@@ -219,19 +220,19 @@ instance JSON rhs => JSON (TableRow rhs) where
|
||||
|
||||
-- *** Identifiers in Concrete Syntax
|
||||
|
||||
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
|
||||
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 ; 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 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:
|
||||
@@ -242,20 +243,24 @@ instance JSON VarId where
|
||||
<|> VarId <$> readJSON o
|
||||
|
||||
instance JSON QualId where
|
||||
showJSON (Qual (ModId m) n) = showJSON (m++"."++n)
|
||||
showJSON (Qual (ModId m) n) = showJSON (showRawIdent m++"."++showRawIdent 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
|
||||
return $ if null mod then Unqual (rawIdentS id) else Qual (ModId (rawIdentS mod)) (rawIdentS id)
|
||||
|
||||
instance JSON RawIdent where
|
||||
showJSON i = showJSON $ showRawIdent i
|
||||
readJSON o = rawIdentS <$> readJSON o
|
||||
|
||||
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 [(showRawIdent f, showJSON v) | (f, v) <- fs]
|
||||
|
||||
readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj)
|
||||
where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
|
||||
return (lbl, value)
|
||||
return (rawIdentS lbl, value)
|
||||
|
||||
instance JSON FlagValue where
|
||||
-- flag values are encoded as basic JSON types:
|
||||
|
||||
@@ -5,7 +5,7 @@
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/11/11 16:38:00 $
|
||||
-- > CVS $Date: 2005/11/11 16:38:00 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.24 $
|
||||
--
|
||||
@@ -51,14 +51,14 @@ typeForm t =
|
||||
_ -> error (render ("no normal form of type" <+> ppTerm Unqualified 0 t))
|
||||
|
||||
typeFormCnc :: Type -> (Context, Type)
|
||||
typeFormCnc t =
|
||||
typeFormCnc t =
|
||||
case t of
|
||||
Prod b x a t -> let (x', v) = typeFormCnc t
|
||||
in ((b,x,a):x',v)
|
||||
_ -> ([],t)
|
||||
|
||||
valCat :: Type -> Cat
|
||||
valCat typ =
|
||||
valCat typ =
|
||||
let (_,cat,_) = typeForm typ
|
||||
in cat
|
||||
|
||||
@@ -99,7 +99,7 @@ isHigherOrderType t = fromErr True $ do -- pessimistic choice
|
||||
contextOfType :: Monad m => Type -> m Context
|
||||
contextOfType typ = case typ of
|
||||
Prod b x a t -> liftM ((b,x,a):) $ contextOfType t
|
||||
_ -> return []
|
||||
_ -> return []
|
||||
|
||||
termForm :: Monad m => Term -> m ([(BindType,Ident)], Term, [Term])
|
||||
termForm t = case t of
|
||||
@@ -108,8 +108,8 @@ termForm t = case t of
|
||||
return ((b,x):x', fun, args)
|
||||
App c a ->
|
||||
do (_,fun, args) <- termForm c
|
||||
return ([],fun,args ++ [a])
|
||||
_ ->
|
||||
return ([],fun,args ++ [a])
|
||||
_ ->
|
||||
return ([],t,[])
|
||||
|
||||
termFormCnc :: Term -> ([(BindType,Ident)], Term)
|
||||
@@ -254,7 +254,7 @@ mkTable :: [Term] -> Term -> Term
|
||||
mkTable tt t = foldr Table t tt
|
||||
|
||||
mkCTable :: [(BindType,Ident)] -> Term -> Term
|
||||
mkCTable ids v = foldr ccase v ids where
|
||||
mkCTable ids v = foldr ccase v ids where
|
||||
ccase (_,x) t = T TRaw [(PV x,t)]
|
||||
|
||||
mkHypo :: Term -> Hypo
|
||||
@@ -287,7 +287,7 @@ plusRecType t1 t2 = case (t1, t2) of
|
||||
filter (`elem` (map fst r1)) (map fst r2) of
|
||||
[] -> return (RecType (r1 ++ r2))
|
||||
ls -> raise $ render ("clashing labels" <+> hsep ls)
|
||||
_ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)
|
||||
_ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)
|
||||
|
||||
--plusRecord :: Term -> Term -> Err Term
|
||||
plusRecord t1 t2 =
|
||||
@@ -304,7 +304,7 @@ defLinType = RecType [(theLinLabel, typeStr)]
|
||||
|
||||
-- | refreshing variables
|
||||
mkFreshVar :: [Ident] -> Ident
|
||||
mkFreshVar olds = varX (maxVarIndex olds + 1)
|
||||
mkFreshVar olds = varX (maxVarIndex olds + 1)
|
||||
|
||||
-- | trying to preserve a given symbol
|
||||
mkFreshVarX :: [Ident] -> Ident -> Ident
|
||||
@@ -313,7 +313,7 @@ mkFreshVarX olds x = if (elem x olds) then (varX (maxVarIndex olds + 1)) else x
|
||||
maxVarIndex :: [Ident] -> Int
|
||||
maxVarIndex = maximum . ((-1):) . map varIndex
|
||||
|
||||
mkFreshVars :: Int -> [Ident] -> [Ident]
|
||||
mkFreshVars :: Int -> [Ident] -> [Ident]
|
||||
mkFreshVars n olds = [varX (maxVarIndex olds + i) | i <- [1..n]]
|
||||
|
||||
-- | quick hack for refining with var in editor
|
||||
@@ -413,11 +413,11 @@ patt2term pt = case pt of
|
||||
PC c pp -> mkApp (Con c) (map patt2term pp)
|
||||
PP c pp -> mkApp (QC c) (map patt2term pp)
|
||||
|
||||
PR r -> R [assign l (patt2term p) | (l,p) <- r]
|
||||
PR r -> R [assign l (patt2term p) | (l,p) <- r]
|
||||
PT _ p -> patt2term p
|
||||
PInt i -> EInt i
|
||||
PFloat i -> EFloat i
|
||||
PString s -> K s
|
||||
PString s -> K s
|
||||
|
||||
PAs x p -> appCons cAs [Vr x, patt2term p] --- an encoding
|
||||
PChar -> appCons cChar [] --- an encoding
|
||||
@@ -436,7 +436,7 @@ composSafeOp op = runIdentity . composOp (return . op)
|
||||
|
||||
-- | to define compositional term functions
|
||||
composOp :: Monad m => (Term -> m Term) -> Term -> m Term
|
||||
composOp co trm =
|
||||
composOp co trm =
|
||||
case trm of
|
||||
App c a -> liftM2 App (co c) (co a)
|
||||
Abs b x t -> liftM (Abs b x) (co t)
|
||||
@@ -552,13 +552,13 @@ strsFromTerm t = case t of
|
||||
v0 <- mapM (strsFromTerm . fst) vs
|
||||
c0 <- mapM (strsFromTerm . snd) vs
|
||||
--let vs' = zip v0 c0
|
||||
return [strTok (str2strings def) vars |
|
||||
return [strTok (str2strings def) vars |
|
||||
def <- d0,
|
||||
vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |
|
||||
vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |
|
||||
vv <- sequence v0]
|
||||
]
|
||||
FV ts -> mapM strsFromTerm ts >>= return . concat
|
||||
Strs ts -> mapM strsFromTerm ts >>= return . concat
|
||||
Strs ts -> mapM strsFromTerm ts >>= return . concat
|
||||
_ -> raise (render ("cannot get Str from term" <+> ppTerm Unqualified 0 t))
|
||||
|
||||
getTableType :: TInfo -> Err Type
|
||||
@@ -590,11 +590,11 @@ noExist = FV []
|
||||
defaultLinType :: Type
|
||||
defaultLinType = mkRecType linLabel [typeStr]
|
||||
|
||||
-- normalize records and record types; put s first
|
||||
-- | normalize records and record types; put s first
|
||||
|
||||
sortRec :: [(Label,a)] -> [(Label,a)]
|
||||
sortRec = sortBy ordLabel where
|
||||
ordLabel (r1,_) (r2,_) =
|
||||
ordLabel (r1,_) (r2,_) =
|
||||
case (showIdent (label2ident r1), showIdent (label2ident r2)) of
|
||||
("s",_) -> LT
|
||||
(_,"s") -> GT
|
||||
@@ -605,7 +605,7 @@ sortRec = sortBy ordLabel where
|
||||
-- | dependency check, detecting circularities and returning topo-sorted list
|
||||
|
||||
allDependencies :: (ModuleName -> Bool) -> Map.Map Ident Info -> [(Ident,[Ident])]
|
||||
allDependencies ism b =
|
||||
allDependencies ism b =
|
||||
[(f, nub (concatMap opty (pts i))) | (f,i) <- Map.toList b]
|
||||
where
|
||||
opersIn t = case t of
|
||||
|
||||
@@ -5,7 +5,7 @@
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/11/15 11:43:33 $
|
||||
-- > CVS $Date: 2005/11/15 11:43:33 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.8 $
|
||||
--
|
||||
@@ -13,18 +13,18 @@
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Infra.Ident (-- ** Identifiers
|
||||
ModuleName(..), moduleNameS,
|
||||
Ident, ident2utf8, showIdent, prefixIdent,
|
||||
-- *** Normal identifiers (returned by the parser)
|
||||
identS, identC, identW,
|
||||
-- *** Special identifiers for internal use
|
||||
identV, identA, identAV,
|
||||
argIdent, isArgIdent, getArgIndex,
|
||||
varStr, varX, isWildIdent, varIndex,
|
||||
-- *** Raw identifiers
|
||||
RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
|
||||
isPrefixOf, showRawIdent
|
||||
) where
|
||||
ModuleName(..), moduleNameS,
|
||||
Ident, ident2utf8, showIdent, prefixIdent,
|
||||
-- *** Normal identifiers (returned by the parser)
|
||||
identS, identC, identW,
|
||||
-- *** Special identifiers for internal use
|
||||
identV, identA, identAV,
|
||||
argIdent, isArgIdent, getArgIndex,
|
||||
varStr, varX, isWildIdent, varIndex,
|
||||
-- *** Raw identifiers
|
||||
RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
|
||||
isPrefixOf, showRawIdent
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString.UTF8 as UTF8
|
||||
import qualified Data.ByteString.Char8 as BS(append,isPrefixOf)
|
||||
@@ -46,7 +46,7 @@ instance Pretty ModuleName where pp (MN m) = pp m
|
||||
|
||||
-- | the constructors labelled /INTERNAL/ are
|
||||
-- internal representation never returned by the parser
|
||||
data Ident =
|
||||
data Ident =
|
||||
IC {-# UNPACK #-} !RawIdent -- ^ raw identifier after parsing, resolved in Rename
|
||||
| IW -- ^ wildcard
|
||||
--
|
||||
@@ -54,7 +54,7 @@ data Ident =
|
||||
| IV {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int -- ^ /INTERNAL/ variable
|
||||
| IA {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int -- ^ /INTERNAL/ argument of cat at position
|
||||
| IAV {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int {-# UNPACK #-} !Int -- ^ /INTERNAL/ argument of cat with bindings at position
|
||||
--
|
||||
--
|
||||
deriving (Eq, Ord, Show, Read)
|
||||
|
||||
-- | Identifiers are stored as UTF-8-encoded bytestrings.
|
||||
@@ -70,14 +70,13 @@ rawIdentS = Id . pack
|
||||
rawIdentC = Id
|
||||
showRawIdent = unpack . rawId2utf8
|
||||
|
||||
prefixRawIdent (Id x) (Id y) = Id (BS.append x y)
|
||||
prefixRawIdent (Id x) (Id y) = Id (BS.append x y)
|
||||
isPrefixOf (Id x) (Id y) = BS.isPrefixOf x y
|
||||
|
||||
instance Binary RawIdent where
|
||||
put = put . rawId2utf8
|
||||
get = fmap rawIdentC get
|
||||
|
||||
|
||||
-- | This function should be used with care, since the returned ByteString is
|
||||
-- UTF-8-encoded.
|
||||
ident2utf8 :: Ident -> UTF8.ByteString
|
||||
@@ -88,6 +87,7 @@ ident2utf8 i = case i of
|
||||
IAV (Id s) b j -> BS.append s (pack ('_':show b ++ '_':show j))
|
||||
IW -> pack "_"
|
||||
|
||||
ident2raw :: Ident -> RawIdent
|
||||
ident2raw = Id . ident2utf8
|
||||
|
||||
showIdent :: Ident -> String
|
||||
@@ -95,13 +95,14 @@ showIdent i = unpack $! ident2utf8 i
|
||||
|
||||
instance Pretty Ident where pp = pp . showIdent
|
||||
|
||||
instance Pretty RawIdent where pp = pp . showRawIdent
|
||||
|
||||
identS :: String -> Ident
|
||||
identS = identC . rawIdentS
|
||||
|
||||
identC :: RawIdent -> Ident
|
||||
identW :: Ident
|
||||
|
||||
|
||||
prefixIdent :: String -> Ident -> Ident
|
||||
prefixIdent pref = identC . Id . BS.append (pack pref) . ident2utf8
|
||||
|
||||
@@ -112,7 +113,7 @@ identV :: RawIdent -> Int -> Ident
|
||||
identA :: RawIdent -> Int -> Ident
|
||||
identAV:: RawIdent -> Int -> Int -> Ident
|
||||
|
||||
(identC, identV, identA, identAV, identW) =
|
||||
(identC, identV, identA, identAV, identW) =
|
||||
(IC, IV, IA, IAV, IW)
|
||||
|
||||
-- | to mark argument variables
|
||||
|
||||
@@ -2,13 +2,13 @@ module GF.Infra.Option
|
||||
(
|
||||
-- ** Command line options
|
||||
-- *** Option types
|
||||
Options,
|
||||
Flags(..),
|
||||
Mode(..), Phase(..), Verbosity(..),
|
||||
OutputFormat(..),
|
||||
Options,
|
||||
Flags(..),
|
||||
Mode(..), Phase(..), Verbosity(..),
|
||||
OutputFormat(..),
|
||||
SISRFormat(..), Optimization(..), CFGTransform(..), HaskellOption(..),
|
||||
Dump(..), Pass(..), Recomp(..),
|
||||
outputFormatsExpl,
|
||||
outputFormatsExpl,
|
||||
-- *** Option parsing
|
||||
parseOptions, parseModuleOptions, fixRelativeLibPaths,
|
||||
-- *** Option pretty-printing
|
||||
@@ -47,7 +47,7 @@ import PGF.Internal(Literal(..))
|
||||
import qualified Control.Monad.Fail as Fail
|
||||
|
||||
usageHeader :: String
|
||||
usageHeader = unlines
|
||||
usageHeader = unlines
|
||||
["Usage: gf [OPTIONS] [FILE [...]]",
|
||||
"",
|
||||
"How each FILE is handled depends on the file name suffix:",
|
||||
@@ -90,10 +90,10 @@ data Phase = Preproc | Convert | Compile | Link
|
||||
data OutputFormat = FmtPGFPretty
|
||||
| FmtCanonicalGF
|
||||
| FmtCanonicalJson
|
||||
| FmtJavaScript
|
||||
| FmtJavaScript
|
||||
| FmtJSON
|
||||
| FmtPython
|
||||
| FmtHaskell
|
||||
| FmtPython
|
||||
| FmtHaskell
|
||||
| FmtJava
|
||||
| FmtProlog
|
||||
| FmtBNF
|
||||
@@ -102,37 +102,42 @@ data OutputFormat = FmtPGFPretty
|
||||
| FmtNoLR
|
||||
| FmtSRGS_XML
|
||||
| FmtSRGS_XML_NonRec
|
||||
| FmtSRGS_ABNF
|
||||
| FmtSRGS_ABNF
|
||||
| FmtSRGS_ABNF_NonRec
|
||||
| FmtJSGF
|
||||
| FmtGSL
|
||||
| FmtJSGF
|
||||
| FmtGSL
|
||||
| FmtVoiceXML
|
||||
| FmtSLF
|
||||
| FmtRegExp
|
||||
| FmtFA
|
||||
deriving (Eq,Ord)
|
||||
|
||||
data SISRFormat =
|
||||
data SISRFormat =
|
||||
-- | SISR Working draft 1 April 2003
|
||||
-- <http://www.w3.org/TR/2003/WD-semantic-interpretation-20030401/>
|
||||
SISR_WD20030401
|
||||
SISR_WD20030401
|
||||
| SISR_1_0
|
||||
deriving (Show,Eq,Ord)
|
||||
|
||||
data Optimization = OptStem | OptCSE | OptExpand | OptParametrize
|
||||
deriving (Show,Eq,Ord)
|
||||
|
||||
data CFGTransform = CFGNoLR
|
||||
data CFGTransform = CFGNoLR
|
||||
| CFGRegular
|
||||
| CFGTopDownFilter
|
||||
| CFGBottomUpFilter
|
||||
| CFGTopDownFilter
|
||||
| CFGBottomUpFilter
|
||||
| CFGStartCatOnly
|
||||
| CFGMergeIdentical
|
||||
| CFGRemoveCycles
|
||||
deriving (Show,Eq,Ord)
|
||||
|
||||
data HaskellOption = HaskellNoPrefix | HaskellGADT | HaskellLexical
|
||||
| HaskellConcrete | HaskellVariants | HaskellData
|
||||
data HaskellOption = HaskellNoPrefix
|
||||
| HaskellGADT
|
||||
| HaskellLexical
|
||||
| HaskellConcrete
|
||||
| HaskellVariants
|
||||
| HaskellData
|
||||
| HaskellPGF2
|
||||
deriving (Show,Eq,Ord)
|
||||
|
||||
data Warning = WarnMissingLincat
|
||||
@@ -196,7 +201,7 @@ instance Show Options where
|
||||
parseOptions :: ErrorMonad err =>
|
||||
[String] -- ^ list of string arguments
|
||||
-> err (Options, [FilePath])
|
||||
parseOptions args
|
||||
parseOptions args
|
||||
| not (null errs) = errors errs
|
||||
| otherwise = do opts <- concatOptions `fmap` liftErr (sequence optss)
|
||||
return (opts, files)
|
||||
@@ -208,7 +213,7 @@ parseModuleOptions :: ErrorMonad err =>
|
||||
-> err Options
|
||||
parseModuleOptions args = do
|
||||
(opts,nonopts) <- parseOptions args
|
||||
if null nonopts
|
||||
if null nonopts
|
||||
then return opts
|
||||
else errors $ map ("Non-option among module options: " ++) nonopts
|
||||
|
||||
@@ -281,7 +286,7 @@ defaultFlags = Flags {
|
||||
optOptimizations = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize],
|
||||
optOptimizePGF = False,
|
||||
optSplitPGF = False,
|
||||
optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter,
|
||||
optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter,
|
||||
CFGTopDownFilter, CFGMergeIdentical],
|
||||
optLibraryPath = [],
|
||||
optStartCat = Nothing,
|
||||
@@ -301,7 +306,7 @@ defaultFlags = Flags {
|
||||
-- | Option descriptions
|
||||
{-# NOINLINE optDescr #-}
|
||||
optDescr :: [OptDescr (Err Options)]
|
||||
optDescr =
|
||||
optDescr =
|
||||
[
|
||||
Option ['?','h'] ["help"] (NoArg (mode ModeHelp)) "Show help message.",
|
||||
Option ['V'] ["version"] (NoArg (mode ModeVersion)) "Display GF version number.",
|
||||
@@ -327,44 +332,44 @@ optDescr =
|
||||
-- Option ['t'] ["trace"] (NoArg (trace True)) "Trace computations",
|
||||
-- Option [] ["no-trace"] (NoArg (trace False)) "Don't trace computations",
|
||||
Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').",
|
||||
Option ['f'] ["output-format"] (ReqArg outFmt "FMT")
|
||||
Option ['f'] ["output-format"] (ReqArg outFmt "FMT")
|
||||
(unlines ["Output format. FMT can be one of:",
|
||||
"Canonical GF grammar: canonical_gf, canonical_json, (and haskell with option --haskell=concrete)",
|
||||
"Multiple concrete: pgf (default), json, 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,
|
||||
Option [] ["sisr"] (ReqArg sisrFmt "FMT")
|
||||
Option [] ["sisr"] (ReqArg sisrFmt "FMT")
|
||||
(unlines ["Include SISR tags in generated speech recognition grammars.",
|
||||
"FMT can be one of: old, 1.0"]),
|
||||
Option [] ["haskell"] (ReqArg hsOption "OPTION")
|
||||
("Turn on an optional feature when generating Haskell data types. OPTION = "
|
||||
Option [] ["haskell"] (ReqArg hsOption "OPTION")
|
||||
("Turn on an optional feature when generating Haskell data types. OPTION = "
|
||||
++ concat (intersperse " | " (map fst haskellOptionNames))),
|
||||
Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]")
|
||||
Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]")
|
||||
"Treat CAT as a lexical category.",
|
||||
Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]")
|
||||
Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]")
|
||||
"Treat CAT as a literal category.",
|
||||
Option ['D'] ["output-dir"] (ReqArg outDir "DIR")
|
||||
Option ['D'] ["output-dir"] (ReqArg outDir "DIR")
|
||||
"Save output files (other than .gfo files) in DIR.",
|
||||
Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR")
|
||||
Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR")
|
||||
"Overrides the value of GF_LIB_PATH.",
|
||||
Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp))
|
||||
Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp))
|
||||
"Always recompile from source.",
|
||||
Option [] ["recomp-if-newer"] (NoArg (recomp RecompIfNewer))
|
||||
Option [] ["recomp-if-newer"] (NoArg (recomp RecompIfNewer))
|
||||
"(default) Recompile from source if the source is newer than the .gfo file.",
|
||||
Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp))
|
||||
Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp))
|
||||
"Never recompile from source, if there is already .gfo file.",
|
||||
Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.",
|
||||
Option [] ["probs"] (ReqArg probsFile "file.probs") "Read probabilities from file.",
|
||||
Option ['n'] ["name"] (ReqArg name "NAME")
|
||||
Option ['n'] ["name"] (ReqArg name "NAME")
|
||||
(unlines ["Use NAME as the name of the output. This is used in the output file names, ",
|
||||
"with suffixes depending on the formats, and, when relevant, ",
|
||||
"internally in the output."]),
|
||||
Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.",
|
||||
Option [] ["path"] (ReqArg setLibPath "DIR:DIR:...") "Set the library search path.",
|
||||
Option [] ["preproc"] (ReqArg preproc "CMD")
|
||||
Option [] ["preproc"] (ReqArg preproc "CMD")
|
||||
(unlines ["Use CMD to preprocess input files.",
|
||||
"Multiple preprocessors can be used by giving this option multiple times."]),
|
||||
Option [] ["coding"] (ReqArg coding "ENCODING")
|
||||
Option [] ["coding"] (ReqArg coding "ENCODING")
|
||||
("Character encoding of the source grammar, ENCODING = utf8, latin1, cp1251, ..."),
|
||||
Option [] ["startcat"] (ReqArg startcat "CAT") "Grammar start category.",
|
||||
Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.",
|
||||
@@ -372,7 +377,7 @@ optDescr =
|
||||
Option [] ["unlexer"] (ReqArg unlexer "UNLEXER") "Use unlexer UNLEXER.",
|
||||
Option [] ["pmcfg"] (NoArg (pmcfg True)) "Generate PMCFG (default).",
|
||||
Option [] ["no-pmcfg"] (NoArg (pmcfg False)) "Don't generate PMCFG (useful for libraries).",
|
||||
Option [] ["optimize"] (ReqArg optimize "OPT")
|
||||
Option [] ["optimize"] (ReqArg optimize "OPT")
|
||||
"Select an optimization package. OPT = all | values | parametrize | none",
|
||||
Option [] ["optimize-pgf"] (NoArg (optimize_pgf True))
|
||||
"Enable or disable global grammar optimization. This could significantly reduce the size of the final PGF file",
|
||||
@@ -447,7 +452,7 @@ optDescr =
|
||||
optimize x = case lookup x optimizationPackages of
|
||||
Just p -> set $ \o -> o { optOptimizations = p }
|
||||
Nothing -> fail $ "Unknown optimization package: " ++ x
|
||||
|
||||
|
||||
optimize_pgf x = set $ \o -> o { optOptimizePGF = x }
|
||||
splitPGF x = set $ \o -> o { optSplitPGF = x }
|
||||
|
||||
@@ -471,7 +476,7 @@ outputFormats :: [(String,OutputFormat)]
|
||||
outputFormats = map fst outputFormatsExpl
|
||||
|
||||
outputFormatsExpl :: [((String,OutputFormat),String)]
|
||||
outputFormatsExpl =
|
||||
outputFormatsExpl =
|
||||
[(("pgf_pretty", FmtPGFPretty),"human-readable pgf"),
|
||||
(("canonical_gf", FmtCanonicalGF),"Canonical GF source files"),
|
||||
(("canonical_json", FmtCanonicalJson),"Canonical JSON source files"),
|
||||
@@ -504,11 +509,11 @@ instance Read OutputFormat where
|
||||
readsPrec = lookupReadsPrec outputFormats
|
||||
|
||||
optimizationPackages :: [(String, Set Optimization)]
|
||||
optimizationPackages =
|
||||
optimizationPackages =
|
||||
[("all", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
|
||||
("values", Set.fromList [OptStem,OptCSE,OptExpand]),
|
||||
("noexpand", Set.fromList [OptStem,OptCSE]),
|
||||
|
||||
|
||||
-- deprecated
|
||||
("all_subs", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
|
||||
("parametrize", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
|
||||
@@ -516,7 +521,7 @@ optimizationPackages =
|
||||
]
|
||||
|
||||
cfgTransformNames :: [(String, CFGTransform)]
|
||||
cfgTransformNames =
|
||||
cfgTransformNames =
|
||||
[("nolr", CFGNoLR),
|
||||
("regular", CFGRegular),
|
||||
("topdown", CFGTopDownFilter),
|
||||
@@ -532,7 +537,8 @@ haskellOptionNames =
|
||||
("lexical", HaskellLexical),
|
||||
("concrete", HaskellConcrete),
|
||||
("variants", HaskellVariants),
|
||||
("data", HaskellData)]
|
||||
("data", HaskellData),
|
||||
("pgf2", HaskellPGF2)]
|
||||
|
||||
-- | This is for bacward compatibility. Since GHC 6.12 we
|
||||
-- started using the native Unicode support in GHC but it
|
||||
@@ -558,7 +564,7 @@ onOff f def = OptArg g "[on,off]"
|
||||
_ -> fail $ "Expected [on,off], got: " ++ show x
|
||||
|
||||
readOutputFormat :: Fail.MonadFail m => String -> m OutputFormat
|
||||
readOutputFormat s =
|
||||
readOutputFormat s =
|
||||
maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats
|
||||
|
||||
-- FIXME: this is a copy of the function in GF.Devel.UseIO.
|
||||
@@ -570,7 +576,7 @@ splitInModuleSearchPath s = case break isPathSep s of
|
||||
isPathSep :: Char -> Bool
|
||||
isPathSep c = c == ':' || c == ';'
|
||||
|
||||
--
|
||||
--
|
||||
-- * Convenience functions for checking options
|
||||
--
|
||||
|
||||
@@ -592,7 +598,7 @@ isLiteralCat opts c = Set.member c (flag optLiteralCats opts)
|
||||
isLexicalCat :: Options -> String -> Bool
|
||||
isLexicalCat opts c = Set.member c (flag optLexicalCats opts)
|
||||
|
||||
--
|
||||
--
|
||||
-- * Convenience functions for setting options
|
||||
--
|
||||
|
||||
@@ -623,8 +629,8 @@ readMaybe s = case reads s of
|
||||
|
||||
toEnumBounded :: (Bounded a, Enum a, Ord a) => Int -> Maybe a
|
||||
toEnumBounded i = let mi = minBound
|
||||
ma = maxBound `asTypeOf` mi
|
||||
in if i >= fromEnum mi && i <= fromEnum ma
|
||||
ma = maxBound `asTypeOf` mi
|
||||
in if i >= fromEnum mi && i <= fromEnum ma
|
||||
then Just (toEnum i `asTypeOf` mi)
|
||||
else Nothing
|
||||
|
||||
|
||||
1
testsuite/canonical/.gitignore
vendored
Normal file
1
testsuite/canonical/.gitignore
vendored
Normal file
@@ -0,0 +1 @@
|
||||
canonical/
|
||||
102
testsuite/canonical/gold/FoodsFin.gf
Normal file
102
testsuite/canonical/gold/FoodsFin.gf
Normal file
@@ -0,0 +1,102 @@
|
||||
concrete FoodsFin of Foods = {
|
||||
param ParamX_Number = ParamX_Sg | ParamX_Pl;
|
||||
param Prelude_Bool = Prelude_False | Prelude_True;
|
||||
param ResFin_Agr = ResFin_Ag ParamX_Number ParamX_Person | ResFin_AgPol;
|
||||
param ParamX_Person = ParamX_P1 | ParamX_P2 | ParamX_P3;
|
||||
param ResFin_Harmony = ResFin_Back | ResFin_Front;
|
||||
param ResFin_NForm =
|
||||
ResFin_NCase ParamX_Number ResFin_Case | ResFin_NComit | ResFin_NInstruct |
|
||||
ResFin_NPossNom ParamX_Number | ResFin_NPossGen ParamX_Number |
|
||||
ResFin_NPossTransl ParamX_Number | ResFin_NPossIllat ParamX_Number |
|
||||
ResFin_NCompound;
|
||||
param ResFin_Case =
|
||||
ResFin_Nom | ResFin_Gen | ResFin_Part | ResFin_Transl | ResFin_Ess |
|
||||
ResFin_Iness | ResFin_Elat | ResFin_Illat | ResFin_Adess | ResFin_Ablat |
|
||||
ResFin_Allat | ResFin_Abess;
|
||||
param ResFin_NPForm = ResFin_NPCase ResFin_Case | ResFin_NPAcc | ResFin_NPSep;
|
||||
lincat Comment = {s : Str};
|
||||
Item =
|
||||
{s : ResFin_NPForm => Str; a : ResFin_Agr; isNeg : Prelude_Bool;
|
||||
isPron : Prelude_Bool};
|
||||
Kind =
|
||||
{s : ResFin_NForm => Str; h : ResFin_Harmony;
|
||||
postmod : ParamX_Number => Str};
|
||||
Quality =
|
||||
{s : Prelude_Bool => ResFin_NForm => Str; hasPrefix : Prelude_Bool;
|
||||
p : Str};
|
||||
lin Expensive =
|
||||
{s =
|
||||
table {Prelude_False =>
|
||||
table {ResFin_NCase ParamX_Sg ResFin_Nom => "kallis";
|
||||
ResFin_NCase ParamX_Sg ResFin_Gen => "kalliin";
|
||||
ResFin_NCase ParamX_Sg ResFin_Part => "kallista";
|
||||
ResFin_NCase ParamX_Sg ResFin_Transl => "kalliiksi";
|
||||
ResFin_NCase ParamX_Sg ResFin_Ess => "kalliina";
|
||||
ResFin_NCase ParamX_Sg ResFin_Iness => "kalliissa";
|
||||
ResFin_NCase ParamX_Sg ResFin_Elat => "kalliista";
|
||||
ResFin_NCase ParamX_Sg ResFin_Illat => "kalliiseen";
|
||||
ResFin_NCase ParamX_Sg ResFin_Adess => "kalliilla";
|
||||
ResFin_NCase ParamX_Sg ResFin_Ablat => "kalliilta";
|
||||
ResFin_NCase ParamX_Sg ResFin_Allat => "kalliille";
|
||||
ResFin_NCase ParamX_Sg ResFin_Abess => "kalliitta";
|
||||
ResFin_NCase ParamX_Pl ResFin_Nom => "kalliit";
|
||||
ResFin_NCase ParamX_Pl ResFin_Gen => "kalliiden";
|
||||
ResFin_NCase ParamX_Pl ResFin_Part => "kalliita";
|
||||
ResFin_NCase ParamX_Pl ResFin_Transl => "kalliiksi";
|
||||
ResFin_NCase ParamX_Pl ResFin_Ess => "kalliina";
|
||||
ResFin_NCase ParamX_Pl ResFin_Iness => "kalliissa";
|
||||
ResFin_NCase ParamX_Pl ResFin_Elat => "kalliista";
|
||||
ResFin_NCase ParamX_Pl ResFin_Illat => "kalliisiin";
|
||||
ResFin_NCase ParamX_Pl ResFin_Adess => "kalliilla";
|
||||
ResFin_NCase ParamX_Pl ResFin_Ablat => "kalliilta";
|
||||
ResFin_NCase ParamX_Pl ResFin_Allat => "kalliille";
|
||||
ResFin_NCase ParamX_Pl ResFin_Abess => "kalliitta";
|
||||
ResFin_NComit => "kalliine";
|
||||
ResFin_NInstruct => "kalliin";
|
||||
ResFin_NPossNom ParamX_Sg => "kallii";
|
||||
ResFin_NPossNom ParamX_Pl => "kallii";
|
||||
ResFin_NPossGen ParamX_Sg => "kallii";
|
||||
ResFin_NPossGen ParamX_Pl => "kalliide";
|
||||
ResFin_NPossTransl ParamX_Sg => "kalliikse";
|
||||
ResFin_NPossTransl ParamX_Pl => "kalliikse";
|
||||
ResFin_NPossIllat ParamX_Sg => "kalliisee";
|
||||
ResFin_NPossIllat ParamX_Pl => "kalliisii";
|
||||
ResFin_NCompound => "kallis"};
|
||||
Prelude_True =>
|
||||
table {ResFin_NCase ParamX_Sg ResFin_Nom => "kallis";
|
||||
ResFin_NCase ParamX_Sg ResFin_Gen => "kalliin";
|
||||
ResFin_NCase ParamX_Sg ResFin_Part => "kallista";
|
||||
ResFin_NCase ParamX_Sg ResFin_Transl => "kalliiksi";
|
||||
ResFin_NCase ParamX_Sg ResFin_Ess => "kalliina";
|
||||
ResFin_NCase ParamX_Sg ResFin_Iness => "kalliissa";
|
||||
ResFin_NCase ParamX_Sg ResFin_Elat => "kalliista";
|
||||
ResFin_NCase ParamX_Sg ResFin_Illat => "kalliiseen";
|
||||
ResFin_NCase ParamX_Sg ResFin_Adess => "kalliilla";
|
||||
ResFin_NCase ParamX_Sg ResFin_Ablat => "kalliilta";
|
||||
ResFin_NCase ParamX_Sg ResFin_Allat => "kalliille";
|
||||
ResFin_NCase ParamX_Sg ResFin_Abess => "kalliitta";
|
||||
ResFin_NCase ParamX_Pl ResFin_Nom => "kalliit";
|
||||
ResFin_NCase ParamX_Pl ResFin_Gen => "kalliiden";
|
||||
ResFin_NCase ParamX_Pl ResFin_Part => "kalliita";
|
||||
ResFin_NCase ParamX_Pl ResFin_Transl => "kalliiksi";
|
||||
ResFin_NCase ParamX_Pl ResFin_Ess => "kalliina";
|
||||
ResFin_NCase ParamX_Pl ResFin_Iness => "kalliissa";
|
||||
ResFin_NCase ParamX_Pl ResFin_Elat => "kalliista";
|
||||
ResFin_NCase ParamX_Pl ResFin_Illat => "kalliisiin";
|
||||
ResFin_NCase ParamX_Pl ResFin_Adess => "kalliilla";
|
||||
ResFin_NCase ParamX_Pl ResFin_Ablat => "kalliilta";
|
||||
ResFin_NCase ParamX_Pl ResFin_Allat => "kalliille";
|
||||
ResFin_NCase ParamX_Pl ResFin_Abess => "kalliitta";
|
||||
ResFin_NComit => "kalliine";
|
||||
ResFin_NInstruct => "kalliin";
|
||||
ResFin_NPossNom ParamX_Sg => "kallii";
|
||||
ResFin_NPossNom ParamX_Pl => "kallii";
|
||||
ResFin_NPossGen ParamX_Sg => "kallii";
|
||||
ResFin_NPossGen ParamX_Pl => "kalliide";
|
||||
ResFin_NPossTransl ParamX_Sg => "kalliikse";
|
||||
ResFin_NPossTransl ParamX_Pl => "kalliikse";
|
||||
ResFin_NPossIllat ParamX_Sg => "kalliisee";
|
||||
ResFin_NPossIllat ParamX_Pl => "kalliisii";
|
||||
ResFin_NCompound => "kallis"}};
|
||||
hasPrefix = Prelude_False; p = ""};
|
||||
}
|
||||
29
testsuite/canonical/gold/PhrasebookBul.gf
Normal file
29
testsuite/canonical/gold/PhrasebookBul.gf
Normal file
@@ -0,0 +1,29 @@
|
||||
concrete PhrasebookBul of Phrasebook = {
|
||||
param Prelude_Bool = Prelude_False | Prelude_True;
|
||||
param ResBul_AGender = ResBul_AMasc ResBul_Animacy | ResBul_AFem | ResBul_ANeut;
|
||||
param ResBul_Animacy = ResBul_Human | ResBul_NonHuman;
|
||||
param ResBul_Case = ResBul_Acc | ResBul_Dat | ResBul_WithPrep | ResBul_CPrep;
|
||||
param ResBul_NForm =
|
||||
ResBul_NF ParamX_Number ResBul_Species | ResBul_NFSgDefNom |
|
||||
ResBul_NFPlCount | ResBul_NFVocative;
|
||||
param ParamX_Number = ParamX_Sg | ParamX_Pl;
|
||||
param ResBul_Species = ResBul_Indef | ResBul_Def;
|
||||
lincat PlaceKind =
|
||||
{at : {s : Str; c : ResBul_Case}; isPl : Prelude_Bool;
|
||||
name : {s : ResBul_NForm => Str; g : ResBul_AGender};
|
||||
to : {s : Str; c : ResBul_Case}};
|
||||
VerbPhrase = {s : Str};
|
||||
lin Airport =
|
||||
{at = {s = "на"; c = ResBul_Acc}; isPl = Prelude_False;
|
||||
name =
|
||||
{s =
|
||||
table {ResBul_NF ParamX_Sg ResBul_Indef => "летище";
|
||||
ResBul_NF ParamX_Sg ResBul_Def => "летището";
|
||||
ResBul_NF ParamX_Pl ResBul_Indef => "летища";
|
||||
ResBul_NF ParamX_Pl ResBul_Def => "летищата";
|
||||
ResBul_NFSgDefNom => "летището";
|
||||
ResBul_NFPlCount => "летища";
|
||||
ResBul_NFVocative => "летище"};
|
||||
g = ResBul_ANeut};
|
||||
to = {s = "до"; c = ResBul_CPrep}};
|
||||
}
|
||||
251
testsuite/canonical/gold/PhrasebookGer.gf
Normal file
251
testsuite/canonical/gold/PhrasebookGer.gf
Normal file
@@ -0,0 +1,251 @@
|
||||
concrete PhrasebookGer of Phrasebook = {
|
||||
param Prelude_Bool = Prelude_False | Prelude_True;
|
||||
param ResGer_Agr = ResGer_Ag ResGer_Gender ParamX_Number ParamX_Person;
|
||||
param ParamX_Number = ParamX_Sg | ParamX_Pl;
|
||||
param ParamX_Person = ParamX_P1 | ParamX_P2 | ParamX_P3;
|
||||
param ResGer_Gender = ResGer_Masc | ResGer_Fem | ResGer_Neutr;
|
||||
param ResGer_Control = ResGer_SubjC | ResGer_ObjC | ResGer_NoC;
|
||||
param ResGer_PCase = ResGer_NPC ResGer_Case | ResGer_NPP ResGer_CPrep;
|
||||
param ResGer_CPrep =
|
||||
ResGer_CAnDat | ResGer_CInAcc | ResGer_CInDat | ResGer_CZuDat |
|
||||
ResGer_CVonDat;
|
||||
param ResGer_Case = ResGer_Nom | ResGer_Acc | ResGer_Dat | ResGer_Gen;
|
||||
param ResGer_VAux = ResGer_VHaben | ResGer_VSein;
|
||||
param ResGer_VForm =
|
||||
ResGer_VInf Prelude_Bool | ResGer_VFin Prelude_Bool ResGer_VFormFin |
|
||||
ResGer_VImper ParamX_Number | ResGer_VPresPart ResGer_AForm |
|
||||
ResGer_VPastPart ResGer_AForm;
|
||||
param ResGer_AForm = ResGer_APred | ResGer_AMod ResGer_GenNum ResGer_Case;
|
||||
param ResGer_GenNum = ResGer_GSg ResGer_Gender | ResGer_GPl;
|
||||
param ResGer_VFormFin =
|
||||
ResGer_VPresInd ParamX_Number ParamX_Person |
|
||||
ResGer_VPresSubj ParamX_Number ParamX_Person;
|
||||
param ResGer_VType = ResGer_VAct | ResGer_VRefl ResGer_Case;
|
||||
lincat PlaceKind = {s : Str};
|
||||
VerbPhrase =
|
||||
{s :
|
||||
{s : ResGer_VForm => Str; aux : ResGer_VAux; particle : Str;
|
||||
prefix : Str; vtype : ResGer_VType};
|
||||
a1 : Str; a2 : Str; adj : Str; ext : Str;
|
||||
inf : {s : Str; ctrl : ResGer_Control; isAux : Prelude_Bool};
|
||||
infExt : Str; isAux : Prelude_Bool;
|
||||
nn :
|
||||
ResGer_Agr =>
|
||||
{p1 : Str; p2 : Str; p3 : Str; p4 : Str; p5 : Str; p6 : Str};
|
||||
subjc :
|
||||
{s : Str; c : ResGer_PCase; isPrep : Prelude_Bool; s2 : Str}};
|
||||
lin VRead =
|
||||
{s =
|
||||
{s =
|
||||
table {ResGer_VInf Prelude_False => "lesen";
|
||||
ResGer_VInf Prelude_True => "zu" ++ "lesen";
|
||||
ResGer_VFin Prelude_False
|
||||
(ResGer_VPresInd ParamX_Sg ParamX_P1) =>
|
||||
"lese";
|
||||
ResGer_VFin Prelude_False
|
||||
(ResGer_VPresInd ParamX_Sg ParamX_P2) =>
|
||||
"liest";
|
||||
ResGer_VFin Prelude_False
|
||||
(ResGer_VPresInd ParamX_Sg ParamX_P3) =>
|
||||
"liest";
|
||||
ResGer_VFin Prelude_False
|
||||
(ResGer_VPresInd ParamX_Pl ParamX_P1) =>
|
||||
"lesen";
|
||||
ResGer_VFin Prelude_False
|
||||
(ResGer_VPresInd ParamX_Pl ParamX_P2) =>
|
||||
"lest";
|
||||
ResGer_VFin Prelude_False
|
||||
(ResGer_VPresInd ParamX_Pl ParamX_P3) =>
|
||||
"lesen";
|
||||
ResGer_VFin Prelude_False
|
||||
(ResGer_VPresSubj ParamX_Sg ParamX_P1) =>
|
||||
"lese";
|
||||
ResGer_VFin Prelude_False
|
||||
(ResGer_VPresSubj ParamX_Sg ParamX_P2) =>
|
||||
"lesest";
|
||||
ResGer_VFin Prelude_False
|
||||
(ResGer_VPresSubj ParamX_Sg ParamX_P3) =>
|
||||
"lese";
|
||||
ResGer_VFin Prelude_False
|
||||
(ResGer_VPresSubj ParamX_Pl ParamX_P1) =>
|
||||
"lesen";
|
||||
ResGer_VFin Prelude_False
|
||||
(ResGer_VPresSubj ParamX_Pl ParamX_P2) =>
|
||||
"leset";
|
||||
ResGer_VFin Prelude_False
|
||||
(ResGer_VPresSubj ParamX_Pl ParamX_P3) =>
|
||||
"lesen";
|
||||
ResGer_VFin Prelude_True
|
||||
(ResGer_VPresInd ParamX_Sg ParamX_P1) =>
|
||||
"lese";
|
||||
ResGer_VFin Prelude_True
|
||||
(ResGer_VPresInd ParamX_Sg ParamX_P2) =>
|
||||
"liest";
|
||||
ResGer_VFin Prelude_True
|
||||
(ResGer_VPresInd ParamX_Sg ParamX_P3) =>
|
||||
"liest";
|
||||
ResGer_VFin Prelude_True
|
||||
(ResGer_VPresInd ParamX_Pl ParamX_P1) =>
|
||||
"lesen";
|
||||
ResGer_VFin Prelude_True
|
||||
(ResGer_VPresInd ParamX_Pl ParamX_P2) =>
|
||||
"lest";
|
||||
ResGer_VFin Prelude_True
|
||||
(ResGer_VPresInd ParamX_Pl ParamX_P3) =>
|
||||
"lesen";
|
||||
ResGer_VFin Prelude_True
|
||||
(ResGer_VPresSubj ParamX_Sg ParamX_P1) =>
|
||||
"lese";
|
||||
ResGer_VFin Prelude_True
|
||||
(ResGer_VPresSubj ParamX_Sg ParamX_P2) =>
|
||||
"lesest";
|
||||
ResGer_VFin Prelude_True
|
||||
(ResGer_VPresSubj ParamX_Sg ParamX_P3) =>
|
||||
"lese";
|
||||
ResGer_VFin Prelude_True
|
||||
(ResGer_VPresSubj ParamX_Pl ParamX_P1) =>
|
||||
"lesen";
|
||||
ResGer_VFin Prelude_True
|
||||
(ResGer_VPresSubj ParamX_Pl ParamX_P2) =>
|
||||
"leset";
|
||||
ResGer_VFin Prelude_True
|
||||
(ResGer_VPresSubj ParamX_Pl ParamX_P3) =>
|
||||
"lesen";
|
||||
ResGer_VImper ParamX_Sg => "les";
|
||||
ResGer_VImper ParamX_Pl => "lest";
|
||||
ResGer_VPresPart ResGer_APred => "lesend";
|
||||
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
|
||||
ResGer_Nom) =>
|
||||
"lesender";
|
||||
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
|
||||
ResGer_Acc) =>
|
||||
"lesenden";
|
||||
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
|
||||
ResGer_Dat) =>
|
||||
"lesendem";
|
||||
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
|
||||
ResGer_Gen) =>
|
||||
"lesenden";
|
||||
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
|
||||
ResGer_Nom) =>
|
||||
"lesende";
|
||||
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
|
||||
ResGer_Acc) =>
|
||||
"lesende";
|
||||
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
|
||||
ResGer_Dat) =>
|
||||
"lesender";
|
||||
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
|
||||
ResGer_Gen) =>
|
||||
"lesender";
|
||||
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
|
||||
ResGer_Nom) =>
|
||||
"lesendes";
|
||||
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
|
||||
ResGer_Acc) =>
|
||||
"lesendes";
|
||||
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
|
||||
ResGer_Dat) =>
|
||||
"lesendem";
|
||||
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
|
||||
ResGer_Gen) =>
|
||||
"lesenden";
|
||||
ResGer_VPresPart (ResGer_AMod ResGer_GPl ResGer_Nom) =>
|
||||
"lesende";
|
||||
ResGer_VPresPart (ResGer_AMod ResGer_GPl ResGer_Acc) =>
|
||||
"lesende";
|
||||
ResGer_VPresPart (ResGer_AMod ResGer_GPl ResGer_Dat) =>
|
||||
"lesenden";
|
||||
ResGer_VPresPart (ResGer_AMod ResGer_GPl ResGer_Gen) =>
|
||||
"lesender";
|
||||
ResGer_VPastPart ResGer_APred => "gelesen";
|
||||
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
|
||||
ResGer_Nom) =>
|
||||
"gelesener";
|
||||
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
|
||||
ResGer_Acc) =>
|
||||
"gelesenen";
|
||||
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
|
||||
ResGer_Dat) =>
|
||||
"gelesenem";
|
||||
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
|
||||
ResGer_Gen) =>
|
||||
"gelesenen";
|
||||
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
|
||||
ResGer_Nom) =>
|
||||
"gelesene";
|
||||
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
|
||||
ResGer_Acc) =>
|
||||
"gelesene";
|
||||
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
|
||||
ResGer_Dat) =>
|
||||
"gelesener";
|
||||
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
|
||||
ResGer_Gen) =>
|
||||
"gelesener";
|
||||
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
|
||||
ResGer_Nom) =>
|
||||
"gelesenes";
|
||||
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
|
||||
ResGer_Acc) =>
|
||||
"gelesenes";
|
||||
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
|
||||
ResGer_Dat) =>
|
||||
"gelesenem";
|
||||
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
|
||||
ResGer_Gen) =>
|
||||
"gelesenen";
|
||||
ResGer_VPastPart (ResGer_AMod ResGer_GPl ResGer_Nom) =>
|
||||
"gelesene";
|
||||
ResGer_VPastPart (ResGer_AMod ResGer_GPl ResGer_Acc) =>
|
||||
"gelesene";
|
||||
ResGer_VPastPart (ResGer_AMod ResGer_GPl ResGer_Dat) =>
|
||||
"gelesenen";
|
||||
ResGer_VPastPart (ResGer_AMod ResGer_GPl ResGer_Gen) =>
|
||||
"gelesener"};
|
||||
aux = ResGer_VHaben; particle = ""; prefix = "";
|
||||
vtype = ResGer_VAct};
|
||||
a1 = ""; a2 = ""; adj = ""; ext = "";
|
||||
inf = {s = ""; ctrl = ResGer_NoC; isAux = Prelude_True}; infExt = "";
|
||||
isAux = Prelude_False;
|
||||
nn =
|
||||
table {ResGer_Ag ResGer_Masc ParamX_Sg ParamX_P1 =>
|
||||
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
|
||||
ResGer_Ag ResGer_Masc ParamX_Sg ParamX_P2 =>
|
||||
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
|
||||
ResGer_Ag ResGer_Masc ParamX_Sg ParamX_P3 =>
|
||||
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
|
||||
ResGer_Ag ResGer_Masc ParamX_Pl ParamX_P1 =>
|
||||
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
|
||||
ResGer_Ag ResGer_Masc ParamX_Pl ParamX_P2 =>
|
||||
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
|
||||
ResGer_Ag ResGer_Masc ParamX_Pl ParamX_P3 =>
|
||||
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
|
||||
ResGer_Ag ResGer_Fem ParamX_Sg ParamX_P1 =>
|
||||
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
|
||||
ResGer_Ag ResGer_Fem ParamX_Sg ParamX_P2 =>
|
||||
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
|
||||
ResGer_Ag ResGer_Fem ParamX_Sg ParamX_P3 =>
|
||||
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
|
||||
ResGer_Ag ResGer_Fem ParamX_Pl ParamX_P1 =>
|
||||
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
|
||||
ResGer_Ag ResGer_Fem ParamX_Pl ParamX_P2 =>
|
||||
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
|
||||
ResGer_Ag ResGer_Fem ParamX_Pl ParamX_P3 =>
|
||||
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
|
||||
ResGer_Ag ResGer_Neutr ParamX_Sg ParamX_P1 =>
|
||||
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
|
||||
ResGer_Ag ResGer_Neutr ParamX_Sg ParamX_P2 =>
|
||||
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
|
||||
ResGer_Ag ResGer_Neutr ParamX_Sg ParamX_P3 =>
|
||||
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
|
||||
ResGer_Ag ResGer_Neutr ParamX_Pl ParamX_P1 =>
|
||||
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
|
||||
ResGer_Ag ResGer_Neutr ParamX_Pl ParamX_P2 =>
|
||||
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
|
||||
ResGer_Ag ResGer_Neutr ParamX_Pl ParamX_P3 =>
|
||||
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""}};
|
||||
subjc =
|
||||
{s = ""; c = ResGer_NPC ResGer_Nom; isPrep = Prelude_False;
|
||||
s2 = ""}};
|
||||
}
|
||||
16
testsuite/canonical/grammars/Foods.gf
Normal file
16
testsuite/canonical/grammars/Foods.gf
Normal file
@@ -0,0 +1,16 @@
|
||||
-- (c) 2009 Aarne Ranta under LGPL
|
||||
|
||||
abstract Foods = {
|
||||
flags startcat = Comment ;
|
||||
cat
|
||||
Comment ; Item ; Kind ; Quality ;
|
||||
fun
|
||||
-- Pred : Item -> Quality -> Comment ;
|
||||
-- This, That, These, Those : Kind -> Item ;
|
||||
-- Mod : Quality -> Kind -> Kind ;
|
||||
-- Wine, Cheese, Fish, Pizza : Kind ;
|
||||
-- Very : Quality -> Quality ;
|
||||
-- Fresh, Warm, Italian,
|
||||
-- Expensive, Delicious, Boring : Quality ;
|
||||
Expensive: Quality;
|
||||
}
|
||||
6
testsuite/canonical/grammars/FoodsFin.gf
Normal file
6
testsuite/canonical/grammars/FoodsFin.gf
Normal file
@@ -0,0 +1,6 @@
|
||||
|
||||
-- (c) 2009 Aarne Ranta under LGPL
|
||||
|
||||
concrete FoodsFin of Foods = FoodsI with
|
||||
(Syntax = SyntaxFin),
|
||||
(LexFoods = LexFoodsFin) ;
|
||||
29
testsuite/canonical/grammars/FoodsI.gf
Normal file
29
testsuite/canonical/grammars/FoodsI.gf
Normal file
@@ -0,0 +1,29 @@
|
||||
-- (c) 2009 Aarne Ranta under LGPL
|
||||
|
||||
incomplete concrete FoodsI of Foods =
|
||||
open Syntax, LexFoods in {
|
||||
lincat
|
||||
Comment = Utt ;
|
||||
Item = NP ;
|
||||
Kind = CN ;
|
||||
Quality = AP ;
|
||||
lin
|
||||
Pred item quality = mkUtt (mkCl item quality) ;
|
||||
This kind = mkNP this_Det kind ;
|
||||
That kind = mkNP that_Det kind ;
|
||||
These kind = mkNP these_Det kind ;
|
||||
Those kind = mkNP those_Det kind ;
|
||||
Mod quality kind = mkCN quality kind ;
|
||||
Very quality = mkAP very_AdA quality ;
|
||||
|
||||
Wine = mkCN wine_N ;
|
||||
Pizza = mkCN pizza_N ;
|
||||
Cheese = mkCN cheese_N ;
|
||||
Fish = mkCN fish_N ;
|
||||
Fresh = mkAP fresh_A ;
|
||||
Warm = mkAP warm_A ;
|
||||
Italian = mkAP italian_A ;
|
||||
Expensive = mkAP expensive_A ;
|
||||
Delicious = mkAP delicious_A ;
|
||||
Boring = mkAP boring_A ;
|
||||
}
|
||||
15
testsuite/canonical/grammars/LexFoods.gf
Normal file
15
testsuite/canonical/grammars/LexFoods.gf
Normal file
@@ -0,0 +1,15 @@
|
||||
-- (c) 2009 Aarne Ranta under LGPL
|
||||
|
||||
interface LexFoods = open Syntax in {
|
||||
oper
|
||||
wine_N : N ;
|
||||
pizza_N : N ;
|
||||
cheese_N : N ;
|
||||
fish_N : N ;
|
||||
fresh_A : A ;
|
||||
warm_A : A ;
|
||||
italian_A : A ;
|
||||
expensive_A : A ;
|
||||
delicious_A : A ;
|
||||
boring_A : A ;
|
||||
}
|
||||
21
testsuite/canonical/grammars/LexFoodsFin.gf
Normal file
21
testsuite/canonical/grammars/LexFoodsFin.gf
Normal file
@@ -0,0 +1,21 @@
|
||||
-- (c) 2009 Aarne Ranta under LGPL
|
||||
--# -coding=latin1
|
||||
|
||||
instance LexFoodsFin of LexFoods =
|
||||
open SyntaxFin, ParadigmsFin in {
|
||||
oper
|
||||
wine_N = mkN "viini" ;
|
||||
pizza_N = mkN "pizza" ;
|
||||
cheese_N = mkN "juusto" ;
|
||||
fish_N = mkN "kala" ;
|
||||
fresh_A = mkA "tuore" ;
|
||||
warm_A = mkA
|
||||
(mkN "l<>mmin" "l<>mpim<69>n" "l<>mmint<6E>" "l<>mpim<69>n<EFBFBD>" "l<>mpim<69><6D>n"
|
||||
"l<>mpimin<69>" "l<>mpimi<6D>" "l<>mpimien" "l<>mpimiss<73>" "l<>mpimiin"
|
||||
)
|
||||
"l<>mpim<69>mpi" "l<>mpimin" ;
|
||||
italian_A = mkA "italialainen" ;
|
||||
expensive_A = mkA "kallis" ;
|
||||
delicious_A = mkA "herkullinen" ;
|
||||
boring_A = mkA "tyls<6C>" ;
|
||||
}
|
||||
9
testsuite/canonical/grammars/Phrasebook.gf
Normal file
9
testsuite/canonical/grammars/Phrasebook.gf
Normal file
@@ -0,0 +1,9 @@
|
||||
abstract Phrasebook = {
|
||||
|
||||
cat PlaceKind ;
|
||||
fun Airport : PlaceKind ;
|
||||
|
||||
cat VerbPhrase ;
|
||||
fun VRead : VerbPhrase ;
|
||||
|
||||
}
|
||||
31
testsuite/canonical/grammars/PhrasebookBul.gf
Normal file
31
testsuite/canonical/grammars/PhrasebookBul.gf
Normal file
@@ -0,0 +1,31 @@
|
||||
--# -path=.:present
|
||||
|
||||
concrete PhrasebookBul of Phrasebook =
|
||||
open
|
||||
SyntaxBul,
|
||||
(R = ResBul),
|
||||
ParadigmsBul,
|
||||
Prelude in {
|
||||
|
||||
lincat
|
||||
PlaceKind = CNPlace ;
|
||||
|
||||
oper
|
||||
CNPlace : Type = {name : CN ; at : Prep ; to : Prep; isPl : Bool} ;
|
||||
|
||||
mkPlace : N -> Prep -> {name : CN ; at : Prep ; to : Prep; isPl : Bool} = \n,p ->
|
||||
mkCNPlace (mkCN n) p to_Prep ;
|
||||
|
||||
mkCNPlace : CN -> Prep -> Prep -> CNPlace = \p,i,t -> {
|
||||
name = p ;
|
||||
at = i ;
|
||||
to = t ;
|
||||
isPl = False
|
||||
} ;
|
||||
|
||||
na_Prep = mkPrep "на" R.Acc ;
|
||||
|
||||
lin
|
||||
Airport = mkPlace (mkN066 "летище") na_Prep ;
|
||||
|
||||
}
|
||||
14
testsuite/canonical/grammars/PhrasebookGer.gf
Normal file
14
testsuite/canonical/grammars/PhrasebookGer.gf
Normal file
@@ -0,0 +1,14 @@
|
||||
--# -path=.:present
|
||||
|
||||
concrete PhrasebookGer of Phrasebook =
|
||||
open
|
||||
SyntaxGer,
|
||||
LexiconGer in {
|
||||
|
||||
lincat
|
||||
VerbPhrase = VP ;
|
||||
|
||||
lin
|
||||
VRead = mkVP <lin V read_V2 : V> ;
|
||||
|
||||
}
|
||||
36
testsuite/canonical/run-on-grammar.sh
Executable file
36
testsuite/canonical/run-on-grammar.sh
Executable file
@@ -0,0 +1,36 @@
|
||||
#!/usr/bin/env sh
|
||||
|
||||
# For a given grammar, compile into canonical format,
|
||||
# then ensure that the canonical format itself is compilable.
|
||||
|
||||
if [ $# -lt 1 ]; then
|
||||
echo "Please specify concrete modules to test with, e.g.:"
|
||||
echo "./run-on-grammar.sh ../../../gf-contrib/foods/FoodsEng.gf ../../../gf-contrib/foods/FoodsFin.gf"
|
||||
exit 2
|
||||
fi
|
||||
|
||||
FAILURES=0
|
||||
|
||||
for CNC_PATH in "$@"; do
|
||||
CNC_FILE=$(basename "$CNC_PATH")
|
||||
stack run -- --batch --output-format=canonical_gf "$CNC_PATH"
|
||||
if [ $? -ne 0 ]; then
|
||||
echo "Failed to compile into canonical"
|
||||
FAILURES=$((FAILURES+1))
|
||||
continue
|
||||
fi
|
||||
|
||||
stack run -- --batch "canonical/$CNC_FILE"
|
||||
if [ $? -ne 0 ]; then
|
||||
echo "Failed to compile canonical"
|
||||
FAILURES=$((FAILURES+1))
|
||||
fi
|
||||
done
|
||||
|
||||
# Summary
|
||||
if [ $FAILURES -ne 0 ]; then
|
||||
echo "Failures: $FAILURES"
|
||||
exit 1
|
||||
else
|
||||
echo "All tests passed"
|
||||
fi
|
||||
54
testsuite/canonical/run.sh
Executable file
54
testsuite/canonical/run.sh
Executable file
@@ -0,0 +1,54 @@
|
||||
#!/usr/bin/env sh
|
||||
|
||||
FAILURES=0
|
||||
|
||||
# https://github.com/GrammaticalFramework/gf-core/issues/100
|
||||
stack run -- --batch --output-format=canonical_gf grammars/PhrasebookBul.gf
|
||||
stack run -- --batch canonical/PhrasebookBul.gf
|
||||
if [ $? -ne 0 ]; then
|
||||
echo "Canonical grammar doesn't compile: FAIL"
|
||||
FAILURES=$((FAILURES+1))
|
||||
else
|
||||
# echo "Canonical grammar compiles: OK"
|
||||
diff canonical/PhrasebookBul.gf gold/PhrasebookBul.gf
|
||||
if [ $? -ne 0 ]; then
|
||||
echo "Canonical grammar doesn't match gold version: FAIL"
|
||||
FAILURES=$((FAILURES+1))
|
||||
else
|
||||
echo "Canonical grammar matches gold version: OK"
|
||||
fi
|
||||
fi
|
||||
|
||||
echo ""
|
||||
|
||||
# https://github.com/GrammaticalFramework/gf-core/issues/101
|
||||
stack run -- --batch --output-format=canonical_gf grammars/PhrasebookGer.gf
|
||||
diff canonical/PhrasebookGer.gf gold/PhrasebookGer.gf
|
||||
if [ $? -ne 0 ]; then
|
||||
echo "Canonical grammar doesn't match gold version: FAIL"
|
||||
FAILURES=$((FAILURES+1))
|
||||
else
|
||||
echo "Canonical grammar matches gold version: OK"
|
||||
fi
|
||||
|
||||
echo ""
|
||||
|
||||
# https://github.com/GrammaticalFramework/gf-core/issues/102
|
||||
stack run -- --batch --output-format=canonical_gf grammars/FoodsFin.gf
|
||||
diff canonical/FoodsFin.gf gold/FoodsFin.gf
|
||||
if [ $? -ne 0 ]; then
|
||||
echo "Canonical grammar doesn't match gold version: FAIL"
|
||||
FAILURES=$((FAILURES+1))
|
||||
else
|
||||
echo "Canonical grammar matches gold version: OK"
|
||||
fi
|
||||
|
||||
echo ""
|
||||
|
||||
# Summary
|
||||
if [ $FAILURES -ne 0 ]; then
|
||||
echo "Failures: $FAILURES"
|
||||
exit 1
|
||||
else
|
||||
echo "All tests passed"
|
||||
fi
|
||||
Reference in New Issue
Block a user