msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Merge with master and drop the Haskell runtime completely

Browse Source
This commit is contained in:
krangelov
2019-09-19 22:01:57 +02:00
parent e993ae59f8 9d3badd8b2
commit 4a71464ca7
488 changed files with 8762 additions and 39251 deletions
Download Patch File Download Diff File Expand all files Collapse all files

16
src/compiler/GF/Compile/CheckGrammar.hs
View File

@@ -146,11 +146,17 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
return $ updateTree (c,CncFun (Just linty) d mn mf) js
_ -> do checkWarn ("function" <+> c <+> "is not in abstract")
return js
CncCat _ _ _ _ _ -> case lookupOrigInfo gr (am,c) of
Ok _ -> return $ updateTree i js
_ -> do checkWarn ("category" <+> c <+> "is not in abstract")
return js
_ -> return $ updateTree i js
CncCat {} ->
case lookupOrigInfo gr (am,c) of
Ok (_,AbsCat _) -> return $ updateTree i js
{- -- This might be too pedantic:
Ok (_,AbsFun {}) ->
checkError ("lincat:"<+>c<+>"is a fun, not a cat")
-}
_ -> do checkWarn ("category" <+> c <+> "is not in abstract")
return js
_ -> return $ updateTree i js
-- | General Principle: only Just-values are checked.

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

