GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 11:42:49 -06:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'master' into concrete-new

Browse Source
This commit is contained in:
Inari Listenmaa
2021-07-06 09:37:22 +02:00
committed by GitHub
parent 5d7c687cb7 1b66bf2773
commit d2fb755fab
24 changed files with 937 additions and 229 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
src/compiler/GF/Command/CommonCommands.hs
View File

@@ -15,6 +15,7 @@ import GF.Command.Abstract --(isOpt,valStrOpts,prOpt)
import GF.Text.Pretty import GF.Text.Pretty
import GF.Text.Transliterations import GF.Text.Transliterations
import GF.Text.Lexing(stringOp,opInEnv) import GF.Text.Lexing(stringOp,opInEnv)
import Data.Char (isSpace)
import qualified PGF as H(showCId,showExpr,toATree,toTrie,Trie(..)) import qualified PGF as H(showCId,showExpr,toATree,toTrie,Trie(..))
@@ -170,7 +171,8 @@ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [
restrictedSystem $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo restrictedSystem $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo
fmap fromString $ restricted $ readFile 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 = [ flags = [
("command","the system command applied to the argument") ("command","the system command applied to the argument")
], ],

47
src/compiler/GF/Compile/ConcreteToHaskell.hs
View File

@@ -7,7 +7,7 @@ import GF.Text.Pretty
--import GF.Grammar.Predef(cPredef,cInts) --import GF.Grammar.Predef(cPredef,cInts)
--import GF.Compile.Compute.Predef(predef) --import GF.Compile.Compute.Predef(predef)
--import GF.Compile.Compute.Value(Predefined(..)) --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.Infra.Option
import GF.Haskell as H import GF.Haskell as H
import GF.Grammar.Canonical as C import GF.Grammar.Canonical as C
@@ -21,7 +21,7 @@ concretes2haskell opts absname gr =
| let Grammar abstr cncs = grammar2canonical opts absname gr, | let Grammar abstr cncs = grammar2canonical opts absname gr,
cncmod<-cncs, cncmod<-cncs,
let ModId name = concName cncmod let ModId name = concName cncmod
filename = name ++ ".hs" :: FilePath filename = showRawIdent name ++ ".hs" :: FilePath
] ]
-- | Generate Haskell code for the given concrete module. -- | 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 labels = S.difference (S.unions (map S.fromList recs)) common_labels
common_records = S.fromList [[label_s]] common_records = S.fromList [[label_s]]
common_labels = 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)) signature (CatDef c _) = TypeSig lf (Fun abs (pure lin))
where where
@@ -69,7 +69,7 @@ concrete2haskell opts
where where
--funcats = S.fromList [c | FunDef f (C.Type _ (TypeApp c _))<-funs] --funcats = S.fromList [c | FunDef f (C.Type _ (TypeApp c _))<-funs]
allcats = S.fromList [c | CatDef c _<-cats] allcats = S.fromList [c | CatDef c _<-cats]
gId :: ToIdent i => i -> Ident gId :: ToIdent i => i -> Ident
gId = (if haskellOption opts HaskellNoPrefix then id else prefixIdent "G") gId = (if haskellOption opts HaskellNoPrefix then id else prefixIdent "G")
. toIdent . toIdent
@@ -116,7 +116,7 @@ concrete2haskell opts
where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-rs] where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-rs]
StrType -> tcon0 (identS "Str") StrType -> tcon0 (identS "Str")
TableType pt lt -> Fun (ppT pt) (ppT lt) TableType pt lt -> Fun (ppT pt) (ppT lt)
-- TupleType lts -> -- TupleType lts ->
lincatDef (LincatDef c t) = tsyn0 (lincatName c) (convLinType t) lincatDef (LincatDef c t) = tsyn0 (lincatName c) (convLinType t)
@@ -126,7 +126,7 @@ concrete2haskell opts
linDefs = map eqn . sortOn fst . map linDef linDefs = map eqn . sortOn fst . map linDef
where eqn (cat,(f,(ps,rhs))) = (cat,Eqn (f,ps) rhs) 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))) (cat,(linfunName cat,(lhs,rhs)))
where where
lhs = [ConP (aId f) (map VarP abs_args)] lhs = [ConP (aId f) (map VarP abs_args)]
@@ -144,7 +144,7 @@ concrete2haskell opts
where where
vs = [(VarValueId (Unqual x),a)|(VarId x,a)<-zip xs args] vs = [(VarValueId (Unqual x),a)|(VarId x,a)<-zip xs args]
env= [(VarValueId (Unqual x),lc)|(VarId x,lc)<-zip xs (map arglincat absctx)] env= [(VarValueId (Unqual x),lc)|(VarId x,lc)<-zip xs (map arglincat absctx)]
letlin a (TypeBinding _ (C.Type _ (TypeApp acat _))) = letlin a (TypeBinding _ (C.Type _ (TypeApp acat _))) =
(a,Ap (Var (linfunName acat)) (Var (abs_arg a))) (a,Ap (Var (linfunName acat)) (Var (abs_arg a)))
@@ -187,7 +187,7 @@ concrete2haskell opts
pId p@(ParamId s) = pId p@(ParamId s) =
if "to_R_" `isPrefixOf` unqual 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 = table cs =
if all (null.patVars) ps if all (null.patVars) ps
then lets ds (LambdaCase [(ppP p,t')|(p,t')<-zip ps ts']) 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 -- | Record subtyping is converted into explicit coercions in Haskell
coerce env ty t = coerce env ty t =
case (ty,t) of case (ty,t) of
(_,VariantValue ts) -> VariantValue (map (coerce env ty) ts) (_,VariantValue ts) -> VariantValue (map (coerce env ty) ts)
(TableType ti tv,TableValue _ cs) -> (TableType ti tv,TableValue _ cs) ->
TableValue ti [TableRow p (coerce env tv t)|TableRow p t<-cs] TableValue ti [TableRow p (coerce env tv t)|TableRow p t<-cs]
(RecordType rt,RecordValue r) -> (RecordType rt,RecordValue r) ->
RecordValue [RecordRow l (coerce env ft f) | 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)-> (RecordType rt,VarValue x)->
case lookup x env of case lookup x env of
Just ty' | ty'/=ty -> -- better to compare to normal form of ty' Just ty' | ty'/=ty -> -- better to compare to normal form of ty'
@@ -334,18 +334,17 @@ coerce env ty t =
_ -> t _ -> t
where where
app f ts = ParamConstant (Param f ts) -- !! a hack 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 = [] patVars p = []
labels r = [l|RecordRow l _<-r] labels r = [l | RecordRow l _ <- r]
proj = Var . identS . proj' proj = Var . identS . proj'
proj' (LabelId l) = "proj_"++l proj' (LabelId l) = "proj_" ++ showRawIdent l
rcon = Var . rcon' rcon = Var . rcon'
rcon' = identS . rcon_name 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 to_rcon' = ("to_"++) . rcon_name
recordType ls = recordType ls =
@@ -400,17 +399,17 @@ linfunName c = prefixIdent "lin" (toIdent c)
class ToIdent i where toIdent :: i -> Ident class ToIdent i where toIdent :: i -> Ident
instance ToIdent ParamId where toIdent (ParamId q) = qIdentS q instance ToIdent ParamId where toIdent (ParamId q) = qIdentC q
instance ToIdent PredefId where toIdent (PredefId s) = identS s instance ToIdent PredefId where toIdent (PredefId s) = identC s
instance ToIdent CatId where toIdent (CatId s) = identS s instance ToIdent CatId where toIdent (CatId s) = identC s
instance ToIdent C.FunId where toIdent (FunId s) = identS s instance ToIdent C.FunId where toIdent (FunId s) = identC s
instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentS q instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentC q
qIdentS = identS . unqual qIdentC = identS . unqual
unqual (Qual (ModId m) n) = m++"_"++n unqual (Qual (ModId m) n) = showRawIdent m++"_"++ showRawIdent n
unqual (Unqual n) = n unqual (Unqual n) = showRawIdent n
instance ToIdent VarId where instance ToIdent VarId where
toIdent Anonymous = identW toIdent Anonymous = identW
toIdent (VarId s) = identS s toIdent (VarId s) = identC s

138
src/compiler/GF/Compile/GrammarToCanonical.hs
View File

@@ -6,30 +6,35 @@ module GF.Compile.GrammarToCanonical(
) where ) where
import Data.List(nub,partition) import Data.List(nub,partition)
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe(fromMaybe)
import qualified Data.Set as S import qualified Data.Set as S
import GF.Data.ErrM import GF.Data.ErrM
import GF.Text.Pretty import GF.Text.Pretty
import GF.Grammar.Grammar import GF.Grammar.Grammar as G
import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues) 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.Lockfield(isLockLabel)
import GF.Grammar.Predef(cPredef,cInts) import GF.Grammar.Predef(cPredef,cInts)
import GF.Compile.Compute.Predef(predef) import GF.Compile.Compute.Predef(predef)
import GF.Compile.Compute.Value(Predefined(..)) import GF.Compile.Compute.Value(Predefined(..))
import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent) import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent)
import GF.Infra.Option(optionsPGF) import GF.Infra.Option(Options,optionsPGF)
import PGF.Internal(Literal(..)) 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 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 -- | Generate Canonical code for the named abstract syntax and all associated
-- concrete syntaxes -- concrete syntaxes
grammar2canonical :: Options -> ModuleName -> G.Grammar -> C.Grammar
grammar2canonical opts absname gr = grammar2canonical opts absname gr =
Grammar (abstract2canonical absname gr) Grammar (abstract2canonical absname gr)
(map snd (concretes2canonical opts absname gr)) (map snd (concretes2canonical opts absname gr))
-- | Generate Canonical code for the named abstract syntax -- | Generate Canonical code for the named abstract syntax
abstract2canonical :: ModuleName -> G.Grammar -> Abstract
abstract2canonical absname gr = abstract2canonical absname gr =
Abstract (modId absname) (convFlags gr absname) cats funs Abstract (modId absname) (convFlags gr absname) cats funs
where where
@@ -44,6 +49,7 @@ abstract2canonical absname gr =
convHypo (bt,name,t) = convHypo (bt,name,t) =
case typeForm t of case typeForm t of
([],(_,cat),[]) -> gId cat -- !! ([],(_,cat),[]) -> gId cat -- !!
tf -> error $ "abstract2canonical convHypo: " ++ show tf
convType t = convType t =
case typeForm t of case typeForm t of
@@ -54,23 +60,24 @@ abstract2canonical absname gr =
convHypo' (bt,name,t) = TypeBinding (gId name) (convType t) convHypo' (bt,name,t) = TypeBinding (gId name) (convType t)
-- | Generate Canonical code for the all concrete syntaxes associated with -- | Generate Canonical code for the all concrete syntaxes associated with
-- the named abstract syntax in given the grammar. -- the named abstract syntax in given the grammar.
concretes2canonical :: Options -> ModuleName -> G.Grammar -> [(FilePath, Concrete)]
concretes2canonical opts absname gr = concretes2canonical opts absname gr =
[(cncname,concrete2canonical gr cenv absname cnc cncmod) [(cncname,concrete2canonical gr cenv absname cnc cncmod)
| let cenv = resourceValues opts gr, | let cenv = resourceValues opts gr,
cnc<-allConcretes gr absname, cnc<-allConcretes gr absname,
let cncname = "canonical/"++render cnc ++ ".gf" :: FilePath let cncname = "canonical" </> render cnc <.> "gf"
Ok cncmod = lookupModule gr cnc Ok cncmod = lookupModule gr cnc
] ]
-- | Generate Canonical GF for the given concrete module. -- | Generate Canonical GF for the given concrete module.
concrete2canonical :: G.Grammar -> GlobalEnv -> ModuleName -> ModuleName -> ModuleInfo -> Concrete
concrete2canonical gr cenv absname cnc modinfo = concrete2canonical gr cenv absname cnc modinfo =
Concrete (modId cnc) (modId absname) (convFlags gr cnc) Concrete (modId cnc) (modId absname) (convFlags gr cnc)
(neededParamTypes S.empty (params defs)) (neededParamTypes S.empty (params defs))
[lincat|(_,Left lincat)<-defs] [lincat | (_,Left lincat) <- defs]
[lin|(_,Right lin)<-defs] [lin | (_,Right lin) <- defs]
where where
defs = concatMap (toCanonical gr absname cenv) . defs = concatMap (toCanonical gr absname cenv) .
M.toList $ M.toList $
@@ -85,6 +92,7 @@ concrete2canonical gr cenv absname cnc modinfo =
else let ((got,need),def) = paramType gr q else let ((got,need),def) = paramType gr q
in def++neededParamTypes (S.union got have) (S.toList need++qs) 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) = toCanonical gr absname cenv (name,jment) =
case jment of case jment of
CncCat (Just (L loc typ)) _ _ pprn _ -> CncCat (Just (L loc typ)) _ _ pprn _ ->
@@ -97,7 +105,8 @@ toCanonical gr absname cenv (name,jment) =
where where
tts = tableTypes gr [e'] tts = tableTypes gr [e']
e' = unAbs (length params) $ e' = cleanupRecordFields lincat $
unAbs (length params) $
nf loc (mkAbs params (mkApp def (map Vr args))) nf loc (mkAbs params (mkApp def (map Vr args)))
params = [(b,x)|(b,x,_)<-ctx] params = [(b,x)|(b,x,_)<-ctx]
args = map snd params args = map snd params
@@ -108,12 +117,12 @@ toCanonical gr absname cenv (name,jment) =
_ -> [] _ -> []
where where
nf loc = normalForm cenv (L loc name) nf loc = normalForm cenv (L loc name)
-- aId n = prefixIdent "A." (gId n)
unAbs 0 t = t unAbs 0 t = t
unAbs n (Abs _ _ t) = unAbs (n-1) t unAbs n (Abs _ _ t) = unAbs (n-1) t
unAbs _ t = t unAbs _ t = t
tableTypes :: G.Grammar -> [Term] -> S.Set QIdent
tableTypes gr ts = S.unions (map tabtys ts) tableTypes gr ts = S.unions (map tabtys ts)
where where
tabtys t = 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)) T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs))
_ -> collectOp tabtys t _ -> collectOp tabtys t
paramTypes :: G.Grammar -> G.Type -> S.Set QIdent
paramTypes gr t = paramTypes gr t =
case t of case t of
RecType fs -> S.unions (map (paramTypes gr.snd) fs) RecType fs -> S.unions (map (paramTypes gr.snd) fs)
@@ -140,11 +150,26 @@ paramTypes gr t =
Ok (_,ResParam {}) -> S.singleton q Ok (_,ResParam {}) -> S.singleton q
_ -> ignore _ -> 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 gr = convert' gr []
convert' :: G.Grammar -> [Ident] -> Term -> LinValue
convert' gr vs = ppT convert' gr vs = ppT
where where
ppT0 = convert' gr vs ppT0 = convert' gr vs
@@ -162,20 +187,20 @@ convert' gr vs = ppT
S t p -> selection (ppT t) (ppT p) S t p -> selection (ppT t) (ppT p)
C t1 t2 -> concatValue (ppT t1) (ppT t2) C t1 t2 -> concatValue (ppT t1) (ppT t2)
App f a -> ap (ppT f) (ppT a) 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) P t l -> projection (ppT t) (lblId l)
Vr x -> VarValue (gId x) Vr x -> VarValue (gId x)
Cn x -> VarValue (gId x) -- hmm Cn x -> VarValue (gId x) -- hmm
Con c -> ParamConstant (Param (gId c) []) Con c -> ParamConstant (Param (gId c) [])
Sort k -> VarValue (gId k) Sort k -> VarValue (gId k)
EInt n -> LiteralValue (IntConstant n) EInt n -> LiteralValue (IntConstant n)
Q (m,n) -> if m==cPredef then ppPredef n else VarValue ((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)) []) QC (m,n) -> ParamConstant (Param (gQId m n) [])
K s -> LiteralValue (StrConstant s) K s -> LiteralValue (StrConstant s)
Empty -> LiteralValue (StrConstant "") Empty -> LiteralValue (StrConstant "")
FV ts -> VariantValue (map ppT ts) FV ts -> VariantValue (map ppT ts)
Alts t' vs -> alts vs (ppT t') 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) 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" Ok ALL_CAPIT -> p "ALL_CAPIT"
_ -> VarValue (gQId cPredef n) -- hmm _ -> VarValue (gQId cPredef n) -- hmm
where where
p = PredefValue . PredefId p = PredefValue . PredefId . rawIdentS
ppP p = ppP p =
case p of case p of
PC c ps -> ParamPattern (Param (gId c) (map ppP ps)) 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) {- PR r -> RecordPattern (fields r) {-
PW -> WildPattern PW -> WildPattern
PV x -> VarP x PV x -> VarP x
@@ -202,6 +227,7 @@ convert' gr vs = ppT
PFloat x -> Lit (show x) PFloat x -> Lit (show x)
PT _ p -> ppP p PT _ p -> ppP p
PAs x p -> AsP x (ppP p) -} PAs x p -> AsP x (ppP p) -}
_ -> error $ "convert' ppP: " ++ show p
where where
fields = map field . filter (not.isLockLabel.fst) fields = map field . filter (not.isLockLabel.fst)
field (l,p) = RecordRow (lblId l) (ppP p) field (l,p) = RecordRow (lblId l) (ppP p)
@@ -218,12 +244,12 @@ convert' gr vs = ppT
pre Empty = [""] -- Empty == K "" pre Empty = [""] -- Empty == K ""
pre (Strs ts) = concatMap pre ts pre (Strs ts) = concatMap pre ts
pre (EPatt p) = pat p pre (EPatt p) = pat p
pre t = error $ "pre "++show t pre t = error $ "convert' alts pre: " ++ show t
pat (PString s) = [s] pat (PString s) = [s]
pat (PAlt p1 p2) = pat p1++pat p2 pat (PAlt p1 p2) = pat p1++pat p2
pat (PSeq p1 p2) = [s1++s2 | s1<-pat p1, s2<-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) fields = map field . filter (not.isLockLabel.fst)
field (l,(_,t)) = RecordRow (lblId l) (ppT t) field (l,(_,t)) = RecordRow (lblId l) (ppT t)
@@ -236,6 +262,7 @@ convert' gr vs = ppT
ParamConstant (Param p (ps++[a])) ParamConstant (Param p (ps++[a]))
_ -> error $ "convert' ap: "++render (ppA f <+> ppA a) _ -> error $ "convert' ap: "++render (ppA f <+> ppA a)
concatValue :: LinValue -> LinValue -> LinValue
concatValue v1 v2 = concatValue v1 v2 =
case (v1,v2) of case (v1,v2) of
(LiteralValue (StrConstant ""),_) -> v2 (LiteralValue (StrConstant ""),_) -> v2
@@ -243,21 +270,24 @@ concatValue v1 v2 =
_ -> ConcatValue v1 v2 _ -> ConcatValue v1 v2
-- | Smart constructor for projections -- | 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 = proj r l =
case r of 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 [v] -> Just v
_ -> Nothing _ -> Nothing
_ -> Nothing _ -> Nothing
-- | Smart constructor for selections -- | Smart constructor for selections
selection :: LinValue -> LinValue -> LinValue
selection t v = selection t v =
-- Note: impossible cases can become possible after grammar transformation -- Note: impossible cases can become possible after grammar transformation
case t of case t of
TableValue tt r -> TableValue tt r ->
case nub [rv|TableRow _ rv<-keep] of case nub [rv | TableRow _ rv <- keep] of
[rv] -> rv [rv] -> rv
_ -> Selection (TableValue tt r') v _ -> Selection (TableValue tt r') v
where where
@@ -276,13 +306,16 @@ selection t v =
(keep,discard) = partition (mightMatchRow v) r (keep,discard) = partition (mightMatchRow v) r
_ -> Selection t v _ -> Selection t v
impossible :: LinValue -> LinValue
impossible = CommentedValue "impossible" impossible = CommentedValue "impossible"
mightMatchRow :: LinValue -> TableRow rhs -> Bool
mightMatchRow v (TableRow p _) = mightMatchRow v (TableRow p _) =
case p of case p of
WildPattern -> True WildPattern -> True
_ -> mightMatch v p _ -> mightMatch v p
mightMatch :: LinValue -> LinPattern -> Bool
mightMatch v p = mightMatch v p =
case v of case v of
ConcatValue _ _ -> False ConcatValue _ _ -> False
@@ -294,16 +327,18 @@ mightMatch v p =
RecordValue rv -> RecordValue rv ->
case p of case p of
RecordPattern rp -> 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 _ -> False
_ -> True _ -> True
patVars :: Patt -> [Ident]
patVars p = patVars p =
case p of case p of
PV x -> [x] PV x -> [x]
PAs x p -> x:patVars p PAs x p -> x:patVars p
_ -> collectPattOp patVars p _ -> collectPattOp patVars p
convType :: Term -> LinType
convType = ppT convType = ppT
where where
ppT t = ppT t =
@@ -315,9 +350,9 @@ convType = ppT
Sort k -> convSort k Sort k -> convSort k
-- EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal -- EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal
FV (t:ts) -> ppT t -- !! FV (t:ts) -> ppT t -- !!
QC (m,n) -> ParamType (ParamTypeId ((gQId m n))) QC (m,n) -> ParamType (ParamTypeId (gQId m n))
Q (m,n) -> ParamType (ParamTypeId ((gQId m n))) Q (m,n) -> ParamType (ParamTypeId (gQId m n))
_ -> error $ "Missing case in convType for: "++show t _ -> error $ "convType ppT: " ++ show t
convFields = map convField . filter (not.isLockLabel.fst) convFields = map convField . filter (not.isLockLabel.fst)
convField (l,r) = RecordRow (lblId l) (ppT r) convField (l,r) = RecordRow (lblId l) (ppT r)
@@ -326,15 +361,20 @@ convType = ppT
"Float" -> FloatType "Float" -> FloatType
"Int" -> IntType "Int" -> IntType
"Str" -> StrType "Str" -> StrType
_ -> error ("convSort "++show k) _ -> error $ "convType convSort: " ++ show k
toParamType :: Term -> ParamType
toParamType t = case convType t of toParamType t = case convType t of
ParamType pt -> pt ParamType pt -> pt
_ -> error ("toParamType "++show t) _ -> error $ "toParamType: " ++ show t
toParamId :: Term -> ParamId
toParamId t = case toParamType t of toParamId t = case toParamType t of
ParamTypeId p -> p ParamTypeId p -> p
paramType :: G.Grammar
-> (ModuleName, Ident)
-> ((S.Set (ModuleName, Ident), S.Set QIdent), [ParamDef])
paramType gr q@(_,n) = paramType gr q@(_,n) =
case lookupOrigInfo gr q of case lookupOrigInfo gr q of
Ok (m,ResParam (Just (L _ ps)) _) Ok (m,ResParam (Just (L _ ps)) _)
@@ -342,7 +382,7 @@ paramType gr q@(_,n) =
((S.singleton (m,n),argTypes ps), ((S.singleton (m,n),argTypes ps),
[ParamDef name (map (param m) ps)] [ParamDef name (map (param m) ps)]
) )
where name = (gQId m n) where name = gQId m n
Ok (m,ResOper _ (Just (L _ t))) Ok (m,ResOper _ (Just (L _ t)))
| m==cPredef && n==cInts -> | m==cPredef && n==cInts ->
((S.empty,S.empty),[]) {- ((S.empty,S.empty),[]) {-
@@ -350,36 +390,46 @@ paramType gr q@(_,n) =
[Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-} [Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-}
| otherwise -> | otherwise ->
((S.singleton (m,n),paramTypes gr t), ((S.singleton (m,n),paramTypes gr t),
[ParamAliasDef ((gQId m n)) (convType t)]) [ParamAliasDef (gQId m n) (convType t)])
_ -> ((S.empty,S.empty),[]) _ -> ((S.empty,S.empty),[])
where 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 argTypes = S.unions . map argTypes1
argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx] argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
lblId = LabelId . render -- hmm lblId :: Label -> C.LabelId
modId (MN m) = ModId (showIdent m) 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 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 C.FunId where gId = C.FunId . ident2raw
instance FromIdent CatId where gId = CatId . showIdent instance FromIdent CatId where gId = CatId . ident2raw
instance FromIdent ParamId where gId = ParamId . unqual instance FromIdent ParamId where gId = ParamId . unqual
instance FromIdent VarValueId where gId = VarValueId . 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) instance QualIdent VarValueId where gQId m n = VarValueId (qual m n)
qual m n = Qual (modId m) (showIdent n) qual :: ModuleName -> Ident -> QualId
unqual n = Unqual (showIdent n) qual m n = Qual (modId m) (ident2raw n)
unqual :: Ident -> QualId
unqual n = Unqual (ident2raw n)
convFlags :: G.Grammar -> ModuleName -> Flags
convFlags gr mn = convFlags gr mn =
Flags [(n,convLit v) | Flags [(rawIdentS n,convLit v) |
(n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)] (n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]
where where
convLit l = convLit l =

120
src/compiler/GF/Compile/PGFtoHaskell.hs
View File

@@ -5,7 +5,7 @@
-- Stability : (stable) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/06/17 12:39:07 $ -- > CVS $Date: 2005/06/17 12:39:07 $
-- > CVS $Author: bringert $ -- > CVS $Author: bringert $
-- > CVS $Revision: 1.8 $ -- > CVS $Revision: 1.8 $
-- --
@@ -22,7 +22,7 @@ import PGF.Internal
import GF.Data.Operations import GF.Data.Operations
import GF.Infra.Option 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 import qualified Data.Map as Map
type Prefix = String -> String type Prefix = String -> String
@@ -34,11 +34,12 @@ grammar2haskell :: Options
-> PGF -> PGF
-> String -> String
grammar2haskell opts name gr = foldr (++++) [] $ grammar2haskell opts name gr = foldr (++++) [] $
pragmas ++ haskPreamble gadt name derivingClause extraImports ++ pragmas ++ haskPreamble gadt name derivingClause (extraImports ++ pgfImports) ++
[types, gfinstances gId lexical gr'] ++ compos [types, gfinstances gId lexical gr'] ++ compos
where gr' = hSkeleton gr where gr' = hSkeleton gr
gadt = haskellOption opts HaskellGADT gadt = haskellOption opts HaskellGADT
dataExt = haskellOption opts HaskellData dataExt = haskellOption opts HaskellData
pgf2 = haskellOption opts HaskellPGF2
lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat
gId | haskellOption opts HaskellNoPrefix = rmForbiddenChars gId | haskellOption opts HaskellNoPrefix = rmForbiddenChars
| otherwise = ("G"++) . rmForbiddenChars | otherwise = ("G"++) . rmForbiddenChars
@@ -50,21 +51,23 @@ grammar2haskell opts name gr = foldr (++++) [] $
derivingClause derivingClause
| dataExt = "deriving (Show,Data)" | dataExt = "deriving (Show,Data)"
| otherwise = "deriving Show" | otherwise = "deriving Show"
extraImports | gadt = ["import Control.Monad.Identity", extraImports | gadt = ["import Control.Monad.Identity", "import Data.Monoid"]
"import Data.Monoid"]
| dataExt = ["import Data.Data"] | dataExt = ["import Data.Data"]
| otherwise = [] | otherwise = []
pgfImports | pgf2 = ["import PGF2 hiding (Tree)", "", "showCId :: CId -> String", "showCId = id"]
| otherwise = ["import PGF hiding (Tree)"]
types | gadt = datatypesGADT gId lexical gr' types | gadt = datatypesGADT gId lexical gr'
| otherwise = datatypes gId derivingClause lexical gr' | otherwise = datatypes gId derivingClause lexical gr'
compos | gadt = prCompos gId lexical gr' ++ composClass compos | gadt = prCompos gId lexical gr' ++ composClass
| otherwise = [] | otherwise = []
haskPreamble gadt name derivingClause extraImports = haskPreamble :: Bool -> String -> String -> [String] -> [String]
haskPreamble gadt name derivingClause imports =
[ [
"module " ++ name ++ " where", "module " ++ name ++ " where",
"" ""
] ++ extraImports ++ [ ] ++ imports ++ [
"import PGF hiding (Tree)", "",
"----------------------------------------------------", "----------------------------------------------------",
"-- automatic translation from GF to Haskell", "-- 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 = predefInst gadt derivingClause gtyp typ destr consr =
(if gadt (if gadt
then [] then []
else ("newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n") else "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n"
) )
++ ++
"instance Gf" +++ gtyp +++ "where" ++++ "instance Gf" +++ gtyp +++ "where" ++++
@@ -103,10 +107,10 @@ type OIdent = String
type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
datatypes :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (String,HSkeleton) -> String 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 :: 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 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 :: OIdent -> String
lexicalConstructor cat = "Lex" ++ cat lexicalConstructor cat = "Lex" ++ cat
predefTypeSkel :: HSkeleton
predefTypeSkel = [(c,[]) | c <- ["String", "Int", "Float"]] predefTypeSkel = [(c,[]) | c <- ["String", "Int", "Float"]]
-- GADT version of data types -- GADT version of data types
datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
datatypesGADT gId lexical (_,skel) = unlines $ datatypesGADT gId lexical (_,skel) = unlines $
concatMap (hCatTypeGADT gId) (skel ++ predefTypeSkel) ++ concatMap (hCatTypeGADT gId) (skel ++ predefTypeSkel) ++
[ [
"", "",
"data Tree :: * -> * where" "data Tree :: * -> * where"
] ++ ] ++
concatMap (map (" "++) . hDatatypeGADT gId lexical) skel ++ concatMap (map (" "++) . hDatatypeGADT gId lexical) skel ++
[ [
" GString :: String -> Tree GString_", " GString :: String -> Tree GString_",
@@ -164,23 +169,23 @@ hCatTypeGADT gId (cat,rules)
"data"+++gId cat++"_"] "data"+++gId cat++"_"]
hDatatypeGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String] 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] | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t]
| otherwise = | otherwise =
[ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t
| (f,args) <- nonLexicalRules (lexical cat) rules ] | (f,args) <- nonLexicalRules (lexical cat) rules ]
++ if lexical cat then [lexicalConstructor cat +++ ":: String ->"+++ t] else [] ++ if lexical cat then [lexicalConstructor cat +++ ":: String ->"+++ t] else []
where t = "Tree" +++ gId cat ++ "_" where t = "Tree" +++ gId cat ++ "_"
hEqGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String] hEqGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
hEqGADT gId lexical (cat, rules) 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] | 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 [] ++ if lexical cat then ["(" ++ lexicalConstructor cat +++ "x" ++ "," ++ lexicalConstructor cat +++ "y" ++ ") -> x == y"] else []
where where
patt s (f,xs) = unwords (gId f : mkSVars s (length xs)) 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)) ] ++ ["]"]) (x,y) <- zip (mkSVars "x" (length xs)) (mkSVars "y" (length xs)) ] ++ ["]"])
listr c = (c,["foo"]) -- foo just for length = 1 listr c = (c,["foo"]) -- foo just for length = 1
listeqs = "and [x == y | (x,y) <- zip x1 y1]" listeqs = "and [x == y | (x,y) <- zip x1 y1]"
@@ -189,25 +194,26 @@ prCompos :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> [String]
prCompos gId lexical (_,catrules) = prCompos gId lexical (_,catrules) =
["instance Compos Tree where", ["instance Compos Tree where",
" compos r a f t = case t of"] " compos r a f t = case t of"]
++ ++
[" " ++ prComposCons (gId f) xs | (c,rs) <- catrules, not (isListCat (c,rs)), [" " ++ 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)] [" " ++ prComposCons (gId c) ["x1"] | (c,rs) <- catrules, isListCat (c,rs)]
++ ++
[" _ -> r t"] [" _ -> r t"]
where 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) f +++ unwords vs +++ "->" +++ rhs f (zip vs xs)
rhs f vcs = "r" +++ f +++ unwords (map (prRec f) vcs) 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 | isList f = "`a` foldr (a . a (r (:)) . f) (r [])" +++ v
| otherwise = "`a`" +++ "f" +++ 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 :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String
gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs 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 m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
hInstance gId _ m (cat,[]) = unlines [ hInstance gId _ m (cat,[]) = unlines [
"instance Show" +++ gId cat, "instance Show" +++ gId cat,
@@ -216,15 +222,15 @@ hInstance gId _ m (cat,[]) = unlines [
" gf _ = undefined", " gf _ = undefined",
" fg _ = undefined" " fg _ = undefined"
] ]
hInstance gId lexical m (cat,rules) hInstance gId lexical m (cat,rules)
| isListCat (cat,rules) = | isListCat (cat,rules) =
"instance Gf" +++ gId cat +++ "where" ++++ "instance Gf" +++ gId cat +++ "where" ++++
" gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])" " gf (" ++ gId cat +++ "[" ++ intercalate "," baseVars ++ "])"
+++ "=" +++ mkRHS ("Base"++ec) baseVars ++++ +++ "=" +++ mkRHS ("Base"++ec) baseVars ++++
" gf (" ++ gId cat +++ "(x:xs)) = " " gf (" ++ gId cat +++ "(x:xs)) = "
++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")] ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")]
-- no show for GADTs -- 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 = | otherwise =
"instance Gf" +++ gId cat +++ "where\n" ++ "instance Gf" +++ gId cat +++ "where\n" ++
unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules]
@@ -233,19 +239,22 @@ hInstance gId lexical m (cat,rules)
ec = elemCat cat ec = elemCat cat
baseVars = mkVars (baseSize (cat,rules)) baseVars = mkVars (baseSize (cat,rules))
mkInst f xx = let xx' = mkVars (length xx) in " gf " ++ 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 xx'
mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++ mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++
"[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]" "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
mkVars :: Int -> [String]
mkVars = mkSVars "x" mkVars = mkSVars "x"
mkSVars :: String -> Int -> [String]
mkSVars s n = [s ++ show i | i <- [1..n]] mkSVars s n = [s ++ show i | i <- [1..n]]
----fInstance m ("Cn",_) = "" --- ----fInstance m ("Cn",_) = "" ---
fInstance _ _ m (cat,[]) = "" fInstance _ _ m (cat,[]) = ""
fInstance gId lexical m (cat,rules) = fInstance gId lexical m (cat,rules) =
" fg t =" ++++ " fg t =" ++++
(if isList (if isList
then " " ++ gId cat ++ " (fgs t) where\n fgs t = case unApp t of" then " " ++ gId cat ++ " (fgs t) where\n fgs t = case unApp t of"
else " case unApp t of") ++++ else " case unApp t of") ++++
unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++ unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++
@@ -257,27 +266,28 @@ fInstance gId lexical m (cat,rules) =
" Just (i," ++ " Just (i," ++
"[" ++ prTList "," xx' ++ "])" +++ "[" ++ prTList "," xx' ++ "])" +++
"| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx' "| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx'
where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]] where
mkRHS f vars xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
| isList = mkRHS f vars
if "Base" `isPrefixOf` f | isList =
then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]" if "Base" `isPrefixOf` f
else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1) then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
| otherwise = else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1)
gId f +++ | otherwise =
prTList " " [prParenth ("fg" +++ x) | x <- vars] gId f +++
prTList " " [prParenth ("fg" +++ x) | x <- vars]
--type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] --type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
hSkeleton :: PGF -> (String,HSkeleton) hSkeleton :: PGF -> (String,HSkeleton)
hSkeleton gr = hSkeleton gr =
(showCId (absname gr), (showCId (absname gr),
let fs = let fs =
[(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) | [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) |
fs@((_, (_,c)):_) <- fns] 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 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))))) fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
valtyps (_, (_,x)) (_, (_,y)) = compare x y valtyps (_, (_,x)) (_, (_,y)) = compare x y
valtypg (_, (_,x)) (_, (_,y)) = x == y valtypg (_, (_,x)) (_, (_,y)) = x == y
@@ -291,9 +301,10 @@ updateSkeleton cat skel rule =
-} -}
isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool
isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2 isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2
&& ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
where c = elemCat cat where
fs = map fst rules c = elemCat cat
fs = map fst rules
-- | Gets the element category of a list category. -- | Gets the element category of a list category.
elemCat :: OIdent -> OIdent elemCat :: OIdent -> OIdent
@@ -310,7 +321,7 @@ baseSize (_,rules) = length bs
where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules
composClass :: [String] composClass :: [String]
composClass = composClass =
[ [
"", "",
"class Compos t where", "class Compos t where",
@@ -337,4 +348,3 @@ composClass =
"", "",
"newtype C b a = C { unC :: b }" "newtype C b a = C { unC :: b }"
] ]

22
src/compiler/GF/Compile/Rename.hs
View File

@@ -39,6 +39,7 @@ import GF.Data.Operations
import Control.Monad import Control.Monad
import Data.List (nub,(\\)) import Data.List (nub,(\\))
import qualified Data.List as L
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe(mapMaybe) import Data.Maybe(mapMaybe)
import GF.Text.Pretty import GF.Text.Pretty
@@ -105,7 +106,26 @@ renameIdentTerm' env@(act,imps) t0 =
ts@(t:_) -> do checkWarn ("atomic term" <+> ppTerm Qualified 0 t0 $$ ts@(t:_) -> do checkWarn ("atomic term" <+> ppTerm Qualified 0 t0 $$
"conflict" <+> hsep (punctuate ',' (map (ppTerm Qualified 0) ts)) $$ "conflict" <+> hsep (punctuate ',' (map (ppTerm Qualified 0) ts)) $$
"given" <+> fsep (punctuate ',' (map fst qualifs))) "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 :: Maybe ModuleName -> Ident -> Info -> StatusInfo
info2status mq c i = case i of info2status mq c i = case i of

3
src/compiler/GF/Grammar/Canonical.hs
View File

@@ -11,6 +11,7 @@
module GF.Grammar.Canonical where module GF.Grammar.Canonical where
import Prelude hiding ((<>)) import Prelude hiding ((<>))
import GF.Text.Pretty import GF.Text.Pretty
import GF.Infra.Ident (RawIdent)
-- | A Complete grammar -- | A Complete grammar
data Grammar = Grammar Abstract [Concrete] deriving Show data Grammar = Grammar Abstract [Concrete] deriving Show
@@ -126,7 +127,7 @@ data FlagValue = Str String | Int Int | Flt Double deriving Show
-- *** Identifiers -- *** Identifiers
type Id = String type Id = RawIdent
data QualId = Qual ModId Id | Unqual Id deriving (Eq,Ord,Show) data QualId = Qual ModId Id | Unqual Id deriving (Eq,Ord,Show)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

37
src/compiler/GF/Grammar/CanonicalJSON.hs
View File

@@ -7,6 +7,7 @@ import Control.Applicative ((<|>))
import Data.Ratio (denominator, numerator) import Data.Ratio (denominator, numerator)
import GF.Grammar.Canonical import GF.Grammar.Canonical
import Control.Monad (guard) import Control.Monad (guard)
import GF.Infra.Ident (RawIdent,showRawIdent,rawIdentS)
encodeJSON :: FilePath -> Grammar -> IO () encodeJSON :: FilePath -> Grammar -> IO ()
@@ -29,7 +30,7 @@ instance JSON Grammar where
-- ** Abstract Syntax -- ** Abstract Syntax
instance JSON Abstract where instance JSON Abstract where
showJSON (Abstract absid flags cats funs) showJSON (Abstract absid flags cats funs)
= makeObj [("abs", showJSON absid), = makeObj [("abs", showJSON absid),
("flags", showJSON flags), ("flags", showJSON flags),
("cats", showJSON cats), ("cats", showJSON cats),
@@ -81,7 +82,7 @@ instance JSON TypeBinding where
-- ** Concrete syntax -- ** Concrete syntax
instance JSON Concrete where instance JSON Concrete where
showJSON (Concrete cncid absid flags params lincats lins) showJSON (Concrete cncid absid flags params lincats lins)
= makeObj [("cnc", showJSON cncid), = makeObj [("cnc", showJSON cncid),
("abs", showJSON absid), ("abs", showJSON absid),
("flags", showJSON flags), ("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) -- record rows and lists of record rows are both encoded as JSON records (i.e., objects)
showJSON row = showJSONs [row] showJSON row = showJSONs [row]
showJSONs rows = makeObj (map toRow rows) 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 readJSON obj = head <$> readJSONs obj
readJSONs obj = mapM fromRow (assocsJSObject obj) readJSONs obj = mapM fromRow (assocsJSObject obj)
where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue 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 instance JSON rhs => JSON (TableRow rhs) where
showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)] 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 -- *** Identifiers in Concrete Syntax
instance JSON PredefId where showJSON (PredefId s) = showJSON s ; readJSON = fmap PredefId . 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 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 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 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 ParamType where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- ** Used in both Abstract and Concrete Syntax -- ** Used in both Abstract and Concrete Syntax
instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . 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 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 FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON
instance JSON VarId where instance JSON VarId where
-- the anonymous variable is the underscore: -- the anonymous variable is the underscore:
@@ -242,20 +243,24 @@ instance JSON VarId where
<|> VarId <$> readJSON o <|> VarId <$> readJSON o
instance JSON QualId where 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 showJSON (Unqual n) = showJSON n
readJSON o = do qualid <- readJSON o readJSON o = do qualid <- readJSON o
let (mod, id) = span (/= '.') qualid 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 instance JSON Flags where
-- flags are encoded directly as JSON records (i.e., objects): -- 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) readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj)
where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
return (lbl, value) return (rawIdentS lbl, value)
instance JSON FlagValue where instance JSON FlagValue where
-- flag values are encoded as basic JSON types: -- flag values are encoded as basic JSON types:

38
src/compiler/GF/Grammar/Macros.hs
View File

@@ -5,7 +5,7 @@
-- Stability : (stable) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/11/11 16:38:00 $ -- > CVS $Date: 2005/11/11 16:38:00 $
-- > CVS $Author: bringert $ -- > CVS $Author: bringert $
-- > CVS $Revision: 1.24 $ -- > CVS $Revision: 1.24 $
-- --
@@ -51,14 +51,14 @@ typeForm t =
_ -> error (render ("no normal form of type" <+> ppTerm Unqualified 0 t)) _ -> error (render ("no normal form of type" <+> ppTerm Unqualified 0 t))
typeFormCnc :: Type -> (Context, Type) typeFormCnc :: Type -> (Context, Type)
typeFormCnc t = typeFormCnc t =
case t of case t of
Prod b x a t -> let (x', v) = typeFormCnc t Prod b x a t -> let (x', v) = typeFormCnc t
in ((b,x,a):x',v) in ((b,x,a):x',v)
_ -> ([],t) _ -> ([],t)
valCat :: Type -> Cat valCat :: Type -> Cat
valCat typ = valCat typ =
let (_,cat,_) = typeForm typ let (_,cat,_) = typeForm typ
in cat in cat
@@ -99,7 +99,7 @@ isHigherOrderType t = fromErr True $ do -- pessimistic choice
contextOfType :: Monad m => Type -> m Context contextOfType :: Monad m => Type -> m Context
contextOfType typ = case typ of contextOfType typ = case typ of
Prod b x a t -> liftM ((b,x,a):) $ contextOfType t Prod b x a t -> liftM ((b,x,a):) $ contextOfType t
_ -> return [] _ -> return []
termForm :: Monad m => Term -> m ([(BindType,Ident)], Term, [Term]) termForm :: Monad m => Term -> m ([(BindType,Ident)], Term, [Term])
termForm t = case t of termForm t = case t of
@@ -108,8 +108,8 @@ termForm t = case t of
return ((b,x):x', fun, args) return ((b,x):x', fun, args)
App c a -> App c a ->
do (_,fun, args) <- termForm c do (_,fun, args) <- termForm c
return ([],fun,args ++ [a]) return ([],fun,args ++ [a])
_ -> _ ->
return ([],t,[]) return ([],t,[])
termFormCnc :: Term -> ([(BindType,Ident)], Term) termFormCnc :: Term -> ([(BindType,Ident)], Term)
@@ -254,7 +254,7 @@ mkTable :: [Term] -> Term -> Term
mkTable tt t = foldr Table t tt mkTable tt t = foldr Table t tt
mkCTable :: [(BindType,Ident)] -> Term -> Term 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)] ccase (_,x) t = T TRaw [(PV x,t)]
mkHypo :: Term -> Hypo mkHypo :: Term -> Hypo
@@ -287,7 +287,7 @@ plusRecType t1 t2 = case (t1, t2) of
filter (`elem` (map fst r1)) (map fst r2) of filter (`elem` (map fst r1)) (map fst r2) of
[] -> return (RecType (r1 ++ r2)) [] -> return (RecType (r1 ++ r2))
ls -> raise $ render ("clashing labels" <+> hsep ls) 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 :: Term -> Term -> Err Term
plusRecord t1 t2 = plusRecord t1 t2 =
@@ -304,7 +304,7 @@ defLinType = RecType [(theLinLabel, typeStr)]
-- | refreshing variables -- | refreshing variables
mkFreshVar :: [Ident] -> Ident mkFreshVar :: [Ident] -> Ident
mkFreshVar olds = varX (maxVarIndex olds + 1) mkFreshVar olds = varX (maxVarIndex olds + 1)
-- | trying to preserve a given symbol -- | trying to preserve a given symbol
mkFreshVarX :: [Ident] -> Ident -> Ident 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 :: [Ident] -> Int
maxVarIndex = maximum . ((-1):) . map varIndex maxVarIndex = maximum . ((-1):) . map varIndex
mkFreshVars :: Int -> [Ident] -> [Ident] mkFreshVars :: Int -> [Ident] -> [Ident]
mkFreshVars n olds = [varX (maxVarIndex olds + i) | i <- [1..n]] mkFreshVars n olds = [varX (maxVarIndex olds + i) | i <- [1..n]]
-- | quick hack for refining with var in editor -- | 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) PC c pp -> mkApp (Con c) (map patt2term pp)
PP c pp -> mkApp (QC 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 PT _ p -> patt2term p
PInt i -> EInt i PInt i -> EInt i
PFloat i -> EFloat i PFloat i -> EFloat i
PString s -> K s PString s -> K s
PAs x p -> appCons cAs [Vr x, patt2term p] --- an encoding PAs x p -> appCons cAs [Vr x, patt2term p] --- an encoding
PChar -> appCons cChar [] --- an encoding PChar -> appCons cChar [] --- an encoding
@@ -436,7 +436,7 @@ composSafeOp op = runIdentity . composOp (return . op)
-- | to define compositional term functions -- | to define compositional term functions
composOp :: Monad m => (Term -> m Term) -> Term -> m Term composOp :: Monad m => (Term -> m Term) -> Term -> m Term
composOp co trm = composOp co trm =
case trm of case trm of
App c a -> liftM2 App (co c) (co a) App c a -> liftM2 App (co c) (co a)
Abs b x t -> liftM (Abs b x) (co t) Abs b x t -> liftM (Abs b x) (co t)
@@ -552,13 +552,13 @@ strsFromTerm t = case t of
v0 <- mapM (strsFromTerm . fst) vs v0 <- mapM (strsFromTerm . fst) vs
c0 <- mapM (strsFromTerm . snd) vs c0 <- mapM (strsFromTerm . snd) vs
--let vs' = zip v0 c0 --let vs' = zip v0 c0
return [strTok (str2strings def) vars | return [strTok (str2strings def) vars |
def <- d0, 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] vv <- sequence v0]
] ]
FV ts -> mapM strsFromTerm ts >>= return . concat 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)) _ -> raise (render ("cannot get Str from term" <+> ppTerm Unqualified 0 t))
getTableType :: TInfo -> Err Type getTableType :: TInfo -> Err Type
@@ -590,11 +590,11 @@ noExist = FV []
defaultLinType :: Type defaultLinType :: Type
defaultLinType = mkRecType linLabel [typeStr] 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 :: [(Label,a)] -> [(Label,a)]
sortRec = sortBy ordLabel where sortRec = sortBy ordLabel where
ordLabel (r1,_) (r2,_) = ordLabel (r1,_) (r2,_) =
case (showIdent (label2ident r1), showIdent (label2ident r2)) of case (showIdent (label2ident r1), showIdent (label2ident r2)) of
("s",_) -> LT ("s",_) -> LT
(_,"s") -> GT (_,"s") -> GT
@@ -605,7 +605,7 @@ sortRec = sortBy ordLabel where
-- | dependency check, detecting circularities and returning topo-sorted list -- | dependency check, detecting circularities and returning topo-sorted list
allDependencies :: (ModuleName -> Bool) -> Map.Map Ident Info -> [(Ident,[Ident])] 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] [(f, nub (concatMap opty (pts i))) | (f,i) <- Map.toList b]
where where
opersIn t = case t of opersIn t = case t of