@@ -1,365 +1,351 @@
-- | Translate concrete syntax to Haskell
module GF.Compile.ConcreteToHaskell(concretes2haskell,concrete2haskell) where
import Data.List(sort,sortBy)
import Data.Function(on)
import Data.List(isPrefixOf,sort,sortOn)
import qualified Data.Map as M
import qualified Data.Set as S
import GF.Data.ErrM
import GF.Data.Utilities(mapSnd)
import GF.Text.Pretty
import GF.Grammar.Grammar
import GF.Grammar.Lookup(lookupFunType,lookupOrigInfo,allOrigInfos)--,allParamValues
import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp)
import GF.Grammar.Lockfield(isLockLabel)
import GF.Grammar.Predef(cPredef,cInts)
import GF.Compile.Compute.Predef(predef)
import GF.Compile.Compute.Value(Predefined(..))
import GF.Infra.Ident(Ident,identS,prefixIdent) --,moduleNameS
--import GF.Grammar.Predef(cPredef,cInts)
--import GF.Compile.Compute.Predef(predef)
--import GF.Compile.Compute.Value(Predefined(..))
import GF.Infra.Ident(Ident,identS,identW,prefixIdent)
import GF.Infra.Option
import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
import GF.Haskell
import Debug.Trace
import GF.Haskell as H
import GF.Grammar.Canonical as C
import GF.Compile.GrammarToCanonical
import Debug.Trace(trace)
-- | Generate Haskell code for the all concrete syntaxes associated with
-- the named abstract syntax in given the grammar.
concretes2haskell opts absname gr =
[(cncname,concrete2haskell opts gr cenv absname cnc cncmod)
| let cenv = resourceValues opts gr,
cnc<-allConcretes gr absname,
let cncname = render cnc ++ ".hs" :: FilePath
Ok cncmod = lookupModule gr cnc
[(filename,render80 $ concrete2haskell opts abstr cncmod)
| let Grammar abstr cncs = grammar2canonical opts absname gr,
cncmod<-cncs,
let ModId name = concName cncmod
filename = name ++ ".hs" :: FilePath
]
-- | Generate Haskell code for the given concrete module.
-- The only options that make a difference are
-- @-haskell=noprefix@ and @-haskell=variants@.
concrete2haskell opts gr cenv absname cnc modinfo =
renderStyle style{lineLength=80,ribbonsPerLine=1} $
haskPreamble va absname cnc $$ vcat (
nl:Comment "--- Parameter types ---":
neededParamTypes S.empty (params defs) ++
nl:Comment "--- Type signatures for linearization functions ---":
map signature (S.toList allcats)++
nl:Comment "--- Linearization functions for empty categories ---":
emptydefs ++
nl:Comment "--- Linearization types and linearization functions ---":
map ppDef defs ++
nl:Comment "--- Type classes for projection functions ---":
map labelClass (S.toList labels) ++
nl:Comment "--- Record types ---":
concatMap recordType recs)
concrete2haskell opts
abstr@(Abstract _ _ cats funs)
modinfo@(Concrete cnc absname _ ps lcs lns) =
haskPreamble absname cnc $$
vcat (
nl:Comment "--- Parameter types ---":
map paramDef ps ++
nl:Comment "--- Type signatures for linearization functions ---":
map signature cats ++
nl:Comment "--- Linearization functions for empty categories ---":
emptydefs ++
nl:Comment "--- Linearization types ---":
map lincatDef lcs ++
nl:Comment "--- Linearization functions ---":
lindefs ++
nl:Comment "--- Type classes for projection functions ---":
map labelClass (S.toList labels) ++
nl:Comment "--- Record types ---":
concatMap recordType recs)
where
nl = Comment ""
recs = S.toList (S.difference (records (lcs,lns)) common_records)
labels = S.difference (S.unions (map S.fromList recs)) common_labels
recs = S.toList (S.difference (records rhss) common_records)
common_records = S.fromList [[label_s]]
common_labels = S.fromList [label_s]
label_s = ident2label (identS "s")
label_s = LabelId "s"
rhss = map (either snd (snd.snd)) defs
defs = sortBy (compare `on` either (const Nothing) (Just . fst)) .
concatMap (toHaskell gId gr absname cenv) .
M.toList $
jments modinfo
-- signature c = "lin"<>c<+>"::"<+>"A."<>gId c<+>"->"<+>"Lin"<>c
-- signature c = "--lin"<>c<+>":: (Applicative f,Monad f) =>"<+>"A."<>gId c<+>"->"<+>"f Lin"<>c
signature c = TypeSig lf (Fun abs (pure lin))
signature (CatDef c _) = TypeSig lf (Fun abs (pure lin))
where
abs = tcon0 (prefixIdent "A." (gId c))
lin = tcon0 lc
lf = prefixIdent "lin" c
lc = prefixIdent "Lin" c
lf = linfunName c
lc = lincatName c
emptydefs = map emptydef (S.toList emptyCats)
emptydef c = Eqn (prefixIdent "lin" c,[WildP]) (Const "undefined")
emptydef c = Eqn (linfunName c,[WildP]) (Const "undefined")
emptyCats = allcats `S.difference` cats
cats = S.fromList [c|Right (c,_)<-defs]
allcats = S.fromList [c|((_,c),AbsCat (Just _))<-allOrigInfos gr absname]
emptyCats = allcats `S.difference` linfuncats
where
--funcats = S.fromList [c | FunDef f (C.Type _ (TypeApp c _))<-funs]
allcats = S.fromList [c | CatDef c _<-cats]
gId :: ToIdent i => i -> Ident
gId = (if haskellOption opts HaskellNoPrefix then id else prefixIdent "G")
. toIdent
params = S.toList . S.unions . map params1
params1 (Left (_,rhs)) = paramTypes gr rhs
params1 (Right (_,(_,rhs))) = tableTypes gr [rhs]
ppDef (Left (lhs,rhs)) = lhs (convType va gId rhs)
ppDef (Right (_,(lhs,rhs))) = lhs (convert va gId gr rhs)
gId :: Ident -> Ident
gId = if haskellOption opts HaskellNoPrefix then id else prefixIdent "G"
va = haskellOption opts HaskellVariants
pure = if va then ListT else id
neededParamTypes have [] = []
neededParamTypes have (q:qs) =
if q `S.member` have
then neededParamTypes have qs
else let ((got,need),def) = paramType va gId gr q
in def++neededParamTypes (S.union got have) (S.toList need++qs)
haskPreamble :: Bool -> ModuleName -> ModuleName -> Doc
haskPreamble va absname cncname =
"{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}" $$
"module" <+> cncname <+> "where" $$
"import Prelude hiding (Ordering(..))" $$
"import Control.Applicative((<$>),(<*>))" $$
"import PGF.Haskell" $$
"import qualified" <+> absname <+> "as A" $$
"" $$
"--- Standard definitions ---" $$
"linString (A.GString s) ="<+>pure "R_s [TK s]" $$
"linInt (A.GInt i) ="<+>pure "R_s [TK (show i)]" $$
"linFloat (A.GFloat x) ="<+>pure "R_s [TK (show x)]" $$
"" $$
"----------------------------------------------------" $$
"-- Automatic translation from GF to Haskell follows" $$
"----------------------------------------------------"
where
pure = if va then brackets else pp
toHaskell gId gr absname cenv (name,jment) =
case jment of
CncCat (Just (L loc typ)) _ _ pprn _ ->
[Left (tsyn0 (prefixIdent "Lin" name),nf loc typ)]
CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ ->
-- trace (render (name<+>hcat[parens (x<>"::"<>t)|(_,x,t)<-ctx]<+>"::"<+>cat)) $
[Right (cat,(Eqn (prefixIdent "lin" cat,lhs),coerce [] lincat rhs))]
haskPreamble :: ModId -> ModId -> Doc
haskPreamble absname cncname =
"{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}" $$
"module" <+> cncname <+> "where" $$
"import Prelude hiding (Ordering(..))" $$
"import Control.Applicative((<$>),(<*>))" $$
"import PGF.Haskell" $$
"import qualified" <+> absname <+> "as A" $$
"" $$
"--- Standard definitions ---" $$
"linString (A.GString s) ="<+>pure "R_s [TK s]" $$
"linInt (A.GInt i) ="<+>pure "R_s [TK (show i)]" $$
"linFloat (A.GFloat x) ="<+>pure "R_s [TK (show x)]" $$
"" $$
"----------------------------------------------------" $$
"-- Automatic translation from GF to Haskell follows" $$
"----------------------------------------------------"
where
Ok abstype = lookupFunType gr absname name
(absctx,_abscat,_absargs) = typeForm abstype
pure = if va then brackets else pp
e' = unAbs (length params) $
nf loc (mkAbs params (mkApp def (map Vr args)))
params = [(b,prefixIdent "g" x)|(b,x,_)<-ctx]
args = map snd params
abs_args = map (prefixIdent "abs_") args
lhs = [ConP (aId name) (map VarP abs_args)]
rhs = foldr letlin e' (zip args absctx)
letlin (a,(_,_,at)) =
Let (a,(Just (con ("Lin"++render at)),(App (con ("lin"++render at)) (con ("abs_"++render a)))))
AnyInd _ m -> case lookupOrigInfo gr (m,name) of
Ok (m,jment) -> toHaskell gId gr absname cenv (name,jment)
_ -> []
_ -> []
where
nf loc = normalForm cenv (L loc name)
aId n = prefixIdent "A." (gId n)
paramDef pd =
case pd of
ParamAliasDef p t -> H.Type (conap0 (gId p)) (convLinType t)
ParamDef p pvs -> Data (conap0 (gId p)) (map paramCon pvs) derive
where
paramCon (Param c cs) = ConAp (gId c) (map (tcon0.gId) cs)
derive = ["Eq","Ord","Show"]
unAbs 0 t = t
unAbs n (Abs _ _ t) = unAbs (n-1) t
unAbs _ t = t
convLinType = ppT
where
ppT t =
case t of
FloatType -> tcon0 (identS "Float")
IntType -> tcon0 (identS "Int")
ParamType (ParamTypeId p) -> tcon0 (gId p)
RecordType rs -> tcon (rcon' ls) (map ppT ts)
where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-rs]
StrType -> tcon0 (identS "Str")
TableType pt lt -> Fun (ppT pt) (ppT lt)
-- TupleType lts ->
lincatDef (LincatDef c t) = tsyn0 (lincatName c) (convLinType t)
linfuncats = S.fromList linfuncatl
(linfuncatl,lindefs) = unzip (linDefs lns)
linDefs = map eqn . sortOn fst . map linDef
where eqn (cat,(f,(ps,rhs))) = (cat,Eqn (f,ps) rhs)
linDef (LinDef f xs rhs0) =
(cat,(linfunName cat,(lhs,rhs)))
where
lhs = [ConP (aId f) (map VarP abs_args)]
aId f = prefixIdent "A." (gId f)
[lincat] = [lincat | LincatDef c lincat<-lcs,c==cat]
[C.Type absctx (TypeApp cat _)] = [t | FunDef f' t<-funs, f'==f]
abs_args = map abs_arg args
abs_arg = prefixIdent "abs_"
args = map (prefixIdent "g" . toIdent) xs
rhs = lets (zipWith letlin args absctx)
(convert vs (coerce env lincat rhs0))
where
vs = [(VarValueId (Unqual x),a)|(VarId x,a)<-zip xs args]
env= [(VarValueId (Unqual x),lc)|(VarId x,lc)<-zip xs (map arglincat absctx)]
letlin a (TypeBinding _ (C.Type _ (TypeApp acat _))) =
(a,Ap (Var (linfunName acat)) (Var (abs_arg a)))
arglincat (TypeBinding _ (C.Type _ (TypeApp acat _))) = lincat
where
[lincat] = [lincat | LincatDef c lincat<-lcs,c==acat]
convert = convert' va
convert' va vs = ppT
where
ppT0 = convert' False vs
ppTv vs' = convert' va vs'
pure = if va then single else id
ppT t =
case t of
TableValue ty cs -> pure (table cs)
Selection t p -> select (ppT t) (ppT p)
ConcatValue t1 t2 -> concat (ppT t1) (ppT t2)
RecordValue r -> aps (rcon ls) (map ppT ts)
where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-r]
PredefValue p -> single (Var (toIdent p)) -- hmm
Projection t l -> ap (proj l) (ppT t)
VariantValue [] -> empty
VariantValue ts@(_:_) -> variants ts
VarValue x -> maybe (Var (gId x)) (pure . Var) $ lookup x vs
PreValue vs t' -> pure (alts t' vs)
ParamConstant (Param c vs) -> aps (Var (pId c)) (map ppT vs)
ErrorValue s -> ap (Const "error") (Const (show s)) -- !!
LiteralValue l -> ppL l
_ -> error ("convert "++show t)
ppL l =
case l of
FloatConstant x -> pure (lit x)
IntConstant n -> pure (lit n)
StrConstant s -> pure (token s)
pId p@(ParamId s) =
if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack
table cs =
if all (null.patVars) ps
then lets ds (LambdaCase [(ppP p,t')|(p,t')<-zip ps ts'])
else LambdaCase (map ppCase cs)
where
(ds,ts') = dedup ts
(ps,ts) = unzip [(p,t)|TableRow p t<-cs]
ppCase (TableRow p t) = (ppP p,ppTv (patVars p++vs) t)
{-
ppPredef n =
case predef n of
Ok BIND -> single (c "BIND")
Ok SOFT_BIND -> single (c "SOFT_BIND")
Ok SOFT_SPACE -> single (c "SOFT_SPACE")
Ok CAPIT -> single (c "CAPIT")
Ok ALL_CAPIT -> single (c "ALL_CAPIT")
_ -> Var n
-}
ppP p =
case p of
ParamPattern (Param c ps) -> ConP (gId c) (map ppP ps)
RecordPattern r -> ConP (rcon' ls) (map ppP ps)
where (ls,ps) = unzip $ sortOn fst [(l,p)|RecordRow l p<-r]
WildPattern -> WildP
token s = single (c "TK" `Ap` lit s)
alts t' vs = single (c "TP" `Ap` List (map alt vs) `Ap` ppT0 t')
where
alt (s,t) = Pair (List (pre s)) (ppT0 t)
pre s = map lit s
c = Const
lit s = c (show s) -- hmm
concat = if va then concat' else plusplus
where
concat' (List [List ts1]) (List [List ts2]) = List [List (ts1++ts2)]
concat' t1 t2 = Op t1 "+++" t2
pure' = single -- forcing the list monad
select = if va then select' else Ap
select' (List [t]) (List [p]) = Op t "!" p
select' (List [t]) p = Op t "!$" p
select' t p = Op t "!*" p
ap = if va then ap' else Ap
where
ap' (List [f]) x = fmap f x
ap' f x = Op f "<*>" x
fmap f (List [x]) = pure' (Ap f x)
fmap f x = Op f "<$>" x
-- join = if va then join' else id
join' (List [x]) = x
join' x = c "concat" `Ap` x
empty = if va then List [] else c "error" `Ap` c (show "empty variant")
variants = if va then \ ts -> join' (List (map ppT ts))
else \ (t:_) -> ppT t
aps f [] = f
aps f (a:as) = aps (ap f a) as
dedup ts =
if M.null dups
then ([],map ppT ts)
else ([(ev i,ppT t)|(i,t)<-defs],zipWith entry ts is)
where
entry t i = maybe (ppT t) (Var . ev) (M.lookup i dups)
ev i = identS ("e'"++show i)
defs = [(i1,t)|(t,i1:_:_)<-ms]
dups = M.fromList [(i2,i1)|(_,i1:is@(_:_))<-ms,i2<-i1:is]
ms = M.toList m
m = fmap sort (M.fromListWith (++) (zip ts [[i]|i<-is]))
is = [0..]::[Int]
con = Cn . identS
--con = Cn . identS
tableTypes gr ts = S.unions (map tabtys ts)
where
tabtys t =
case t of
V t cc -> S.union (paramTypes gr t) (tableTypes gr cc)
T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs))
_ -> collectOp tabtys t
class Records t where
records :: t -> S.Set [LabelId]
paramTypes gr t =
case t of
RecType fs -> S.unions (map (paramTypes gr.snd) fs)
Table t1 t2 -> S.union (paramTypes gr t1) (paramTypes gr t2)
App tf ta -> S.union (paramTypes gr tf) (paramTypes gr ta)
Sort _ -> S.empty
EInt _ -> S.empty
Q q -> lookup q
QC q -> lookup q
FV ts -> S.unions (map (paramTypes gr) ts)
_ -> ignore
where
lookup q = case lookupOrigInfo gr q of
Ok (_,ResOper _ (Just (L _ t))) ->
S.insert q (paramTypes gr t)
Ok (_,ResParam {}) -> S.singleton q
_ -> ignore
instance Records t => Records [t] where
records = S.unions . map records
ignore = trace ("Ignore: "++show t) S.empty
records ts = S.unions (map recs ts)
where
recs t =
case t of
R r -> S.insert (labels r) (records (map (snd.snd) r))
RecType r -> S.insert (labels r) (records (map snd r))
_ -> collectOp recs t
labels = sort . filter (not . isLockLabel) . map fst
instance (Records t1,Records t2) => Records (t1,t2) where
records (t1,t2) = S.union (records t1) (records t2)
instance Records LincatDef where
records (LincatDef _ lt) = records lt
instance Records LinDef where
records (LinDef _ _ lv) = records lv
instance Records LinType where
records t =
case t of
RecordType r -> rowRecords r
TableType pt lt -> records (pt,lt)
TupleType ts -> records ts
_ -> S.empty
rowRecords r = S.insert (sort ls) (records ts)
where (ls,ts) = unzip [(l,t)|RecordRow l t<-r]
instance Records LinValue where
records v =
case v of
ConcatValue v1 v2 -> records (v1,v2)
ParamConstant (Param c vs) -> records vs
RecordValue r -> rowRecords r
TableValue t r -> records (t,r)
TupleValue vs -> records vs
VariantValue vs -> records vs
PreValue alts d -> records (map snd alts,d)
Projection v l -> records v
Selection v1 v2 -> records (v1,v2)
_ -> S.empty
instance Records rhs => Records (TableRow rhs) where
records (TableRow _ v) = records v
-- | Record subtyping is converted into explicit coercions in Haskell
coerce env ty t =
case (ty,t) of
(_,Let d t) -> Let d (coerce (extend env d) ty t)
(_,FV ts) -> FV (map (coerce env ty) ts)
(Table ti tv,V _ ts) -> V ti (map (coerce env tv) ts)
(Table ti tv,T (TTyped _) cs) -> T (TTyped ti) (mapSnd (coerce env tv) cs)
(RecType rt,R r) ->
R [(l,(Just ft,coerce env ft f))|(l,(_,f))<-r,Just ft<-[lookup l rt]]
(RecType rt,Vr x)->
(_,VariantValue ts) -> VariantValue (map (coerce env ty) ts)
(TableType ti tv,TableValue _ cs) ->
TableValue ti [TableRow p (coerce env tv t)|TableRow p t<-cs]
(RecordType rt,RecordValue r) ->
RecordValue [RecordRow l (coerce env ft f) |
RecordRow l f<-r,ft<-[ft|RecordRow l' ft<-rt,l'==l]]
(RecordType rt,VarValue x)->
case lookup x env of
Just ty' | ty'/=ty -> -- better to compare to normal form of ty'
--trace ("coerce "++render ty'++" to "++render ty) $
App (to_rcon (map fst rt)) t
_ -> trace ("no coerce to "++render ty) t
--trace ("coerce "++render ty'++" to "++render ty) $
app (to_rcon rt) [t]
| otherwise -> t -- types match, no coercion needed
_ -> trace (render ("missing type to coerce"<+>x<+>"to"<+>render ty
$$ "in" <+> map fst env))
t
_ -> t
where
extend env (x,(Just ty,rhs)) = (x,ty):env
extend env _ = env
app f ts = ParamConstant (Param f ts) -- !! a hack
to_rcon = ParamId . Unqual . to_rcon' . labels
convert va gId gr = convert' va gId [] gr
patVars p = []
convert' va gId vs gr = ppT
where
ppT0 = convert' False gId vs gr
ppTv vs' = convert' va gId vs' gr
labels r = [l|RecordRow l _<-r]
ppT t =
case t of
-- Only for 'let' inserted on the top-level by this converter:
Let (x,(_,xt)) t -> let1 x (ppT0 xt) (ppT t)
-- Abs b x t -> ...
V ty ts -> pure (c "table" `Ap` dedup ts)
T (TTyped ty) cs -> pure (LambdaCase (map ppCase cs))
S t p -> select (ppT t) (ppT p)
C t1 t2 -> concat (ppT t1) (ppT t2)
App f a -> ap (ppT f) (ppT a)
R r -> aps (ppT (rcon (map fst r))) (fields r)
P t l -> ap (ppT (proj l)) (ppT t)
FV [] -> empty
Vr x -> if x `elem` vs then pure (Var x) else Var x
Cn x -> pure (Var x)
Con c -> pure (Var (gId c))
Sort k -> pure (Var k)
EInt n -> pure (lit n)
Q (m,n) -> if m==cPredef then pure (ppPredef n) else Var (qual m n)
QC (m,n) -> pure (Var (gId (qual m n)))
K s -> pure (token s)
Empty -> pure (List [])
FV ts@(_:_) -> variants ts
Alts t' vs -> pure (alts t' vs)
ppCase (p,t) = (ppP p,ppTv (patVars p++vs) t)
ppPredef n =
case predef n of
Ok BIND -> single (c "BIND")
Ok SOFT_BIND -> single (c "SOFT_BIND")
Ok SOFT_SPACE -> single (c "SOFT_SPACE")
Ok CAPIT -> single (c "CAPIT")
Ok ALL_CAPIT -> single (c "ALL_CAPIT")
_ -> Var n
ppP p =
case p of
PC c ps -> ConP (gId c) (map ppP ps)
PP (_,c) ps -> ConP (gId c) (map ppP ps)
PR r -> ConP (rcon' (map fst r)) (map (ppP.snd) (filter (not.isLockLabel.fst) r))
PW -> WildP
PV x -> VarP x
PString s -> Lit (show s) -- !!
PInt i -> Lit (show i)
PFloat x -> Lit (show x)
PT _ p -> ppP p
PAs x p -> AsP x (ppP p)
token s = single (c "TK" `Ap` lit s)
alts t' vs = single (c "TP" `Ap` List (map alt vs) `Ap` ppT0 t')
where
alt (t,p) = Pair (List (pre p)) (ppT0 t)
pre (K s) = [lit s]
pre (Strs ts) = concatMap pre ts
pre (EPatt p) = pat p
pre t = error $ "pre "++show t
pat (PString s) = [lit s]
pat (PAlt p1 p2) = pat p1++pat p2
pat p = error $ "pat "++show p
fields = map (ppT.snd.snd) . sort . filter (not.isLockLabel.fst)
c = Const
lit s = c (show s) -- hmm
concat = if va then concat' else plusplus
where
concat' (List [List ts1]) (List [List ts2]) = List [List (ts1++ts2)]
concat' t1 t2 = Op t1 "+++" t2
pure = if va then single else id
pure' = single -- forcing the list monad
select = if va then select' else Ap
select' (List [t]) (List [p]) = Op t "!" p
select' (List [t]) p = Op t "!$" p
select' t p = Op t "!*" p
ap = if va then ap' else Ap
where
ap' (List [f]) x = fmap f x
ap' f x = Op f "<*>" x
fmap f (List [x]) = pure' (Ap f x)
fmap f x = Op f "<$>" x
-- join = if va then join' else id
join' (List [x]) = x
join' x = c "concat" `Ap` x
empty = if va then List [] else c "error" `Ap` c (show "empty variant")
variants = if va then \ ts -> join' (List (map ppT ts))
else \ (t:_) -> ppT t
aps f [] = f
aps f (a:as) = aps (ap f a) as
dedup ts =
if M.null dups
then List (map ppT ts)
else Lets [(ev i,ppT t)|(i,t)<-defs] (List (zipWith entry ts is))
where
entry t i = maybe (ppT t) (Var . ev) (M.lookup i dups)
ev i = identS ("e'"++show i)
defs = [(i1,t)|(t,i1:_:_)<-ms]
dups = M.fromList [(i2,i1)|(_,i1:is@(_:_))<-ms,i2<-i1:is]
ms = M.toList m
m = fmap sort (M.fromListWith (++) (zip ts [[i]|i<-is]))
is = [0..]::[Int]
patVars p =
case p of
PV x -> [x]
PAs x p -> x:patVars p
_ -> collectPattOp patVars p
convType va gId = ppT
where
ppT t =
case t of
Table ti tv -> Fun (ppT ti) (if va then ListT (ppT tv) else ppT tv)
RecType rt -> tcon (rcon' (map fst rt)) (fields rt)
App tf ta -> TAp (ppT tf) (ppT ta)
FV [] -> tcon0 (identS "({-empty variant-})")
Sort k -> tcon0 k
EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal
FV (t:ts) -> ppT t -- !!
QC (m,n) -> tcon0 (gId (qual m n))
Q (m,n) -> tcon0 (gId (qual m n))
_ -> error $ "Missing case in convType for: "++show t
fields = map (ppT.snd) . sort . filter (not.isLockLabel.fst)
proj = con . proj'
proj' l = "proj_"++render l
rcon = con . rcon_name
proj = Var . identS . proj'
proj' (LabelId l) = "proj_"++l
rcon = Var . rcon'
rcon' = identS . rcon_name
rcon_name ls = "R"++concat (sort ['_':render l|l<-ls,not (isLockLabel l)])
to_rcon = con . to_rcon'
rcon_name ls = "R"++concat (sort ['_':l|LabelId l<-ls])
to_rcon' = ("to_"++) . rcon_name
recordType ls =
@@ -400,31 +386,6 @@ labelClass l =
r = identS "r"
a = identS "a"
paramType va gId gr q@(_,n) =
case lookupOrigInfo gr q of
Ok (m,ResParam (Just (L _ ps)) _)
{- - | m/=cPredef && m/=moduleNameS "Prelude"-} ->
((S.singleton (m,n),argTypes ps),
[Data (conap0 name) (map (param m) ps)["Eq","Ord","Show"],
Instance [] (TId (identS "EnumAll") `TAp` TId name)
[(lhs0 "enumAll",foldr1 plusplus (map (enumParam m) ps))]]
)
where name = gId (qual m n)
Ok (m,ResOper _ (Just (L _ t)))
| m==cPredef && n==cInts ->
((S.singleton (m,n),S.empty),
[Type (ConAp (gId (qual m n)) [identS "n"]) (TId (identS "Int"))])
| otherwise ->
((S.singleton (m,n),paramTypes gr t),
[Type (conap0 (gId (qual m n))) (convType va gId t)])
_ -> ((S.empty,S.empty),[])
where
param m (n,ctx) = ConAp (gId (qual m n)) [convType va gId t|(_,_,t)<-ctx]
argTypes = S.unions . map argTypes1
argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
enumParam m (n,ctx) = enumCon (gId (qual m n)) (length ctx)
enumCon name arity =
if arity==0
then single (Var name)
@@ -433,5 +394,23 @@ enumCon name arity =
ap (List [f]) a = Op f "<$>" a
ap f a = Op f "<*>" a
qual :: ModuleName -> Ident -> Ident
qual m = prefixIdent (render m++"_")
lincatName,linfunName :: CatId -> Ident
lincatName c = prefixIdent "Lin" (toIdent c)
linfunName c = prefixIdent "lin" (toIdent c)
class ToIdent i where toIdent :: i -> Ident
instance ToIdent ParamId where toIdent (ParamId q) = qIdentS q
instance ToIdent PredefId where toIdent (PredefId s) = identS s
instance ToIdent CatId where toIdent (CatId s) = identS s
instance ToIdent C.FunId where toIdent (FunId s) = identS s
instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentS q
qIdentS = identS . unqual
unqual (Qual (ModId m) n) = m++"_"++n
unqual (Unqual n) = n
instance ToIdent VarId where
toIdent Anonymous = identW
toIdent (VarId s) = identS s

28
src/compiler/GF/Compile/Export.hs
View File

@@ -1,11 +1,10 @@
module GF.Compile.Export where
import PGF
import PGF2
import GF.Compile.PGFtoHaskell
--import GF.Compile.PGFtoAbstract
import GF.Compile.PGFtoJava
import GF.Compile.PGFtoProlog
import GF.Compile.PGFtoJS
import GF.Compile.PGFtoPython
import GF.Compile.PGFtoJSON
import GF.Infra.Option
--import GF.Speech.CFG
import GF.Speech.PGFToCFG
@@ -19,6 +18,7 @@ import GF.Speech.SLF
import GF.Speech.PrRegExp
import Data.Maybe
import qualified Data.Map as Map
import System.FilePath
import GF.Text.Pretty
@@ -33,11 +33,11 @@ exportPGF :: Options
exportPGF opts fmt pgf =
case fmt of
FmtPGFPretty -> multi "txt" (showPGF)
FmtJavaScript -> multi "js" pgf2js
FmtPython -> multi "py" pgf2python
FmtCanonicalGF -> [] -- canon "gf" (render80 . abstract2canonical)
FmtCanonicalJson-> []
FmtJSON -> multi "json" pgf2json
FmtHaskell -> multi "hs" (grammar2haskell opts name)
FmtJava -> multi "java" (grammar2java opts name)
FmtProlog -> multi "pl" grammar2prolog
FmtBNF -> single "bnf" bnfPrinter
FmtEBNF -> single "ebnf" (ebnfPrinter opts)
FmtSRGS_XML -> single "grxml" (srgsXmlPrinter opts)
@@ -51,17 +51,13 @@ exportPGF opts fmt pgf =
FmtRegExp -> single "rexp" regexpPrinter
FmtFA -> single "dot" slfGraphvizPrinter
where
name = fromMaybe (showCId (abstractName pgf)) (flag optName opts)
name = fromMaybe (abstractName pgf) (flag optName opts)
multi :: String -> (PGF -> String) -> [(FilePath,String)]
multi ext pr = [(name <.> ext, pr pgf)]
single :: String -> (PGF -> CId -> String) -> [(FilePath,String)]
single ext pr = [(showCId cnc <.> ext, pr pgf cnc) | cnc <- languages pgf]
-- canon ext pr = [("canonical"</>name<.>ext,pr pgf)]
single :: String -> (PGF -> Concr -> String) -> [(FilePath,String)]
single ext pr = [(concreteName cnc <.> ext, pr pgf cnc) | cnc <- Map.elems (languages pgf)]
-- | Get the name of the concrete syntax to generate output from.
-- FIXME: there should be an option to change this.
outputConcr :: PGF -> CId
outputConcr pgf = case languages pgf of
[] -> error "No concrete syntax."
cnc:_ -> cnc

389
src/compiler/GF/Compile/GrammarToCanonical.hs Normal file
View File

@@ -0,0 +1,389 @@
-- | Translate grammars to Canonical form
-- (a common intermediate representation to simplify export to other formats)
module GF.Compile.GrammarToCanonical(
grammar2canonical,abstract2canonical,concretes2canonical,
projection,selection
) where
import Data.List(nub,partition)
import qualified Data.Map as M
import qualified Data.Set as S
import GF.Data.ErrM
import GF.Text.Pretty
import GF.Grammar.Grammar
import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt)
import GF.Grammar.Lockfield(isLockLabel)
import GF.Grammar.Predef(cPredef,cInts)
import GF.Compile.Compute.Predef(predef)
import GF.Compile.Compute.Value(Predefined(..))
import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent)
import GF.Infra.Option(optionsPGF)
import PGF.Internal(Literal(..))
import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
import GF.Grammar.Canonical as C
import Debug.Trace
-- | Generate Canonical code for the named abstract syntax and all associated
-- concrete syntaxes
grammar2canonical opts absname gr =
Grammar (abstract2canonical absname gr)
(map snd (concretes2canonical opts absname gr))
-- | Generate Canonical code for the named abstract syntax
abstract2canonical absname gr =
Abstract (modId absname) (convFlags gr absname) cats funs
where
cats = [CatDef (gId c) (convCtx ctx) | ((_,c),AbsCat ctx) <- adefs]
funs = [FunDef (gId f) (convType ty) |
((_,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs]
adefs = allOrigInfos gr absname
convCtx = maybe [] (map convHypo . unLoc)
convHypo (bt,name,t) =
case typeForm t of
([],(_,cat),[]) -> gId cat -- !!
convType t =
case typeForm t of
(hyps,(_,cat),args) -> Type bs (TypeApp (gId cat) as)
where
bs = map convHypo' hyps
as = map convType args
convHypo' (bt,name,t) = TypeBinding (gId name) (convType t)
-- | Generate Canonical code for the all concrete syntaxes associated with
-- the named abstract syntax in given the grammar.
concretes2canonical opts absname gr =
[(cncname,concrete2canonical gr cenv absname cnc cncmod)
| let cenv = resourceValues opts gr,
cnc<-allConcretes gr absname,
let cncname = "canonical/"++render cnc ++ ".gf" :: FilePath
Ok cncmod = lookupModule gr cnc
]
-- | Generate Canonical GF for the given concrete module.
concrete2canonical gr cenv absname cnc modinfo =
Concrete (modId cnc) (modId absname) (convFlags gr cnc)
(neededParamTypes S.empty (params defs))
[lincat|(_,Left lincat)<-defs]
[lin|(_,Right lin)<-defs]
where
defs = concatMap (toCanonical gr absname cenv) .
M.toList $
jments modinfo
params = S.toList . S.unions . map fst
neededParamTypes have [] = []
neededParamTypes have (q:qs) =
if q `S.member` have
then neededParamTypes have qs
else let ((got,need),def) = paramType gr q
in def++neededParamTypes (S.union got have) (S.toList need++qs)
toCanonical gr absname cenv (name,jment) =
case jment of
CncCat (Just (L loc typ)) _ _ pprn _ ->
[(pts,Left (LincatDef (gId name) (convType ntyp)))]
where
pts = paramTypes gr ntyp
ntyp = nf loc typ
CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ ->
[(tts,Right (LinDef (gId name) (map gId args) (convert gr e')))]
where
tts = tableTypes gr [e']
e' = unAbs (length params) $
nf loc (mkAbs params (mkApp def (map Vr args)))
params = [(b,x)|(b,x,_)<-ctx]
args = map snd params
AnyInd _ m -> case lookupOrigInfo gr (m,name) of
Ok (m,jment) -> toCanonical gr absname cenv (name,jment)
_ -> []
_ -> []
where
nf loc = normalForm cenv (L loc name)
-- aId n = prefixIdent "A." (gId n)
unAbs 0 t = t
unAbs n (Abs _ _ t) = unAbs (n-1) t
unAbs _ t = t
tableTypes gr ts = S.unions (map tabtys ts)
where
tabtys t =
case t of
V t cc -> S.union (paramTypes gr t) (tableTypes gr cc)
T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs))
_ -> collectOp tabtys t
paramTypes gr t =
case t of
RecType fs -> S.unions (map (paramTypes gr.snd) fs)
Table t1 t2 -> S.union (paramTypes gr t1) (paramTypes gr t2)
App tf ta -> S.union (paramTypes gr tf) (paramTypes gr ta)
Sort _ -> S.empty
EInt _ -> S.empty
Q q -> lookup q
QC q -> lookup q
FV ts -> S.unions (map (paramTypes gr) ts)
_ -> ignore
where
lookup q = case lookupOrigInfo gr q of
Ok (_,ResOper _ (Just (L _ t))) ->
S.insert q (paramTypes gr t)
Ok (_,ResParam {}) -> S.singleton q
_ -> ignore
ignore = trace ("Ignore: "++show t) S.empty
convert gr = convert' gr []
convert' gr vs = ppT
where
ppT0 = convert' gr vs
ppTv vs' = convert' gr vs'
ppT t =
case t of
-- Abs b x t -> ...
-- V ty ts -> VTableValue (convType ty) (map ppT ts)
V ty ts -> TableValue (convType ty) [TableRow (ppP p) (ppT t)|(p,t)<-zip ps ts]
where
Ok pts = allParamValues gr ty
Ok ps = mapM term2patt pts
T (TTyped ty) cs -> TableValue (convType ty) (map ppCase cs)
S t p -> selection (ppT t) (ppT p)
C t1 t2 -> concatValue (ppT t1) (ppT t2)
App f a -> ap (ppT f) (ppT a)
R r -> RecordValue (fields r)
P t l -> projection (ppT t) (lblId l)
Vr x -> VarValue (gId x)
Cn x -> VarValue (gId x) -- hmm
Con c -> ParamConstant (Param (gId c) [])
Sort k -> VarValue (gId k)
EInt n -> LiteralValue (IntConstant n)
Q (m,n) -> if m==cPredef then ppPredef n else VarValue ((gQId m n))
QC (m,n) -> ParamConstant (Param ((gQId m n)) [])
K s -> LiteralValue (StrConstant s)
Empty -> LiteralValue (StrConstant "")
FV ts -> VariantValue (map ppT ts)
Alts t' vs -> alts vs (ppT t')
_ -> error $ "convert' "++show t
ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t)
ppPredef n =
case predef n of
Ok BIND -> p "BIND"
Ok SOFT_BIND -> p "SOFT_BIND"
Ok SOFT_SPACE -> p "SOFT_SPACE"
Ok CAPIT -> p "CAPIT"
Ok ALL_CAPIT -> p "ALL_CAPIT"
_ -> VarValue (gQId cPredef n) -- hmm
where
p = PredefValue . PredefId
ppP p =
case p of
PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
PP (m,c) ps -> ParamPattern (Param ((gQId m c)) (map ppP ps))
PR r -> RecordPattern (fields r) {-
PW -> WildPattern
PV x -> VarP x
PString s -> Lit (show s) -- !!
PInt i -> Lit (show i)
PFloat x -> Lit (show x)
PT _ p -> ppP p
PAs x p -> AsP x (ppP p) -}
where
fields = map field . filter (not.isLockLabel.fst)
field (l,p) = RecordRow (lblId l) (ppP p)
-- patToParam p = case ppP p of ParamPattern pv -> pv
-- token s = single (c "TK" `Ap` lit s)
alts vs = PreValue (map alt vs)
where
alt (t,p) = (pre p,ppT0 t)
pre (K s) = [s]
pre Empty = [""] -- Empty == K ""
pre (Strs ts) = concatMap pre ts
pre (EPatt p) = pat p
pre t = error $ "pre "++show t
pat (PString s) = [s]
pat (PAlt p1 p2) = pat p1++pat p2
pat (PSeq p1 p2) = [s1++s2 | s1<-pat p1, s2<-pat p2]
pat p = error $ "pat "++show p
fields = map field . filter (not.isLockLabel.fst)
field (l,(_,t)) = RecordRow (lblId l) (ppT t)
--c = Const
--c = VarValue . VarValueId
--lit s = c (show s) -- hmm
ap f a = case f of
ParamConstant (Param p ps) ->
ParamConstant (Param p (ps++[a]))
_ -> error $ "convert' ap: "++render (ppA f <+> ppA a)
concatValue v1 v2 =
case (v1,v2) of
(LiteralValue (StrConstant ""),_) -> v2
(_,LiteralValue (StrConstant "")) -> v1
_ -> ConcatValue v1 v2
-- | Smart constructor for projections
projection r l = maybe (Projection r l) id (proj r l)
proj r l =
case r of
RecordValue r -> case [v|RecordRow l' v<-r,l'==l] of
[v] -> Just v
_ -> Nothing
_ -> Nothing
-- | Smart constructor for selections
selection t v =
-- Note: impossible cases can become possible after grammar transformation
case t of
TableValue tt r ->
case nub [rv|TableRow _ rv<-keep] of
[rv] -> rv
_ -> Selection (TableValue tt r') v
where
-- Don't introduce wildcard patterns, true to the canonical format,
-- annotate (or eliminate) rhs in impossible rows
r' = map trunc r
trunc r@(TableRow p e) = if mightMatchRow v r
then r
else TableRow p (impossible e)
{-
-- Creates smaller tables, but introduces wildcard patterns
r' = if null discard
then r
else keep++[TableRow WildPattern impossible]
-}
(keep,discard) = partition (mightMatchRow v) r
_ -> Selection t v
impossible = CommentedValue "impossible"
mightMatchRow v (TableRow p _) =
case p of
WildPattern -> True
_ -> mightMatch v p
mightMatch v p =
case v of
ConcatValue _ _ -> False
ParamConstant (Param c1 pvs) ->
case p of
ParamPattern (Param c2 pps) -> c1==c2 && length pvs==length pps &&
and [mightMatch v p|(v,p)<-zip pvs pps]
_ -> False
RecordValue rv ->
case p of
RecordPattern rp ->
and [maybe False (flip mightMatch p) (proj v l) | RecordRow l p<-rp]
_ -> False
_ -> True
patVars p =
case p of
PV x -> [x]
PAs x p -> x:patVars p
_ -> collectPattOp patVars p
convType = ppT
where
ppT t =
case t of
Table ti tv -> TableType (ppT ti) (ppT tv)
RecType rt -> RecordType (convFields rt)
-- App tf ta -> TAp (ppT tf) (ppT ta)
-- FV [] -> tcon0 (identS "({-empty variant-})")
Sort k -> convSort k
-- EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal
FV (t:ts) -> ppT t -- !!
QC (m,n) -> ParamType (ParamTypeId ((gQId m n)))
Q (m,n) -> ParamType (ParamTypeId ((gQId m n)))
_ -> error $ "Missing case in convType for: "++show t
convFields = map convField . filter (not.isLockLabel.fst)
convField (l,r) = RecordRow (lblId l) (ppT r)
convSort k = case showIdent k of
"Float" -> FloatType
"Int" -> IntType
"Str" -> StrType
_ -> error ("convSort "++show k)
toParamType t = case convType t of
ParamType pt -> pt
_ -> error ("toParamType "++show t)
toParamId t = case toParamType t of
ParamTypeId p -> p
paramType gr q@(_,n) =
case lookupOrigInfo gr q of
Ok (m,ResParam (Just (L _ ps)) _)
{- - | m/=cPredef && m/=moduleNameS "Prelude"-} ->
((S.singleton (m,n),argTypes ps),
[ParamDef name (map (param m) ps)]
)
where name = (gQId m n)
Ok (m,ResOper _ (Just (L _ t)))
| m==cPredef && n==cInts ->
((S.empty,S.empty),[]) {-
((S.singleton (m,n),S.empty),
[Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-}
| otherwise ->
((S.singleton (m,n),paramTypes gr t),
[ParamAliasDef ((gQId m n)) (convType t)])
_ -> ((S.empty,S.empty),[])
where
param m (n,ctx) = Param ((gQId m n)) [toParamId t|(_,_,t)<-ctx]
argTypes = S.unions . map argTypes1
argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
lblId = LabelId . render -- hmm
modId (MN m) = ModId (showIdent m)
class FromIdent i where gId :: Ident -> i
instance FromIdent VarId where
gId i = if isWildIdent i then Anonymous else VarId (showIdent i)
instance FromIdent C.FunId where gId = C.FunId . showIdent
instance FromIdent CatId where gId = CatId . showIdent
instance FromIdent ParamId where gId = ParamId . unqual
instance FromIdent VarValueId where gId = VarValueId . unqual
class FromIdent i => QualIdent i where gQId :: ModuleName -> Ident -> i
instance QualIdent ParamId where gQId m n = ParamId (qual m n)
instance QualIdent VarValueId where gQId m n = VarValueId (qual m n)
qual m n = Qual (modId m) (showIdent n)
unqual n = Unqual (showIdent n)
convFlags gr mn =
Flags [(n,convLit v) |
(n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]
where
convLit l =
case l of
LStr s -> Str s
LInt i -> C.Int i
LFlt d -> Flt d

169
src/compiler/GF/Compile/GrammarToPGF.hs
View File

@@ -1,12 +1,12 @@
{-# LANGUAGE ImplicitParams, BangPatterns, FlexibleContexts #-}
{-# LANGUAGE ImplicitParams, BangPatterns, FlexibleContexts, MagicHash #-}
module GF.Compile.GrammarToPGF (grammar2PGF) where
import GF.Compile.GeneratePMCFG
import GF.Compile.GenerateBC
import GF.Compile.OptimizePGF
import PGF(CId,mkCId,Type,Hypo,Expr)
import PGF.Internal
import PGF2 hiding (mkType)
import PGF2.Internal
import GF.Grammar.Predef
import GF.Grammar.Grammar hiding (Production)
import qualified GF.Grammar.Lookup as Look
@@ -19,18 +19,22 @@ import GF.Infra.UseIO (IOE)
import GF.Data.Operations
import Data.List
import Data.Char
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import Data.Array.IArray
import Data.Maybe(fromMaybe)
grammar2PGF :: Options -> SourceGrammar -> ModuleName -> Map.Map CId Double -> IO PGF
import GHC.Prim
import GHC.Base(getTag)
grammar2PGF :: Options -> SourceGrammar -> ModuleName -> Map.Map PGF2.Fun Double -> IO PGF
grammar2PGF opts gr am probs = do
cnc_infos <- getConcreteInfos gr am
return $
build (let gflags = if flag optSplitPGF opts
then [(mkCId "split", LStr "true")]
then [("split", LStr "true")]
else []
(an,abs) = mkAbstr am probs
cncs = map (mkConcr opts abs) cnc_infos
@@ -39,21 +43,21 @@ grammar2PGF opts gr am probs = do
cenv = resourceValues opts gr
aflags = err (const noOptions) mflags (lookupModule gr am)
mkAbstr :: (?builder :: Builder s) => ModuleName -> Map.Map CId Double -> (CId, B s AbstrInfo)
mkAbstr :: (?builder :: Builder s) => ModuleName -> Map.Map PGF2.Fun Double -> (AbsName, B s AbstrInfo)
mkAbstr am probs = (mi2i am, newAbstr flags cats funs)
where
adefs =
[((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++
Look.allOrigInfos gr am
flags = [(mkCId f,x) | (f,x) <- optionsPGF aflags]
flags = optionsPGF aflags
toLogProb = realToFrac . negate . log
cats = [(c', snd (mkContext [] cont), toLogProb (fromMaybe 0 (Map.lookup c' probs))) |
((m,c),AbsCat (Just (L _ cont))) <- adefs, let c' = i2i c]
funs = [(f', mkType [] ty, arity, {-mkDef gr arity mdef,-} toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) |
funs = [(f', mkType [] ty, arity, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) |
((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs,
let arity = mkArity ma mdef ty,
let f' = i2i f]
@@ -72,7 +76,10 @@ grammar2PGF opts gr am probs = do
mkConcr opts abs (cm,ex_seqs,cdefs) =
let cflags = err (const noOptions) mflags (lookupModule gr cm)
flags = [(mkCId f,x) | (f,x) <- optionsPGF cflags]
ciCmp | flag optCaseSensitive cflags = compare
| otherwise = compareCaseInsensitive
flags = optionsPGF aflags
seqs = (mkSetArray . Set.fromList . concat) $
(elems (ex_seqs :: Array SeqId [Symbol]) : [maybe [] elems (mseqs mi) | (m,mi) <- allExtends gr cm])
@@ -80,11 +87,11 @@ grammar2PGF opts gr am probs = do
!(!fid_cnt1,!cnccats) = genCncCats gr am cm cdefs
cnccat_ranges = Map.fromList (map (\(cid,s,e,_) -> (cid,(s,e))) cnccats)
!(!fid_cnt2,!productions,!lindefs,!linrefs,!cncfuns)
= genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt1 cnccat_ranges
= genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt1 cnccat_ranges
printnames = genPrintNames cdefs
startCat = mkCId (fromMaybe "S" (flag optStartCat aflags))
startCat = (fromMaybe "S" (flag optStartCat aflags))
(lindefs',linrefs',productions',cncfuns',sequences',cnccats') =
(if flag optOptimizePGF opts then optimizePGF startCat else id)
@@ -118,16 +125,13 @@ grammar2PGF opts gr am probs = do
(seqs,infos) <- addMissingPMCFGs cm seqs is
return (seqs, ((m,id), info) : infos)
mkSetArray set = listArray (0,Set.size set-1) (Set.toList set)
mkMapArray map = array (0,Map.size map-1) [(k,v) | (v,k) <- Map.toList map]
i2i :: Ident -> String
i2i = showIdent
i2i :: Ident -> CId
i2i = mkCId . showIdent
mi2i :: ModuleName -> CId
mi2i :: ModuleName -> String
mi2i (MN i) = i2i i
mkType :: (?builder :: Builder s) => [Ident] -> A.Type -> B s PGF.Type
mkType :: (?builder :: Builder s) => [Ident] -> A.Type -> B s PGF2.Type
mkType scope t =
case GM.typeForm t of
(hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps
@@ -164,7 +168,7 @@ mkPatt scope p =
in (scope',C.PImplArg p')
A.PTilde t -> ( scope,C.PTilde (mkExp scope t))
-}
mkContext :: (?builder :: Builder s) => [Ident] -> A.Context -> ([Ident],[B s PGF.Hypo])
mkContext :: (?builder :: Builder s) => [Ident] -> A.Context -> ([Ident],[B s PGF2.Hypo])
mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
in if x == identW
then ( scope,hypo bt (i2i x) ty')
@@ -206,16 +210,17 @@ genCncFuns :: Grammar
-> ModuleName
-> ModuleName
-> Array SeqId [Symbol]
-> ([Symbol] -> [Symbol] -> Ordering)
-> Array SeqId [Symbol]
-> [(QIdent, Info)]
-> FId
-> Map.Map CId (Int,Int)
-> Map.Map PGF2.Cat (Int,Int)
-> (FId,
[(FId, [Production])],
[(FId, [FunId])],
[(FId, [FunId])],
[(CId,[SeqId])])
genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccat_ranges =
[(PGF2.Fun,[SeqId])])
genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccat_ranges =
let (fid_cnt1,funs_cnt1,funs1,lindefs,linrefs) = mkCncCats cdefs fid_cnt 0 [] IntMap.empty IntMap.empty
(fid_cnt2,funs_cnt2,funs2,prods0) = mkCncFuns cdefs fid_cnt1 funs_cnt1 funs1 lindefs Map.empty IntMap.empty
prods = [(fid,Set.toList prodSet) | (fid,prodSet) <- IntMap.toList prods0]
@@ -304,7 +309,7 @@ genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccat_ranges =
newIndex mseqs i = binSearch (mseqs ! i) seqs (bounds seqs)
binSearch v arr (i,j)
| i <= j = case compare v (arr ! k) of
| i <= j = case ciCmp v (arr ! k) of
LT -> binSearch v arr (i,k-1)
EQ -> k
GT -> binSearch v arr (k+1,j)
@@ -323,3 +328,121 @@ genPrintNames cdefs =
flatten (K s) = s
flatten (Alts x _) = flatten x
flatten (C x y) = flatten x +++ flatten y
mkArray lst = listArray (0,length lst-1) lst
mkMapArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
mkSetArray set = listArray (0,Set.size set-1) (Set.toList set)
-- The following is a version of Data.List.sortBy which together
-- with the sorting also eliminates duplicate values
sortNubBy cmp = mergeAll . sequences
where
sequences (a:b:xs) =
case cmp a b of
GT -> descending b [a] xs
EQ -> sequences (b:xs)
LT -> ascending b (a:) xs
sequences xs = [xs]
descending a as [] = [a:as]
descending a as (b:bs) =
case cmp a b of
GT -> descending b (a:as) bs
EQ -> descending a as bs
LT -> (a:as) : sequences (b:bs)
ascending a as [] = let !x = as [a]
in [x]
ascending a as (b:bs) =
case cmp a b of
GT -> let !x = as [a]
in x : sequences (b:bs)
EQ -> ascending a as bs
LT -> ascending b (\ys -> as (a:ys)) bs
mergeAll [x] = x
mergeAll xs = mergeAll (mergePairs xs)
mergePairs (a:b:xs) = let !x = merge a b
in x : mergePairs xs
mergePairs xs = xs
merge as@(a:as') bs@(b:bs') =
case cmp a b of
GT -> b:merge as bs'
EQ -> a:merge as' bs'
LT -> a:merge as' bs
merge [] bs = bs
merge as [] = as
-- The following function does case-insensitive comparison of sequences.
-- This is used to allow case-insensitive parsing, while
-- the linearizer still has access to the original cases.
compareCaseInsensitive [] [] = EQ
compareCaseInsensitive [] _ = LT
compareCaseInsensitive _ [] = GT
compareCaseInsensitive (x:xs) (y:ys) =
case compareSym x y of
EQ -> compareCaseInsensitive xs ys
x -> x
where
compareSym s1 s2 =
case s1 of
SymCat d1 r1
-> case s2 of
SymCat d2 r2
-> case compare d1 d2 of
EQ -> r1 `compare` r2
x -> x
_ -> LT
SymLit d1 r1
-> case s2 of
SymCat {} -> GT
SymLit d2 r2
-> case compare d1 d2 of
EQ -> r1 `compare` r2
x -> x
_ -> LT
SymVar d1 r1
-> if tagToEnum# (getTag s2 ># 2#)
then LT
else case s2 of
SymVar d2 r2
-> case compare d1 d2 of
EQ -> r1 `compare` r2
x -> x
_ -> GT
SymKS t1
-> if tagToEnum# (getTag s2 ># 3#)
then LT
else case s2 of
SymKS t2 -> t1 `compareToken` t2
_ -> GT
SymKP a1 b1
-> if tagToEnum# (getTag s2 ># 4#)
then LT
else case s2 of
SymKP a2 b2
-> case compare a1 a2 of
EQ -> b1 `compare` b2
x -> x
_ -> GT
_ -> let t1 = getTag s1
t2 = getTag s2
in if tagToEnum# (t1 <# t2)
then LT
else if tagToEnum# (t1 ==# t2)
then EQ
else GT
compareToken [] [] = EQ
compareToken [] _ = LT
compareToken _ [] = GT
compareToken (x:xs) (y:ys)
| x == y = compareToken xs ys
| otherwise = case compare (toLower x) (toLower y) of
EQ -> case compareToken xs ys of
EQ -> compare x y
x -> x
x -> x

88
src/compiler/GF/Compile/PGFtoJS.hs
View File

@@ -1,88 +0,0 @@
module GF.Compile.PGFtoJS (pgf2js) where
import PGF
import PGF.Internal
import qualified GF.JavaScript.AbsJS as JS
import qualified GF.JavaScript.PrintJS as JS
import Data.Map (Map)
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
pgf2js :: PGF -> String
pgf2js pgf =
JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]]
where
n = showCId $ abstractName pgf
start = showType [] $ startCat pgf
grammar = new "GFGrammar" [js_abstract, js_concrete]
js_abstract = abstract2js start pgf
js_concrete = JS.EObj $ map (concrete2js pgf) (languages pgf)
abstract2js :: String -> PGF -> JS.Expr
abstract2js start pgf = new "GFAbstract" [JS.EStr start, JS.EObj [absdef2js f ty | f <- functions pgf, Just ty <- [functionType pgf f]]]
absdef2js :: CId -> Type -> JS.Property
absdef2js f typ =
let (hypos,cat,_) = unType typ
args = [cat | (_,_,typ) <- hypos, let (hypos,cat,_) = unType typ]
in JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)])
lit2js (LStr s) = JS.EStr s
lit2js (LInt n) = JS.EInt n
lit2js (LFlt d) = JS.EDbl d
concrete2js :: PGF -> Language -> JS.Property
concrete2js pgf lang =
JS.Prop l (new "GFConcrete" [mapToJSObj (lit2js) $ concrFlags cnc,
JS.EObj [JS.Prop (JS.IntPropName cat) (JS.EArray (map frule2js (concrProductions cnc cat))) | cat <- [0..concrTotalCats cnc]],
JS.EArray [ffun2js (concrFunction cnc funid) | funid <- [0..concrTotalFuns cnc]],
JS.EArray [seq2js (concrSequence cnc seqid) | seqid <- [0..concrTotalSeqs cnc]],
JS.EObj $ map cats (concrCategories cnc),
JS.EInt (concrTotalCats cnc)])
where
cnc = lookConcr pgf lang
l = JS.IdentPropName (JS.Ident (showCId lang))
litslins = [JS.Prop (JS.StringPropName "Int") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
JS.Prop (JS.StringPropName "Float") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
JS.Prop (JS.StringPropName "String") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]])]
cats (c,start,end,_) = JS.Prop (JS.IdentPropName (JS.Ident (showCId c))) (JS.EObj [JS.Prop (JS.IdentPropName (JS.Ident "s")) (JS.EInt start)
,JS.Prop (JS.IdentPropName (JS.Ident "e")) (JS.EInt end)])
children :: JS.Ident
children = JS.Ident "cs"
frule2js :: Production -> JS.Expr
frule2js (PApply funid args) = new "Apply" [JS.EInt funid, JS.EArray (map farg2js args)]
frule2js (PCoerce arg) = new "Coerce" [JS.EInt arg]
farg2js (PArg hypos fid) = new "PArg" (map (JS.EInt . snd) hypos ++ [JS.EInt fid])
ffun2js (f,lins) = new "CncFun" [JS.EStr (showCId f), JS.EArray (map JS.EInt lins)]
seq2js :: [Symbol] -> JS.Expr
seq2js seq = JS.EArray [sym2js s | s <- seq]
sym2js :: Symbol -> JS.Expr
sym2js (SymCat n l) = new "SymCat" [JS.EInt n, JS.EInt l]
sym2js (SymLit n l) = new "SymLit" [JS.EInt n, JS.EInt l]
sym2js (SymVar n l) = new "SymVar" [JS.EInt n, JS.EInt l]
sym2js (SymKS t) = new "SymKS" [JS.EStr t]
sym2js (SymKP ts alts) = new "SymKP" [JS.EArray (map sym2js ts), JS.EArray (map alt2js alts)]
sym2js SymBIND = new "SymKS" [JS.EStr "&+"]
sym2js SymSOFT_BIND = new "SymKS" [JS.EStr "&+"]
sym2js SymSOFT_SPACE = new "SymKS" [JS.EStr "&+"]
sym2js SymCAPIT = new "SymKS" [JS.EStr "&|"]
sym2js SymALL_CAPIT = new "SymKS" [JS.EStr "&|"]
sym2js SymNE = new "SymNE" []
alt2js (ps,ts) = new "Alt" [JS.EArray (map sym2js ps), JS.EArray (map JS.EStr ts)]
new :: String -> [JS.Expr] -> JS.Expr
new f xs = JS.ENew (JS.Ident f) xs
mapToJSObj :: (a -> JS.Expr) -> Map CId a -> JS.Expr
mapToJSObj f m = JS.EObj [ JS.Prop (JS.IdentPropName (JS.Ident (showCId k))) (f v) | (k,v) <- Map.toList m ]

156
src/compiler/GF/Compile/PGFtoJSON.hs Normal file
View File

@@ -0,0 +1,156 @@
module GF.Compile.PGFtoJSON (pgf2json) where
import PGF (showCId)
import qualified PGF.Internal as M
import PGF.Internal (
Abstr,
CId,
CncCat(..),
CncFun(..),
Concr,
DotPos,
Equation(..),
Literal(..),
PArg(..),
PGF,
Production(..),
Symbol(..),
Type,
absname,
abstract,
cflags,
cnccats,
cncfuns,
concretes,
funs,
productions,
sequences,
totalCats
)
import qualified Text.JSON as JSON
import Text.JSON (JSValue(..))
import qualified Data.Array.IArray as Array
import Data.Map (Map)
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
pgf2json :: PGF -> String
pgf2json pgf =
JSON.encode $ JSON.makeObj
[ ("abstract", json_abstract)
, ("concretes", json_concretes)
]
where
n = showCId $ absname pgf
as = abstract pgf
cs = Map.assocs (concretes pgf)
start = showCId $ M.lookStartCat pgf
json_abstract = abstract2json n start as
json_concretes = JSON.makeObj $ map concrete2json cs
abstract2json :: String -> String -> Abstr -> JSValue
abstract2json name start ds =
JSON.makeObj
[ ("name", mkJSStr name)
, ("startcat", mkJSStr start)
, ("funs", JSON.makeObj $ map absdef2json (Map.assocs (funs ds)))
]
absdef2json :: (CId,(Type,Int,Maybe ([Equation],[[M.Instr]]),Double)) -> (String,JSValue)
absdef2json (f,(typ,_,_,_)) = (showCId f,sig)
where
(args,cat) = M.catSkeleton typ
sig = JSON.makeObj
[ ("args", JSArray $ map (mkJSStr.showCId) args)
, ("cat", mkJSStr $ showCId cat)
]
lit2json :: Literal -> JSValue
lit2json (LStr s) = mkJSStr s
lit2json (LInt n) = mkJSInt n
lit2json (LFlt d) = JSRational True (toRational d)
concrete2json :: (CId,Concr) -> (String,JSValue)
concrete2json (c,cnc) = (showCId c,obj)
where
obj = JSON.makeObj
[ ("flags", JSON.makeObj [ (showCId k, lit2json v) | (k,v) <- Map.toList (cflags cnc) ])
, ("productions", JSON.makeObj [ (show cat, JSArray (map frule2json (Set.toList set))) | (cat,set) <- IntMap.toList (productions cnc)])
, ("functions", JSArray (map ffun2json (Array.elems (cncfuns cnc))))
, ("sequences", JSArray (map seq2json (Array.elems (sequences cnc))))
, ("categories", JSON.makeObj $ map cats2json (Map.assocs (cnccats cnc)))
, ("totalfids", mkJSInt (totalCats cnc))
]
cats2json :: (CId, CncCat) -> (String,JSValue)
cats2json (c,CncCat start end _) = (showCId c, ixs)
where
ixs = JSON.makeObj
[ ("start", mkJSInt start)
, ("end", mkJSInt end)
]
frule2json :: Production -> JSValue
frule2json (PApply fid args) =
JSON.makeObj
[ ("type", mkJSStr "Apply")
, ("fid", mkJSInt fid)
, ("args", JSArray (map farg2json args))
]
frule2json (PCoerce arg) =
JSON.makeObj
[ ("type", mkJSStr "Coerce")
, ("arg", mkJSInt arg)
]
farg2json :: PArg -> JSValue
farg2json (PArg hypos fid) =
JSON.makeObj
[ ("type", mkJSStr "PArg")
, ("hypos", JSArray $ map (mkJSInt . snd) hypos)
, ("fid", mkJSInt fid)
]
ffun2json :: CncFun -> JSValue
ffun2json (CncFun f lins) =
JSON.makeObj
[ ("name", mkJSStr $ showCId f)
, ("lins", JSArray (map mkJSInt (Array.elems lins)))
]
seq2json :: Array.Array DotPos Symbol -> JSValue
seq2json seq = JSArray [sym2json s | s <- Array.elems seq]
sym2json :: Symbol -> JSValue
sym2json (SymCat n l) = new "SymCat" [mkJSInt n, mkJSInt l]
sym2json (SymLit n l) = new "SymLit" [mkJSInt n, mkJSInt l]
sym2json (SymVar n l) = new "SymVar" [mkJSInt n, mkJSInt l]
sym2json (SymKS t) = new "SymKS" [mkJSStr t]
sym2json (SymKP ts alts) = new "SymKP" [JSArray (map sym2json ts), JSArray (map alt2json alts)]
sym2json SymBIND = new "SymKS" [mkJSStr "&+"]
sym2json SymSOFT_BIND = new "SymKS" [mkJSStr "&+"]
sym2json SymSOFT_SPACE = new "SymKS" [mkJSStr "&+"]
sym2json SymCAPIT = new "SymKS" [mkJSStr "&|"]
sym2json SymALL_CAPIT = new "SymKS" [mkJSStr "&|"]
sym2json SymNE = new "SymNE" []
alt2json :: ([Symbol],[String]) -> JSValue
alt2json (ps,ts) = new "Alt" [JSArray (map sym2json ps), JSArray (map mkJSStr ts)]
new :: String -> [JSValue] -> JSValue
new f xs =
JSON.makeObj
[ ("type", mkJSStr f)
, ("args", JSArray xs)
]
-- | Make JSON value from string
mkJSStr :: String -> JSValue
mkJSStr = JSString . JSON.toJSString
-- | Make JSON value from integer
mkJSInt :: Integral a => a -> JSValue
mkJSInt = JSRational False . toRational

186
src/compiler/GF/Compile/PGFtoProlog.hs
View File

@@ -1,186 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : PGFtoProlog
-- Maintainer : Peter Ljunglöf
--
-- exports a GF grammar into a Prolog module
-----------------------------------------------------------------------------
module GF.Compile.PGFtoProlog (grammar2prolog) where
import PGF
import PGF.Internal
import GF.Data.Operations
import qualified Data.Array.IArray as Array
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import Data.Char (isAlphaNum, isAscii, isAsciiLower, isAsciiUpper, ord)
import Data.List (isPrefixOf, mapAccumL)
grammar2prolog :: PGF -> String
grammar2prolog pgf
= ("%% This file was automatically generated by GF" +++++
":- style_check(-singleton)." +++++
plFacts wildCId "abstract" 1 "(?AbstractName)"
[[plp name]] ++++
plFacts wildCId "concrete" 2 "(?AbstractName, ?ConcreteName)"
[[plp name, plp cncname] |
cncname <- languages pgf] ++++
plFacts wildCId "flag" 2 "(?Flag, ?Value): global flags"
[[plp f, plp v] |
(f, v) <- Map.assocs (globalFlags pgf)] ++++
plAbstract name pgf ++++
unlines [plConcrete name (lookConcr pgf name) | name <- languages pgf]
)
where name = abstractName pgf
----------------------------------------------------------------------
-- abstract syntax
plAbstract :: CId -> PGF -> String
plAbstract name pgf
= (plHeader "Abstract syntax" ++++
plFacts name "flag" 2 "(?Flag, ?Value): flags for abstract syntax"
[[plp f, plp v] |
(f, v) <- Map.assocs (abstrFlags pgf)] ++++
plFacts name "cat" 2 "(?Type, ?[X:Type,...])"
[[plType cat, []] | cat <- categories pgf] ++++
plFacts name "fun" 3 "(?Fun, ?Type, ?[X:Type,...])"
[[plp fun, plType cat, plHypos hypos] |
fun <- functions pgf, Just typ <- [functionType pgf fun],
let (hypos,cat,_) = unType typ]
)
where plType cat = plTerm (plp cat) []
plHypos hypos = plList [plOper ":" (plp x) (plp ty) | (_, x, ty) <- hypos]
----------------------------------------------------------------------
-- concrete syntax
plConcrete :: CId -> Concr -> String
plConcrete name cnc
= (plHeader ("Concrete syntax: " ++ plp name) ++++
plFacts name "flag" 2 "(?Flag, ?Value): flags for concrete syntax"
[[plp f, plp v] |
(f, v) <- Map.assocs (concrFlags cnc)] ++++
plFacts name "prod" 3 "(?CncCat, ?CncFun, ?[CncCat])"
[[plCat cat, fun, plTerm "c" (map plCat args)] |
cat <- [0..concrTotalCats cnc-1],
(fun, args) <- map plProduction (concrProductions cnc cat)] ++++
plFacts name "cncfun" 3 "(?CncFun, ?[Seq,...], ?AbsFun)"
[[plFun funid, plTerm "s" (map plSeq lins), plp absfun] |
funid <- [0..concrTotalFuns cnc-1], let (absfun,lins) = concrFunction cnc funid] ++++
plFacts name "seq" 2 "(?Seq, ?[Term])"
[[plSeq seqid, plp (concrSequence cnc seqid)] |
seqid <- [0..concrTotalSeqs cnc-1]] ++++
plFacts name "cnccat" 2 "(?AbsCat, ?[CnCCat])"
[[plp cat, plList (map plCat [start..end])] |
(cat,start,end,_) <- concrCategories cnc]
)
where plProduction (PCoerce arg) = ("-", [arg])
plProduction (PApply funid args) = (plFun funid, [fid | PArg hypos fid <- args])
----------------------------------------------------------------------
-- prolog-printing pgf datatypes
instance PLPrint Type where
plp ty
| null hypos = result
| otherwise = plOper " -> " plHypos result
where (hypos,cat,_) = unType ty
result = plTerm (plp cat) []
plHypos = plList [plOper ":" (plp x) (plp ty) | (_,x,ty) <- hypos]
instance PLPrint CId where
plp cid | isLogicalVariable str || cid == wildCId = plVar str
| otherwise = plAtom str
where str = showCId cid
instance PLPrint Literal where
plp (LStr s) = plp s
plp (LInt n) = plp (show n)
plp (LFlt f) = plp (show f)
instance PLPrint Symbol where
plp (SymCat n l) = plOper ":" (show n) (show l)
plp (SymLit n l) = plTerm "lit" [show n, show l]
plp (SymVar n l) = plTerm "var" [show n, show l]
plp (SymKS t) = plAtom t
plp (SymKP ts alts) = plTerm "pre" [plList (map plp ts), plList (map plAlt alts)]
where plAlt (ps,ts) = plOper "/" (plList (map plp ps)) (plList (map plAtom ts))
class PLPrint a where
plp :: a -> String
plps :: [a] -> String
plps = plList . map plp
instance PLPrint Char where
plp c = plAtom [c]
plps s = plAtom s
instance PLPrint a => PLPrint [a] where
plp = plps
----------------------------------------------------------------------
-- other prolog-printing functions
plCat :: Int -> String
plCat n = plAtom ('c' : show n)
plFun :: Int -> String
plFun n = plAtom ('f' : show n)
plSeq :: Int -> String
plSeq n = plAtom ('s' : show n)
plHeader :: String -> String
plHeader hdr = "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n%% " ++ hdr ++ "\n"
plFacts :: CId -> String -> Int -> String -> [[String]] -> String
plFacts mod pred arity comment facts = "%% " ++ pred ++ comment ++++ clauses
where clauses = (if facts == [] then ":- dynamic " ++ pred ++ "/" ++ show arity ++ ".\n"
else unlines [mod' ++ plTerm pred args ++ "." | args <- facts])
mod' = if mod == wildCId then "" else plp mod ++ ": "
plTerm :: String -> [String] -> String
plTerm fun args = plAtom fun ++ prParenth (prTList ", " args)
plList :: [String] -> String
plList xs = prBracket (prTList "," xs)
plOper :: String -> String -> String -> String
plOper op a b = prParenth (a ++ op ++ b)
plVar :: String -> String
plVar = varPrefix . concatMap changeNonAlphaNum
where varPrefix var@(c:_) | isAsciiUpper c || c=='_' = var
| otherwise = "_" ++ var
changeNonAlphaNum c | isAlphaNumUnderscore c = [c]
| otherwise = "_" ++ show (ord c) ++ "_"
plAtom :: String -> String
plAtom "" = "''"
plAtom atom@(c:cs) | isAsciiLower c && all isAlphaNumUnderscore cs
|| c == '\'' && cs /= "" && last cs == '\'' = atom
| otherwise = "'" ++ changeQuote atom ++ "'"
where changeQuote ('\'':cs) = '\\' : '\'' : changeQuote cs
changeQuote ('\\':cs) = '\\' : '\\' : changeQuote cs
changeQuote (c:cs) = c : changeQuote cs
changeQuote "" = ""
isAlphaNumUnderscore :: Char -> Bool
isAlphaNumUnderscore c = (isAscii c && isAlphaNum c) || c == '_'
----------------------------------------------------------------------
-- prolog variables
createLogicalVariable :: Int -> CId
createLogicalVariable n = mkCId (logicalVariablePrefix ++ show n)
isLogicalVariable :: String -> Bool
isLogicalVariable = isPrefixOf logicalVariablePrefix
logicalVariablePrefix :: String
logicalVariablePrefix = "X"

114
src/compiler/GF/Compile/PGFtoPython.hs
View File

@@ -1,114 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : PGFtoPython
-- Maintainer : Peter Ljunglöf
--
-- exports a GF grammar into a Python module
-----------------------------------------------------------------------------
{-# LANGUAGE FlexibleContexts #-}
module GF.Compile.PGFtoPython (pgf2python) where
import PGF
import PGF.Internal
import qualified Data.Map as Map
import GF.Data.Operations
pgf2python :: PGF -> String
pgf2python pgf = ("# -*- coding: utf-8 -*-" ++++
"# This file was automatically generated by GF" +++++
showCId name +++ "=" +++
pyDict 1 pyStr id [
("flags", pyDict 2 pyCId pyLiteral (Map.assocs (globalFlags pgf))),
("abstract", pyDict 2 pyStr id [
("name", pyCId name),
("start", pyCId start),
("flags", pyDict 3 pyCId pyLiteral (Map.assocs (abstrFlags pgf))),
("funs", pyDict 3 pyCId pyAbsdef [(f,ty) | f <- functions pgf, Just ty <- [functionType pgf f]])
]),
("concretes", pyDict 2 pyCId pyConcrete [(lang,lookConcr pgf lang) | lang <- languages pgf])
] ++ "\n")
where
name = abstractName pgf
(_,start,_) = unType (startCat pgf)
-- cncs = concretes pgf
pyAbsdef :: Type -> String
pyAbsdef typ = pyTuple 0 id [pyCId cat, pyList 0 pyCId args]
where (hypos,cat,_) = unType typ
args = [cat | (_,_,typ) <- hypos, let (_,cat,_) = unType typ]
pyLiteral :: Literal -> String
pyLiteral (LStr s) = pyStr s
pyLiteral (LInt n) = show n
pyLiteral (LFlt d) = show d
pyConcrete :: Concr -> String
pyConcrete cnc = pyDict 3 pyStr id [
("flags", pyDict 0 pyCId pyLiteral (Map.assocs (concrFlags cnc))),
("productions", pyDict 4 pyCat pyProds [(fid,concrProductions cnc fid) | fid <- [0..concrTotalCats cnc-1]]),
("cncfuns", pyDict 4 pyFun pyCncFun [(funid,concrFunction cnc funid) | funid <- [0..concrTotalFuns cnc-1]]),
("sequences", pyDict 4 pySeq pySymbols [(seqid,concrSequence cnc seqid) | seqid <- [0..concrTotalSeqs cnc-1]]),
("cnccats", pyDict 4 pyCId pyCncCat [(cat,(s,e,lbls)) | (cat,s,e,lbls) <- concrCategories cnc]),
("size", show (concrTotalCats cnc))
]
where pyProds prods = pyList 5 pyProduction prods
pyCncCat (start,end,_) = pyList 0 pyCat [start..end]
pyCncFun (f,lins) = pyTuple 0 id [pyList 0 pySeq lins, pyCId f]
pySymbols syms = pyList 0 pySymbol syms
pyProduction :: Production -> String
pyProduction (PCoerce arg) = pyTuple 0 id [pyStr "", pyList 0 pyCat [arg]]
pyProduction (PApply funid args) = pyTuple 0 id [pyFun funid, pyList 0 pyPArg args]
where pyPArg (PArg [] fid) = pyCat fid
pyPArg (PArg hypos fid) = pyTuple 0 pyCat (fid : map snd hypos)
pySymbol :: Symbol -> String
pySymbol (SymCat n l) = pyTuple 0 show [n, l]
pySymbol (SymLit n l) = pyDict 0 pyStr id [("lit", pyTuple 0 show [n, l])]
pySymbol (SymVar n l) = pyDict 0 pyStr id [("var", pyTuple 0 show [n, l])]
pySymbol (SymKS t) = pyStr t
pySymbol (SymKP ts alts) = pyDict 0 pyStr id [("pre", pyList 0 pySymbol ts), ("alts", pyList 0 alt2py alts)]
where alt2py (ps,ts) = pyTuple 0 (pyList 0 pyStr) [map pySymbol ps, ts]
pySymbol SymBIND = pyStr "&+"
pySymbol SymSOFT_BIND = pyStr "&+"
pySymbol SymSOFT_SPACE = pyStr "&+"
pySymbol SymCAPIT = pyStr "&|"
pySymbol SymALL_CAPIT = pyStr "&|"
pySymbol SymNE = pyDict 0 pyStr id [("nonExist", pyTuple 0 id [])]
----------------------------------------------------------------------
-- python helpers
pyDict :: Int -> (k -> String) -> (v -> String) -> [(k, v)] -> String
pyDict n pk pv [] = "{}"
pyDict n pk pv kvlist = prCurly (pyIndent n ++ prTList ("," ++ pyIndent n) (map pyKV kvlist) ++ pyIndent n)
where pyKV (k, v) = pk k ++ ":" ++ pv v
pyList :: Int -> (v -> String) -> [v] -> String
pyList n pv [] = "[]"
pyList n pv xs = prBracket (pyIndent n ++ prTList ("," ++ pyIndent n) (map pv xs) ++ pyIndent n)
pyTuple :: Int -> (v -> String) -> [v] -> String
pyTuple n pv [] = "()"
pyTuple n pv [x] = prParenth (pyIndent n ++ pv x ++ "," ++ pyIndent n)
pyTuple n pv xs = prParenth (pyIndent n ++ prTList ("," ++ pyIndent n) (map pv xs) ++ pyIndent n)
pyCat :: Int -> String
pyCat n = pyStr ('C' : show n)
pyFun :: Int -> String
pyFun n = pyStr ('F' : show n)
pySeq :: Int -> String
pySeq n = pyStr ('S' : show n)
pyStr :: String -> String
pyStr s = 'u' : prQuotedString s
pyCId :: CId -> String
pyCId = pyStr . showCId
pyIndent :: Int -> String
pyIndent n | n > 0 = "\n" ++ replicate n ' '
| otherwise = ""

11
src/compiler/GF/Compile/TypeCheck/RConcrete.hs
View File

@@ -359,12 +359,13 @@ getOverload gr g mt ot = case appForm ot of
nest 2 (showTypes pre)
return (mkApp fun tts, val)
([],[]) -> do
checkError $ "no overload instance of" <+> ppTerm Unqualified 0 f $$
"for" $$
checkError $ "no overload instance of" <+> ppTerm Qualified 0 f $$
maybe empty (\x -> "with value type" <+> ppType x) mt $$
"for argument list" $$
nest 2 stysError $$
"among" $$
nest 2 (vcat stypsError) $$
maybe empty (\x -> "with value type" <+> ppType x) mt
"among alternatives" $$
nest 2 (vcat stypsError)
(vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of
([(val,fun)],_) -> do

232
src/compiler/GF/Compile/pgf.schema.json Normal file
View File

@@ -0,0 +1,232 @@
{
"$schema": "http://json-schema.org/draft-07/schema#",
"$id": "http://grammaticalframework.org/pgf.schema.json",
"type": "object",
"title": "PGF JSON Schema",
"required": [
"abstract",
"concretes"
],
"properties": {
"abstract": {
"type": "object",
"required": [
"name",
"startcat",
"funs"
],
"properties": {
"name": {
"type": "string"
},
"startcat": {
"type": "string"
},
"funs": {
"type": "object",
"additionalProperties": {
"type": "object",
"required": [
"args",
"cat"
],
"properties": {
"args": {
"type": "array",
"items": {
"type": "string"
}
},
"cat": {
"type": "string"
}
}
}
}
}
},
"concretes": {
"type": "object",
"additionalProperties": {
"required": [
"flags",
"productions",
"functions",
"sequences",
"categories",
"totalfids"
],
"properties": {
"flags": {
"type": "object",
"additionalProperties": {
"type": ["string", "number"]
}
},
"productions": {
"type": "object",
"additionalProperties": {
"type": "array",
"items": {
"oneOf": [
{
"$ref": "#/definitions/apply"
},
{
"$ref": "#/definitions/coerce"
}
]
}
}
},
"functions": {
"type": "array",
"items": {
"title": "CncFun",
"type": "object",
"properties": {
"name": {
"type": "string"
},
"lins": {
"type": "array",
"items": {
"type": "integer"
}
}
}
}
},
"sequences": {
"type": "array",
"items": {
"type": "array",
"items": {
"$ref": "#/definitions/sym"
}
}
},
"categories": {
"type": "object",
"additionalProperties": {
"title": "CncCat",
"type": "object",
"required": [
"start",
"end"
],
"properties": {
"start": {
"type": "integer"
},
"end": {
"type": "integer"
}
}
}
},
"totalfids": {
"type": "integer"
}
}
}
}
},
"definitions": {
"apply": {
"required": [
"type",
"fid",
"args"
],
"properties": {
"type": {
"type": "string",
"enum": ["Apply"]
},
"fid": {
"type": "integer"
},
"args": {
"type": "array",
"items": {
"$ref": "#/definitions/parg"
}
}
}
},
"coerce": {
"required": [
"type",
"arg"
],
"properties": {
"type": {
"type": "string",
"enum": ["Coerce"]
},
"arg": {
"type": "integer"
}
}
},
"parg": {
"required": [
"type",
"hypos",
"fid"
],
"properties": {
"type": {
"type": "string",
"enum": ["PArg"]
},
"hypos": {
"type": "array",
"items": {
"type": "integer"
}
},
"fid": {
"type": "integer"
}
}
},
"sym": {
"title": "Sym",
"required": [
"type",
"args"
],
"properties": {
"type": {
"type": "string",
"enum": [
"SymCat",
"SymLit",
"SymVar",
"SymKS",
"SymKP",
"SymNE"
]
},
"args": {
"type": "array",
"items": {
"anyOf": [
{
"type": "string"
},
{
"type": "integer"
},
{
"$ref": "#/definitions/sym"
}
]
}
}
}
}
}
}