39
src/compiler/GF/Infra/Ident.hs
View File

@@ -5,7 +5,7 @@
-- Stability : (stable) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/11/15 11:43:33 $ -- > CVS $Date: 2005/11/15 11:43:33 $
-- > CVS $Author: aarne $ -- > CVS $Author: aarne $
-- > CVS $Revision: 1.8 $ -- > CVS $Revision: 1.8 $
-- --
@@ -13,18 +13,18 @@
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module GF.Infra.Ident (-- ** Identifiers module GF.Infra.Ident (-- ** Identifiers
ModuleName(..), moduleNameS, ModuleName(..), moduleNameS,
Ident, ident2utf8, showIdent, prefixIdent, Ident, ident2utf8, showIdent, prefixIdent,
-- *** Normal identifiers (returned by the parser) -- *** Normal identifiers (returned by the parser)
identS, identC, identW, identS, identC, identW,
-- *** Special identifiers for internal use -- *** Special identifiers for internal use
identV, identA, identAV, identV, identA, identAV,
argIdent, isArgIdent, getArgIndex, argIdent, isArgIdent, getArgIndex,
varStr, varX, isWildIdent, varIndex, varStr, varX, isWildIdent, varIndex,
-- *** Raw identifiers -- *** Raw identifiers
RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent, RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
isPrefixOf, showRawIdent isPrefixOf, showRawIdent
) where ) where
import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString.Char8 as BS(append,isPrefixOf) 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 -- | the constructors labelled /INTERNAL/ are
-- internal representation never returned by the parser -- internal representation never returned by the parser
data Ident = data Ident =
IC {-# UNPACK #-} !RawIdent -- ^ raw identifier after parsing, resolved in Rename IC {-# UNPACK #-} !RawIdent -- ^ raw identifier after parsing, resolved in Rename
| IW -- ^ wildcard | IW -- ^ wildcard
-- --
@@ -54,7 +54,7 @@ data Ident =
| IV {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int -- ^ /INTERNAL/ variable | IV {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int -- ^ /INTERNAL/ variable
| IA {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int -- ^ /INTERNAL/ argument of cat at position | 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 | IAV {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int {-# UNPACK #-} !Int -- ^ /INTERNAL/ argument of cat with bindings at position
-- --
deriving (Eq, Ord, Show, Read) deriving (Eq, Ord, Show, Read)
-- | Identifiers are stored as UTF-8-encoded bytestrings. -- | Identifiers are stored as UTF-8-encoded bytestrings.
@@ -70,14 +70,13 @@ rawIdentS = Id . pack
rawIdentC = Id rawIdentC = Id
showRawIdent = unpack . rawId2utf8 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 isPrefixOf (Id x) (Id y) = BS.isPrefixOf x y
instance Binary RawIdent where instance Binary RawIdent where
put = put . rawId2utf8 put = put . rawId2utf8
get = fmap rawIdentC get get = fmap rawIdentC get
-- | This function should be used with care, since the returned ByteString is -- | This function should be used with care, since the returned ByteString is
-- UTF-8-encoded. -- UTF-8-encoded.
ident2utf8 :: Ident -> UTF8.ByteString 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)) IAV (Id s) b j -> BS.append s (pack ('_':show b ++ '_':show j))
IW -> pack "_" IW -> pack "_"
ident2raw :: Ident -> RawIdent
ident2raw = Id . ident2utf8 ident2raw = Id . ident2utf8
showIdent :: Ident -> String showIdent :: Ident -> String
@@ -95,13 +95,14 @@ showIdent i = unpack $! ident2utf8 i
instance Pretty Ident where pp = pp . showIdent instance Pretty Ident where pp = pp . showIdent
instance Pretty RawIdent where pp = pp . showRawIdent
identS :: String -> Ident identS :: String -> Ident
identS = identC . rawIdentS identS = identC . rawIdentS
identC :: RawIdent -> Ident identC :: RawIdent -> Ident
identW :: Ident identW :: Ident
prefixIdent :: String -> Ident -> Ident prefixIdent :: String -> Ident -> Ident
prefixIdent pref = identC . Id . BS.append (pack pref) . ident2utf8 prefixIdent pref = identC . Id . BS.append (pack pref) . ident2utf8
@@ -112,7 +113,7 @@ identV :: RawIdent -> Int -> Ident
identA :: RawIdent -> Int -> Ident identA :: RawIdent -> Int -> Ident
identAV:: RawIdent -> Int -> Int -> Ident identAV:: RawIdent -> Int -> Int -> Ident
(identC, identV, identA, identAV, identW) = (identC, identV, identA, identAV, identW) =
(IC, IV, IA, IAV, IW) (IC, IV, IA, IAV, IW)
-- | to mark argument variables -- | to mark argument variables

104
src/compiler/GF/Infra/Option.hs
View File

@@ -2,13 +2,13 @@ module GF.Infra.Option
( (
-- ** Command line options -- ** Command line options
-- *** Option types -- *** Option types
Options, Options,
Flags(..), Flags(..),
Mode(..), Phase(..), Verbosity(..), Mode(..), Phase(..), Verbosity(..),
OutputFormat(..), OutputFormat(..),
SISRFormat(..), Optimization(..), CFGTransform(..), HaskellOption(..), SISRFormat(..), Optimization(..), CFGTransform(..), HaskellOption(..),
Dump(..), Pass(..), Recomp(..), Dump(..), Pass(..), Recomp(..),
outputFormatsExpl, outputFormatsExpl,
-- *** Option parsing -- *** Option parsing
parseOptions, parseModuleOptions, fixRelativeLibPaths, parseOptions, parseModuleOptions, fixRelativeLibPaths,
-- *** Option pretty-printing -- *** Option pretty-printing
@@ -47,7 +47,7 @@ import PGF.Internal(Literal(..))
import qualified Control.Monad.Fail as Fail import qualified Control.Monad.Fail as Fail
usageHeader :: String usageHeader :: String
usageHeader = unlines usageHeader = unlines
["Usage: gf [OPTIONS] [FILE [...]]", ["Usage: gf [OPTIONS] [FILE [...]]",
"", "",
"How each FILE is handled depends on the file name suffix:", "How each FILE is handled depends on the file name suffix:",
@@ -90,10 +90,10 @@ data Phase = Preproc | Convert | Compile | Link
data OutputFormat = FmtPGFPretty data OutputFormat = FmtPGFPretty
| FmtCanonicalGF | FmtCanonicalGF
| FmtCanonicalJson | FmtCanonicalJson
| FmtJavaScript | FmtJavaScript
| FmtJSON | FmtJSON
| FmtPython | FmtPython
| FmtHaskell | FmtHaskell
| FmtJava | FmtJava
| FmtProlog | FmtProlog
| FmtBNF | FmtBNF
@@ -102,37 +102,42 @@ data OutputFormat = FmtPGFPretty
| FmtNoLR | FmtNoLR
| FmtSRGS_XML | FmtSRGS_XML
| FmtSRGS_XML_NonRec | FmtSRGS_XML_NonRec
| FmtSRGS_ABNF | FmtSRGS_ABNF
| FmtSRGS_ABNF_NonRec | FmtSRGS_ABNF_NonRec
| FmtJSGF | FmtJSGF
| FmtGSL | FmtGSL
| FmtVoiceXML | FmtVoiceXML
| FmtSLF | FmtSLF
| FmtRegExp | FmtRegExp
| FmtFA | FmtFA
deriving (Eq,Ord) deriving (Eq,Ord)
data SISRFormat = data SISRFormat =
-- | SISR Working draft 1 April 2003 -- | SISR Working draft 1 April 2003
-- <http://www.w3.org/TR/2003/WD-semantic-interpretation-20030401/> -- <http://www.w3.org/TR/2003/WD-semantic-interpretation-20030401/>
SISR_WD20030401 SISR_WD20030401
| SISR_1_0 | SISR_1_0
deriving (Show,Eq,Ord) deriving (Show,Eq,Ord)
data Optimization = OptStem | OptCSE | OptExpand | OptParametrize data Optimization = OptStem | OptCSE | OptExpand | OptParametrize
deriving (Show,Eq,Ord) deriving (Show,Eq,Ord)
data CFGTransform = CFGNoLR data CFGTransform = CFGNoLR
| CFGRegular | CFGRegular
| CFGTopDownFilter | CFGTopDownFilter
| CFGBottomUpFilter | CFGBottomUpFilter
| CFGStartCatOnly | CFGStartCatOnly
| CFGMergeIdentical | CFGMergeIdentical
| CFGRemoveCycles | CFGRemoveCycles
deriving (Show,Eq,Ord) deriving (Show,Eq,Ord)
data HaskellOption = HaskellNoPrefix | HaskellGADT | HaskellLexical data HaskellOption = HaskellNoPrefix
| HaskellConcrete | HaskellVariants | HaskellData | HaskellGADT
| HaskellLexical
| HaskellConcrete
| HaskellVariants
| HaskellData
| HaskellPGF2
deriving (Show,Eq,Ord) deriving (Show,Eq,Ord)
data Warning = WarnMissingLincat data Warning = WarnMissingLincat
@@ -196,7 +201,7 @@ instance Show Options where
parseOptions :: ErrorMonad err => parseOptions :: ErrorMonad err =>
[String] -- ^ list of string arguments [String] -- ^ list of string arguments
-> err (Options, [FilePath]) -> err (Options, [FilePath])
parseOptions args parseOptions args
| not (null errs) = errors errs | not (null errs) = errors errs
| otherwise = do opts <- concatOptions `fmap` liftErr (sequence optss) | otherwise = do opts <- concatOptions `fmap` liftErr (sequence optss)
return (opts, files) return (opts, files)
@@ -208,7 +213,7 @@ parseModuleOptions :: ErrorMonad err =>
-> err Options -> err Options
parseModuleOptions args = do parseModuleOptions args = do
(opts,nonopts) <- parseOptions args (opts,nonopts) <- parseOptions args
if null nonopts if null nonopts
then return opts then return opts
else errors $ map ("Non-option among module options: " ++) nonopts else errors $ map ("Non-option among module options: " ++) nonopts
@@ -281,7 +286,7 @@ defaultFlags = Flags {
optOptimizations = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize], optOptimizations = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize],
optOptimizePGF = False, optOptimizePGF = False,
optSplitPGF = False, optSplitPGF = False,
optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter, optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter,
CFGTopDownFilter, CFGMergeIdentical], CFGTopDownFilter, CFGMergeIdentical],
optLibraryPath = [], optLibraryPath = [],
optStartCat = Nothing, optStartCat = Nothing,
@@ -301,7 +306,7 @@ defaultFlags = Flags {
-- | Option descriptions -- | Option descriptions
{-# NOINLINE optDescr #-} {-# NOINLINE optDescr #-}
optDescr :: [OptDescr (Err Options)] optDescr :: [OptDescr (Err Options)]
optDescr = optDescr =
[ [
Option ['?','h'] ["help"] (NoArg (mode ModeHelp)) "Show help message.", Option ['?','h'] ["help"] (NoArg (mode ModeHelp)) "Show help message.",
Option ['V'] ["version"] (NoArg (mode ModeVersion)) "Display GF version number.", Option ['V'] ["version"] (NoArg (mode ModeVersion)) "Display GF version number.",
@@ -327,44 +332,44 @@ optDescr =
-- Option ['t'] ["trace"] (NoArg (trace True)) "Trace computations", -- Option ['t'] ["trace"] (NoArg (trace True)) "Trace computations",
-- Option [] ["no-trace"] (NoArg (trace False)) "Don't 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 [] ["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:", (unlines ["Output format. FMT can be one of:",
"Canonical GF grammar: canonical_gf, canonical_json, (and haskell with option --haskell=concrete)", "Canonical GF grammar: canonical_gf, canonical_json, (and haskell with option --haskell=concrete)",
"Multiple concrete: pgf (default), json, js, pgf_pretty, prolog, python, ...", -- gar, "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, "Single concrete only: bnf, ebnf, fa, gsl, jsgf, regexp, slf, srgs_xml, srgs_abnf, vxml, ....", -- cf, lbnf,
"Abstract only: haskell, ..."]), -- prolog_abs, "Abstract only: haskell, ..."]), -- prolog_abs,
Option [] ["sisr"] (ReqArg sisrFmt "FMT") Option [] ["sisr"] (ReqArg sisrFmt "FMT")
(unlines ["Include SISR tags in generated speech recognition grammars.", (unlines ["Include SISR tags in generated speech recognition grammars.",
"FMT can be one of: old, 1.0"]), "FMT can be one of: old, 1.0"]),
Option [] ["haskell"] (ReqArg hsOption "OPTION") Option [] ["haskell"] (ReqArg hsOption "OPTION")
("Turn on an optional feature when generating Haskell data types. OPTION = " ("Turn on an optional feature when generating Haskell data types. OPTION = "
++ concat (intersperse " | " (map fst haskellOptionNames))), ++ concat (intersperse " | " (map fst haskellOptionNames))),
Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]") Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]")
"Treat CAT as a lexical category.", "Treat CAT as a lexical category.",
Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]") Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]")
"Treat CAT as a literal category.", "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.", "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.", "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.", "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.", "(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.", "Never recompile from source, if there is already .gfo file.",
Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.", Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.",
Option [] ["probs"] (ReqArg probsFile "file.probs") "Read probabilities from file.", 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, ", (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, ", "with suffixes depending on the formats, and, when relevant, ",
"internally in the output."]), "internally in the output."]),
Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.", Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.",
Option [] ["path"] (ReqArg setLibPath "DIR:DIR:...") "Set 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.", (unlines ["Use CMD to preprocess input files.",
"Multiple preprocessors can be used by giving this option multiple times."]), "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, ..."), ("Character encoding of the source grammar, ENCODING = utf8, latin1, cp1251, ..."),
Option [] ["startcat"] (ReqArg startcat "CAT") "Grammar start category.", Option [] ["startcat"] (ReqArg startcat "CAT") "Grammar start category.",
Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.", 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 [] ["unlexer"] (ReqArg unlexer "UNLEXER") "Use unlexer UNLEXER.",
Option [] ["pmcfg"] (NoArg (pmcfg True)) "Generate PMCFG (default).", Option [] ["pmcfg"] (NoArg (pmcfg True)) "Generate PMCFG (default).",
Option [] ["no-pmcfg"] (NoArg (pmcfg False)) "Don't generate PMCFG (useful for libraries).", 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", "Select an optimization package. OPT = all | values | parametrize | none",
Option [] ["optimize-pgf"] (NoArg (optimize_pgf True)) Option [] ["optimize-pgf"] (NoArg (optimize_pgf True))
"Enable or disable global grammar optimization. This could significantly reduce the size of the final PGF file", "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 optimize x = case lookup x optimizationPackages of
Just p -> set $ \o -> o { optOptimizations = p } Just p -> set $ \o -> o { optOptimizations = p }
Nothing -> fail $ "Unknown optimization package: " ++ x Nothing -> fail $ "Unknown optimization package: " ++ x
optimize_pgf x = set $ \o -> o { optOptimizePGF = x } optimize_pgf x = set $ \o -> o { optOptimizePGF = x }
splitPGF x = set $ \o -> o { optSplitPGF = x } splitPGF x = set $ \o -> o { optSplitPGF = x }
@@ -471,7 +476,7 @@ outputFormats :: [(String,OutputFormat)]
outputFormats = map fst outputFormatsExpl outputFormats = map fst outputFormatsExpl
outputFormatsExpl :: [((String,OutputFormat),String)] outputFormatsExpl :: [((String,OutputFormat),String)]
outputFormatsExpl = outputFormatsExpl =
[(("pgf_pretty", FmtPGFPretty),"human-readable pgf"), [(("pgf_pretty", FmtPGFPretty),"human-readable pgf"),
(("canonical_gf", FmtCanonicalGF),"Canonical GF source files"), (("canonical_gf", FmtCanonicalGF),"Canonical GF source files"),
(("canonical_json", FmtCanonicalJson),"Canonical JSON source files"), (("canonical_json", FmtCanonicalJson),"Canonical JSON source files"),
@@ -504,11 +509,11 @@ instance Read OutputFormat where
readsPrec = lookupReadsPrec outputFormats readsPrec = lookupReadsPrec outputFormats
optimizationPackages :: [(String, Set Optimization)] optimizationPackages :: [(String, Set Optimization)]
optimizationPackages = optimizationPackages =
[("all", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]), [("all", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
("values", Set.fromList [OptStem,OptCSE,OptExpand]), ("values", Set.fromList [OptStem,OptCSE,OptExpand]),
("noexpand", Set.fromList [OptStem,OptCSE]), ("noexpand", Set.fromList [OptStem,OptCSE]),
-- deprecated -- deprecated
("all_subs", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]), ("all_subs", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
("parametrize", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]), ("parametrize", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
@@ -516,7 +521,7 @@ optimizationPackages =
] ]
cfgTransformNames :: [(String, CFGTransform)] cfgTransformNames :: [(String, CFGTransform)]
cfgTransformNames = cfgTransformNames =
[("nolr", CFGNoLR), [("nolr", CFGNoLR),
("regular", CFGRegular), ("regular", CFGRegular),
("topdown", CFGTopDownFilter), ("topdown", CFGTopDownFilter),
@@ -532,7 +537,8 @@ haskellOptionNames =
("lexical", HaskellLexical), ("lexical", HaskellLexical),
("concrete", HaskellConcrete), ("concrete", HaskellConcrete),
("variants", HaskellVariants), ("variants", HaskellVariants),
("data", HaskellData)] ("data", HaskellData),
("pgf2", HaskellPGF2)]
-- | This is for bacward compatibility. Since GHC 6.12 we -- | This is for bacward compatibility. Since GHC 6.12 we
-- started using the native Unicode support in GHC but it -- 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 _ -> fail $ "Expected [on,off], got: " ++ show x
readOutputFormat :: Fail.MonadFail m => String -> m OutputFormat readOutputFormat :: Fail.MonadFail m => String -> m OutputFormat
readOutputFormat s = readOutputFormat s =
maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats
-- FIXME: this is a copy of the function in GF.Devel.UseIO. -- 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 :: Char -> Bool
isPathSep c = c == ':' || c == ';' isPathSep c = c == ':' || c == ';'
-- --
-- * Convenience functions for checking options -- * Convenience functions for checking options
-- --
@@ -592,7 +598,7 @@ isLiteralCat opts c = Set.member c (flag optLiteralCats opts)
isLexicalCat :: Options -> String -> Bool isLexicalCat :: Options -> String -> Bool
isLexicalCat opts c = Set.member c (flag optLexicalCats opts) isLexicalCat opts c = Set.member c (flag optLexicalCats opts)
-- --
-- * Convenience functions for setting options -- * 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 :: (Bounded a, Enum a, Ord a) => Int -> Maybe a
toEnumBounded i = let mi = minBound toEnumBounded i = let mi = minBound
ma = maxBound `asTypeOf` mi ma = maxBound `asTypeOf` mi
in if i >= fromEnum mi && i <= fromEnum ma in if i >= fromEnum mi && i <= fromEnum ma
then Just (toEnum i `asTypeOf` mi) then Just (toEnum i `asTypeOf` mi)
else Nothing else Nothing

1
testsuite/canonical/.gitignore vendored Normal file
View File

@@ -0,0 +1 @@
canonical/

102
testsuite/canonical/gold/FoodsFin.gf Normal file
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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