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

Merge branch 'master' into lpgf

Browse Source 
# Conflicts:
#	gf.cabal
#	src/compiler/GF/Grammar/Canonical.hs
This commit is contained in:
John J. Camilleri
2021-07-07 09:42:44 +02:00
parent 2be54ffb12 f2e52d6f2c
commit 045def61d8
33 changed files with 867 additions and 834 deletions
Download Patch File Download Diff File Expand all files Collapse all files

120
gf.cabal
View File

@@ -43,21 +43,21 @@ custom-setup
setup-depends:
base,
Cabal >=1.22.0.0,
directory,
filepath,
directory >= 1.3.0 && < 1.4,
filepath >= 1.4.1 && < 1.5,
process >=1.0.1.1
source-repository head
type: git
type: git
location: https://github.com/GrammaticalFramework/gf-core.git
flag interrupt
Description: Enable Ctrl+Break in the shell
Default: True
Default: True
flag server
Description: Include --server mode
Default: True
Default: True
flag network-uri
description: Get Network.URI from the network-uri package
@@ -69,13 +69,13 @@ flag network-uri
flag c-runtime
Description: Include functionality from the C run-time library (which must be installed already)
Default: False
Default: False
library
default-language: Haskell2010
default-language: Haskell2010
build-depends:
-- GHC 8.0.2 to GHC 8.10.4
base >= 4.9.1 && <4.15,
base >= 4.9.1 && < 4.15,
array >= 0.5.1 && < 0.6,
containers >= 0.5.7 && < 0.7,
bytestring >= 0.10.8 && < 0.11,
@@ -138,13 +138,17 @@ library
if flag(c-runtime)
exposed-modules: PGF2
other-modules: PGF2.FFI PGF2.Expr PGF2.Type
GF.Interactive2 GF.Command.Commands2
hs-source-dirs: src/runtime/haskell-bind
build-tools: hsc2hs
other-modules:
PGF2.FFI
PGF2.Expr
PGF2.Type
GF.Interactive2
GF.Command.Commands2
hs-source-dirs: src/runtime/haskell-bind
build-tools: hsc2hs
extra-libraries: pgf gu
c-sources: src/runtime/haskell-bind/utils.c
cc-options: -std=c99
c-sources: src/runtime/haskell-bind/utils.c
cc-options: -std=c99
---- GF compiler as a library:
@@ -166,12 +170,19 @@ library
GF.Grammar.Canonical
other-modules:
GF.Main GF.Compiler GF.Interactive
GF.Main
GF.Compiler
GF.Interactive
GF.Compile GF.CompileInParallel GF.CompileOne GF.Compile.GetGrammar
GF.Compile
GF.CompileInParallel
GF.CompileOne
GF.Compile.GetGrammar
GF.Grammar
GF.Data.Operations GF.Infra.Option GF.Infra.UseIO
GF.Data.Operations
GF.Infra.Option
GF.Infra.UseIO
GF.Command.Abstract
GF.Command.CommandInfo
@@ -283,12 +294,17 @@ library
cpp-options: -DC_RUNTIME
if flag(server)
build-depends: httpd-shed >= 0.4.0 && < 0.5, network>=2.3 && <2.7,
cgi >= 3001.3.0.2 && < 3001.6
build-depends:
httpd-shed >= 0.4.0 && < 0.5,
network>=2.3 && <2.7,
cgi >= 3001.3.0.2 && < 3001.6
if flag(network-uri)
build-depends: network-uri >= 2.6.1.0 && < 2.7, network>=2.6 && <2.7
build-depends:
network-uri >= 2.6.1.0 && < 2.7,
network>=2.6 && <2.7
else
build-depends: network >= 2.5 && <2.6
build-depends:
network >= 2.5 && <2.6
cpp-options: -DSERVER_MODE
other-modules:
@@ -305,7 +321,10 @@ library
Fold
ExampleDemo
ExampleService
hs-source-dirs: src/server src/server/transfer src/example-based
hs-source-dirs:
src/server
src/server/transfer
src/example-based
if flag(interrupt)
cpp-options: -DUSE_INTERRUPT
@@ -314,17 +333,24 @@ library
other-modules: GF.System.NoSignal
if impl(ghc>=7.8)
build-tools: happy>=1.19, alex>=3.1
build-tools:
happy>=1.19,
alex>=3.1
-- ghc-options: +RTS -A20M -RTS
else
build-tools: happy, alex>=3
build-tools:
happy,
alex>=3
ghc-options: -fno-warn-tabs
if os(windows)
build-depends: Win32 >= 2.3.1.1 && < 2.7
build-depends:
Win32 >= 2.3.1.1 && < 2.7
else
build-depends: unix >= 2.7.2 && < 2.8, terminfo >=0.4.0 && < 0.5
build-depends:
unix >= 2.7.2 && < 2.8,
terminfo >=0.4.0 && < 0.5
if impl(ghc>=8.2)
ghc-options: -fhide-source-paths
@@ -332,8 +358,10 @@ library
executable gf
hs-source-dirs: src/programs
main-is: gf-main.hs
default-language: Haskell2010
build-depends: gf, base
default-language: Haskell2010
build-depends:
gf,
base
ghc-options: -threaded
--ghc-options: -fwarn-unused-imports
@@ -347,23 +375,33 @@ executable gf
if impl(ghc>=8.2)
ghc-options: -fhide-source-paths
executable pgf-shell
--if !flag(c-runtime)
buildable: False
main-is: pgf-shell.hs
hs-source-dirs: src/runtime/haskell-bind/examples
build-depends: gf, base, containers, mtl, lifted-base
default-language: Haskell2010
if impl(ghc>=7.0)
ghc-options: -rtsopts
-- executable pgf-shell
-- --if !flag(c-runtime)
-- buildable: False
-- main-is: pgf-shell.hs
-- hs-source-dirs: src/runtime/haskell-bind/examples
-- build-depends:
-- gf,
-- base,
-- containers,
-- mtl,
-- lifted-base
-- default-language: Haskell2010
-- if impl(ghc>=7.0)
-- ghc-options: -rtsopts
test-suite gf-tests
type: exitcode-stdio-1.0
main-is: run.hs
type: exitcode-stdio-1.0
main-is: run.hs
hs-source-dirs: testsuite
build-depends: base>=4.3 && <5, Cabal>=1.8, directory, filepath, process
build-depends:
base >= 4.9.1 && < 4.15,
Cabal >= 1.8,
directory >= 1.3.0 && < 1.4,
filepath >= 1.4.1 && < 1.5,
process >= 1.4.3 && < 1.7
build-tool-depends: gf:gf
default-language: Haskell2010
default-language: Haskell2010
test-suite lpgf
type: exitcode-stdio-1.0

12
src/compiler/GF/Compile/CFGtoPGF.hs
View File

@@ -18,7 +18,7 @@ import Data.List
--------------------------
cf2pgf :: FilePath -> ParamCFG -> PGF
cf2pgf fpath cf =
cf2pgf fpath cf =
let pgf = PGF Map.empty aname (cf2abstr cf) (Map.singleton cname (cf2concr cf))
in updateProductionIndices pgf
where
@@ -33,7 +33,7 @@ cf2abstr cfg = Abstr aflags afuns acats
acats = Map.fromList [(cat, ([], [(0,mkRuleName rule) | rule <- rules], 0))
| (cat,rules) <- (Map.toList . Map.fromListWith (++))
[(cat2id cat, catRules cfg cat) |
[(cat2id cat, catRules cfg cat) |
cat <- allCats' cfg]]
afuns = Map.fromList [(mkRuleName rule, (cftype [cat2id c | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)), 0, Nothing, 0))
| rule <- allRules cfg]
@@ -52,7 +52,7 @@ cf2concr cfg = Concr Map.empty Map.empty
cats = allCats' cfg
rules = allRules cfg
sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] :
sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] :
map mkSequence rules)
sequences = listArray (0,Set.size sequences0-1) (Set.toList sequences0)
@@ -102,7 +102,7 @@ cf2concr cfg = Concr Map.empty Map.empty
mkLinDefRef (cat,_) =
(cat2fid cat 0,[0])
addProd prods (fid,prod) =
case IntMap.lookup fid prods of
Just set -> IntMap.insert fid (Set.insert prod set) prods
@@ -130,5 +130,5 @@ cf2concr cfg = Concr Map.empty Map.empty
mkRuleName rule =
case ruleName rule of
CFObj n _ -> n
_ -> wildCId
CFObj n _ -> n
_ -> wildCId

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

@@ -175,7 +175,7 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
checkTyp gr typ
case md of
Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $
checkDef gr (m,c) typ eq) eqs
checkDef gr (m,c) typ eq) eqs
Nothing -> return ()
return (AbsFun (Just (L loc typ)) ma md moper)
@@ -316,7 +316,7 @@ linTypeOfType cnc m typ = do
mkLinArg (i,(n,mc@(m,cat))) = do
val <- lookLin mc
let vars = mkRecType varLabel $ replicate n typeStr
symb = argIdent n cat i
symb = argIdent n cat i
rec <- if n==0 then return val else
errIn (render ("extending" $$
nest 2 vars $$

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

@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/30 18:39:44 $
-- > CVS $Date: 2005/05/30 18:39:44 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.19 $
--
@@ -23,9 +23,9 @@
-----------------------------------------------------------------------------
module GF.Compile.Rename (
renameSourceTerm,
renameModule
) where
renameSourceTerm,
renameModule
) where
import GF.Infra.Ident
import GF.Infra.CheckM
@@ -68,7 +68,7 @@ renameIdentTerm env = accumulateError (renameIdentTerm' env)
-- Fails immediately on error, makes it possible to try other possibilities
renameIdentTerm' :: Status -> Term -> Check Term
renameIdentTerm' env@(act,imps) t0 =
renameIdentTerm' env@(act,imps) t0 =
case t0 of
Vr c -> ident predefAbs c
Cn c -> ident (\_ s -> checkError s) c
@@ -85,8 +85,8 @@ renameIdentTerm' env@(act,imps) t0 =
_ -> return t0
where
opens = [st | (OSimple _,st) <- imps]
qualifs = [(m, st) | (OQualif m _, st) <- imps] ++
[(m, st) | (OQualif _ m, st) <- imps] ++
qualifs = [(m, st) | (OQualif m _, st) <- imps] ++
[(m, st) | (OQualif _ m, st) <- imps] ++
[(m, st) | (OSimple m, st) <- imps] -- qualif is always possible
-- this facility is mainly for BWC with GF1: you need not import PredefAbs
@@ -94,7 +94,7 @@ renameIdentTerm' env@(act,imps) t0 =
| isPredefCat c = return (Q (cPredefAbs,c))
| otherwise = checkError s
ident alt c =
ident alt c =
case Map.lookup c act of
Just f -> return (f c)
_ -> case mapMaybe (Map.lookup c) opens of
@@ -157,7 +157,7 @@ modInfo2status (o,mo) = (o,tree2status o (jments mo))
self2status :: ModuleName -> ModuleInfo -> StatusMap
self2status c m = Map.mapWithKey (info2status (Just c)) (jments m)
renameInfo :: FilePath -> Status -> Module -> Ident -> Info -> Check Info
renameInfo cwd status (m,mi) i info =
case info of
@@ -208,7 +208,7 @@ renameTerm env vars = ren vars where
Abs b x t -> liftM (Abs b x) (ren (x:vs) t)
Prod bt x a b -> liftM2 (Prod bt x) (ren vs a) (ren (x:vs) b)
Typed a b -> liftM2 Typed (ren vs a) (ren vs b)
Vr x
Vr x
| elem x vs -> return trm
| otherwise -> renid trm
Cn _ -> renid trm
@@ -219,7 +219,7 @@ renameTerm env vars = ren vars where
i' <- case i of
TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source
_ -> return i
liftM (T i') $ mapM (renCase vs) cs
liftM (T i') $ mapM (renCase vs) cs
Let (x,(m,a)) b -> do
m' <- case m of
@@ -229,7 +229,7 @@ renameTerm env vars = ren vars where
b' <- ren (x:vs) b
return $ Let (x,(m',a')) b'
P t@(Vr r) l -- Here we have $r.l$ and this is ambiguous it could be either
P t@(Vr r) l -- Here we have $r.l$ and this is ambiguous it could be either
-- record projection from variable or constant $r$ or qualified expression with module $r$
| elem r vs -> return trm -- try var proj first ..
| otherwise -> checks [ renid' (Q (MN r,label2ident l)) -- .. and qualified expression second.
@@ -331,7 +331,7 @@ renamePattern env patt =
renameContext :: Status -> Context -> Check Context
renameContext b = renc [] where
renc vs cont = case cont of
(bt,x,t) : xts
(bt,x,t) : xts
| isWildIdent x -> do
t' <- ren vs t
xts' <- renc vs xts

16
src/compiler/GF/Compile/TypeCheck/Abstract.hs
View File

@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/09/15 16:22:02 $
-- > CVS $Date: 2005/09/15 16:22:02 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.16 $
--
@@ -13,11 +13,11 @@
-----------------------------------------------------------------------------
module GF.Compile.TypeCheck.Abstract (-- * top-level type checking functions; TC should not be called directly.
checkContext,
checkTyp,
checkDef,
checkConstrs,
) where
checkContext,
checkTyp,
checkDef,
checkConstrs,
) where
import GF.Data.Operations
@@ -33,8 +33,8 @@ import GF.Text.Pretty
--import Control.Monad (foldM, liftM, liftM2)
-- | invariant way of creating TCEnv from context
initTCEnv gamma =
(length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma)
initTCEnv gamma =
(length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma)
-- interface to TC type checker

1
src/compiler/GF/Compile/TypeCheck/Concrete.hs
View File

@@ -69,7 +69,6 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
lockRecType c t' ---- locking to be removed AR 20/6/2009
_ | ty == typeTok -> return typeStr
_ | isPredefConstant ty -> return ty
_ -> composOp (comp g) ty

16
src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
View File

@@ -396,7 +396,7 @@ tcRecTypeFields ge scope ((l,ty):rs) mb_ty = do
return ((l,ty):rs,mb_ty)
-- | Invariant: if the third argument is (Just rho),
-- then rho is in weak-prenex form
-- then rho is in weak-prenex form
instSigma :: GlobalEnv -> Scope -> Term -> Sigma -> Maybe Rho -> TcM (Term, Rho)
instSigma ge scope t ty1 Nothing = return (t,ty1) -- INST1
instSigma ge scope t ty1 (Just ty2) = do -- INST2
@@ -631,8 +631,8 @@ allBinders = [ identS [x] | x <- ['a'..'z'] ] ++
type Scope = [(Ident,Value)]
type Sigma = Value
type Rho = Value -- No top-level ForAll
type Tau = Value -- No ForAlls anywhere
type Rho = Value -- No top-level ForAll
type Tau = Value -- No ForAlls anywhere
data MetaValue
= Unbound Scope Sigma
@@ -724,8 +724,8 @@ getMetaVars loc sc_tys = do
go (Vr tv) acc = acc
go (App x y) acc = go x (go y acc)
go (Meta i) acc
| i `elem` acc = acc
| otherwise = i : acc
| i `elem` acc = acc
| otherwise = i : acc
go (Q _) acc = acc
go (QC _) acc = acc
go (Sort _) acc = acc
@@ -742,9 +742,9 @@ getFreeVars loc sc_tys = do
return (foldr (go []) [] tys)
where
go bound (Vr tv) acc
| tv `elem` bound = acc
| tv `elem` acc = acc
| otherwise = tv : acc
| tv `elem` bound = acc
| tv `elem` acc = acc
| otherwise = tv : acc
go bound (App x y) acc = go bound x (go bound y acc)
go bound (Meta _) acc = acc
go bound (Q _) acc = acc

88
src/compiler/GF/Compile/TypeCheck/TC.hs
View File

@@ -5,21 +5,22 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/02 20:50:19 $
-- > CVS $Date: 2005/10/02 20:50:19 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.11 $
--
-- Thierry Coquand's type checking algorithm that creates a trace
-----------------------------------------------------------------------------
module GF.Compile.TypeCheck.TC (AExp(..),
Theory,
checkExp,
inferExp,
checkBranch,
eqVal,
whnf
) where
module GF.Compile.TypeCheck.TC (
AExp(..),
Theory,
checkExp,
inferExp,
checkBranch,
eqVal,
whnf
) where
import GF.Data.Operations
import GF.Grammar
@@ -31,17 +32,17 @@ import Data.Maybe
import GF.Text.Pretty
data AExp =
AVr Ident Val
AVr Ident Val
| ACn QIdent Val
| AType
| AInt Int
| AType
| AInt Int
| AFloat Double
| AStr String
| AMeta MetaId Val
| ALet (Ident,(Val,AExp)) AExp
| AApp AExp AExp Val
| AAbs Ident Val AExp
| AProd Ident AExp AExp
| AApp AExp AExp Val
| AAbs Ident Val AExp
| AProd Ident AExp AExp
-- -- | AEqs [([Exp],AExp)] --- not used
| ARecType [ALabelling]
| AR [AAssign]
@@ -50,7 +51,7 @@ data AExp =
| AData Val
deriving (Eq,Show)
type ALabelling = (Label, AExp)
type ALabelling = (Label, AExp)
type AAssign = (Label, (Val, AExp))
type Theory = QIdent -> Err Val
@@ -71,7 +72,7 @@ whnf :: Val -> Err Val
whnf v = ---- errIn ("whnf" +++ prt v) $ ---- debug
case v of
VApp u w -> do
u' <- whnf u
u' <- whnf u
w' <- whnf w
app u' w'
VClos env e -> eval env e
@@ -81,9 +82,9 @@ app :: Val -> Val -> Err Val
app u v = case u of
VClos env (Abs _ x e) -> eval ((x,v):env) e
_ -> return $ VApp u v
eval :: Env -> Term -> Err Val
eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
case e of
Vr x -> lookupVar env x
Q c -> return $ VCn c
@@ -95,23 +96,23 @@ eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
_ -> return $ VClos env e
eqVal :: Int -> Val -> Val -> Err [(Val,Val)]
eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $
eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $
do
w1 <- whnf u1
w2 <- whnf u2
w2 <- whnf u2
let v = VGen k
case (w1,w2) of
(VApp f1 a1, VApp f2 a2) -> liftM2 (++) (eqVal k f1 f2) (eqVal k a1 a2)
(VClos env1 (Abs _ x1 e1), VClos env2 (Abs _ x2 e2)) ->
eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2)
(VClos env1 (Prod _ x1 a1 e1), VClos env2 (Prod _ x2 a2 e2)) ->
liftM2 (++)
liftM2 (++)
(eqVal k (VClos env1 a1) (VClos env2 a2))
(eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2))
(VGen i _, VGen j _) -> return [(w1,w2) | i /= j]
(VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j]
(VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j]
--- thus ignore qualifications; valid because inheritance cannot
--- be qualified. Simplifies annotation. AR 17/3/2005
--- be qualified. Simplifies annotation. AR 17/3/2005
_ -> return [(w1,w2) | w1 /= w2]
-- invariant: constraints are in whnf
@@ -127,10 +128,10 @@ checkExp th tenv@(k,rho,gamma) e ty = do
Abs _ x t -> case typ of
VClos env (Prod _ y a b) -> do
a' <- whnf $ VClos env a ---
(t',cs) <- checkExp th
(k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
return (AAbs x a' t', cs)
a' <- whnf $ VClos env a ---
(t',cs) <- checkExp th
(k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
return (AAbs x a' t', cs)
_ -> Bad (render ("function type expected for" <+> ppTerm Unqualified 0 e <+> "instead of" <+> ppValue Unqualified 0 typ))
Let (x, (mb_typ, e1)) e2 -> do
@@ -150,7 +151,7 @@ checkExp th tenv@(k,rho,gamma) e ty = do
(b',csb) <- checkType th (k+1, (x,v x):rho, (x,VClos rho a):gamma) b
return (AProd x a' b', csa ++ csb)
R xs ->
R xs ->
case typ of
VRecType ys -> do case [l | (l,_) <- ys, isNothing (lookup l xs)] of
[] -> return ()
@@ -174,7 +175,7 @@ checkInferExp th tenv@(k,_,_) e typ = do
(e',w,cs1) <- inferExp th tenv e
cs2 <- eqVal k w typ
return (e',cs1 ++ cs2)
inferExp :: Theory -> TCEnv -> Term -> Err (AExp, Val, [(Val,Val)])
inferExp th tenv@(k,rho,gamma) e = case e of
Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x
@@ -200,13 +201,13 @@ inferExp th tenv@(k,rho,gamma) e = case e of
(e2,val2,cs2) <- inferExp th (k,rho,(x,val1):gamma) e2
return (ALet (x,(val1,e1)) e2, val2, cs1++cs2)
App f t -> do
(f',w,csf) <- inferExp th tenv f
(f',w,csf) <- inferExp th tenv f
typ <- whnf w
case typ of
VClos env (Prod _ x a b) -> do
(a',csa) <- checkExp th tenv t (VClos env a)
b' <- whnf $ VClos ((x,VClos rho t):env) b
return $ (AApp f' a' b', b', csf ++ csa)
b' <- whnf $ VClos ((x,VClos rho t):env) b
return $ (AApp f' a' b', b', csf ++ csa)
_ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
_ -> Bad (render ("cannot infer type of expression" <+> ppTerm Unqualified 0 e))
@@ -232,9 +233,9 @@ checkAssign th tenv@(k,rho,gamma) typs (lbl,(Nothing,exp)) = do
return ((lbl,(val,aexp)),cs)
checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Term],AExp),[(Val,Val)])
checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
chB tenv' ps' ty
where
checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
chB tenv' ps' ty
where
(ps',_,rho2,k') = ps2ts k ps
tenv' = (k, rho2++rho, gamma) ---- k' ?
@@ -245,11 +246,11 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
typ <- whnf ty
case typ of
VClos env (Prod _ y a b) -> do
a' <- whnf $ VClos env a
a' <- whnf $ VClos env a
(p', sigma, binds, cs1) <- checkP tenv p y a'
let tenv' = (length binds, sigma ++ rho, binds ++ gamma)
((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b)
return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
_ -> Bad (render ("Product expected for definiens" <+> ppTerm Unqualified 0 t <+> "instead of" <+> ppValue Unqualified 0 typ))
[] -> do
(e,cs) <- checkExp th tenv t ty
@@ -259,15 +260,15 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
let sigma = [(x, VGen i x) | ((x,_),i) <- zip delta [k..]]
return (VClos sigma t, sigma, delta, cs)
ps2ts k = foldr p2t ([],0,[],k)
ps2ts k = foldr p2t ([],0,[],k)
p2t p (ps,i,g,k) = case p of
PW -> (Meta i : ps, i+1,g,k)
PW -> (Meta i : ps, i+1,g,k)
PV x -> (Vr x : ps, i, upd x k g,k+1)
PAs x p -> p2t p (ps,i,g,k)
PString s -> (K s : ps, i, g, k)
PInt n -> (EInt n : ps, i, g, k)
PFloat n -> (EFloat n : ps, i, g, k)
PP c xs -> (mkApp (Q c) xss : ps, j, g',k')
PP c xs -> (mkApp (Q c) xss : ps, j, g',k')
where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
PImplArg p -> p2t p (ps,i,g,k)
PTilde t -> (t : ps, i, g, k)
@@ -307,8 +308,8 @@ checkPatt th tenv exp val = do
case typ of
VClos env (Prod _ x a b) -> do
(a',_,csa) <- checkExpP tenv t (VClos env a)
b' <- whnf $ VClos ((x,VClos rho t):env) b
return $ (AApp f' a' b', b', csf ++ csa)
b' <- whnf $ VClos ((x,VClos rho t):env) b
return $ (AApp f' a' b', b', csf ++ csa)
_ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
_ -> Bad (render ("cannot typecheck pattern" <+> ppTerm Unqualified 0 exp))
@@ -321,4 +322,3 @@ mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)])
mkAnnot a ti = do
(v,cs) <- ti
return (a v, v, cs)

66
src/compiler/GF/Compile/Update.hs
View File

@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/30 18:39:44 $
-- > CVS $Date: 2005/05/30 18:39:44 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.8 $
--
@@ -34,14 +34,14 @@ buildAnyTree :: Fail.MonadFail m => ModuleName -> [(Ident,Info)] -> m (Map.Map I
buildAnyTree m = go Map.empty
where
go map [] = return map
go map ((c,j):is) = do
go map ((c,j):is) =
case Map.lookup c map of
Just i -> case unifyAnyInfo m i j of
Ok k -> go (Map.insert c k map) is
Bad _ -> fail $ render ("conflicting information in module"<+>m $$
nest 4 (ppJudgement Qualified (c,i)) $$
"and" $+$
nest 4 (ppJudgement Qualified (c,j)))
Ok k -> go (Map.insert c k map) is
Bad _ -> fail $ render ("conflicting information in module"<+>m $$
nest 4 (ppJudgement Qualified (c,i)) $$
"and" $+$
nest 4 (ppJudgement Qualified (c,j)))
Nothing -> go (Map.insert c j map) is
extendModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
@@ -51,14 +51,14 @@ extendModule cwd gr (name,m)
---- Should be replaced by real control. AR 4/2/2005
| mstatus m == MSIncomplete && isModCnc m = return (name,m)
| otherwise = checkInModule cwd m NoLoc empty $ do
m' <- foldM extOne m (mextend m)
m' <- foldM extOne m (mextend m)
return (name,m')
where
extOne mo (n,cond) = do
m0 <- lookupModule gr n
-- test that the module types match, and find out if the old is complete
unless (sameMType (mtype m) (mtype mo))
unless (sameMType (mtype m) (mtype mo))
(checkError ("illegal extension type to module" <+> name))
let isCompl = isCompleteModule m0
@@ -67,7 +67,7 @@ extendModule cwd gr (name,m)
js1 <- extendMod gr isCompl ((n,m0), isInherited cond) name (jments mo)
-- if incomplete, throw away extension information
return $
return $
if isCompl
then mo {jments = js1}
else mo {mextend= filter ((/=n) . fst) (mextend mo)
@@ -75,7 +75,7 @@ extendModule cwd gr (name,m)
,jments = js1
}
-- | rebuilding instance + interface, and "with" modules, prior to renaming.
-- | rebuilding instance + interface, and "with" modules, prior to renaming.
-- AR 24/10/2003
rebuildModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_)) =
@@ -88,8 +88,8 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
-- add the information given in interface into an instance module
Nothing -> do
unless (null is || mstatus mi == MSIncomplete)
(checkError ("module" <+> i <+>
unless (null is || mstatus mi == MSIncomplete)
(checkError ("module" <+> i <+>
"has open interfaces and must therefore be declared incomplete"))
case mt of
MTInstance (i0,mincl) -> do
@@ -113,7 +113,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
let stat' = if all (flip elem infs) is
then MSComplete
else MSIncomplete
unless (stat' == MSComplete || stat == MSIncomplete)
unless (stat' == MSComplete || stat == MSIncomplete)
(checkError ("module" <+> i <+> "remains incomplete"))
ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext
let ops1 = nub $
@@ -141,24 +141,24 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
extendMod :: Grammar ->
Bool -> (Module,Ident -> Bool) -> ModuleName ->
Map.Map Ident Info -> Check (Map.Map Ident Info)
extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi)
extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi)
where
try new (c,i0)
| not (cond c) = return new
| otherwise = case Map.lookup c new of
Just j -> case unifyAnyInfo name i j of
Ok k -> return $ Map.insert c k new
Bad _ -> do (base,j) <- case j of
AnyInd _ m -> lookupOrigInfo gr (m,c)
_ -> return (base,j)
(name,i) <- case i of
Ok k -> return $ Map.insert c k new
Bad _ -> do (base,j) <- case j of
AnyInd _ m -> lookupOrigInfo gr (m,c)
_ -> return (base,j)
(name,i) <- case i of
AnyInd _ m -> lookupOrigInfo gr (m,c)
_ -> return (name,i)
checkError ("cannot unify the information" $$
nest 4 (ppJudgement Qualified (c,i)) $$
"in module" <+> name <+> "with" $$
nest 4 (ppJudgement Qualified (c,j)) $$
"in module" <+> base)
checkError ("cannot unify the information" $$
nest 4 (ppJudgement Qualified (c,i)) $$
"in module" <+> name <+> "with" $$
nest 4 (ppJudgement Qualified (c,j)) $$
"in module" <+> base)
Nothing-> if isCompl
then return $ Map.insert c (indirInfo name i) new
else return $ Map.insert c i new
@@ -166,11 +166,11 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme
i = globalizeLoc (msrc mi) i0
indirInfo :: ModuleName -> Info -> Info
indirInfo n info = AnyInd b n' where
indirInfo n info = AnyInd b n' where
(b,n') = case info of
ResValue _ -> (True,n)
ResParam _ _ -> (True,n)
AbsFun _ _ Nothing _ -> (True,n)
AbsFun _ _ Nothing _ -> (True,n)
AnyInd b k -> (b,k)
_ -> (False,n) ---- canonical in Abs
@@ -194,24 +194,24 @@ globalizeLoc fpath i =
unifyAnyInfo :: ModuleName -> Info -> Info -> Err Info
unifyAnyInfo m i j = case (i,j) of
(AbsCat mc1, AbsCat mc2) ->
(AbsCat mc1, AbsCat mc2) ->
liftM AbsCat (unifyMaybeL mc1 mc2)
(AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) ->
(AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) ->
liftM4 AbsFun (unifyMaybeL mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) (unifyMaybe moper1 moper2) -- adding defs
(ResParam mt1 mv1, ResParam mt2 mv2) ->
liftM2 ResParam (unifyMaybeL mt1 mt2) (unifyMaybe mv1 mv2)
(ResValue (L l1 t1), ResValue (L l2 t2))
(ResValue (L l1 t1), ResValue (L l2 t2))
| t1==t2 -> return (ResValue (L l1 t1))
| otherwise -> fail ""
(_, ResOverload ms t) | elem m ms ->
return $ ResOverload ms t
(ResOper mt1 m1, ResOper mt2 m2) ->
(ResOper mt1 m1, ResOper mt2 m2) ->
liftM2 ResOper (unifyMaybeL mt1 mt2) (unifyMaybeL m1 m2)
(CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) ->
(CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) ->
liftM5 CncCat (unifyMaybeL mc1 mc2) (unifyMaybeL md1 md2) (unifyMaybeL mr1 mr2) (unifyMaybeL mp1 mp2) (unifyMaybe mpmcfg1 mpmcfg2)
(CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) ->
(CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) ->
liftM3 (CncFun m) (unifyMaybeL mt1 mt2) (unifyMaybeL md1 md2) (unifyMaybe mpmcfg1 mpmcfg2)
(AnyInd b1 m1, AnyInd b2 m2) -> do

26
src/compiler/GF/Data/BacktrackM.hs
View File

@@ -16,18 +16,18 @@
{-# LANGUAGE CPP #-}
module GF.Data.BacktrackM (
-- * the backtracking state monad
BacktrackM,
-- * monad specific utilities
member,
cut,
-- * running the monad
foldBM, runBM,
foldSolutions, solutions,
foldFinalStates, finalStates,
-- * reexport the 'MonadState' class
module Control.Monad.State.Class,
) where
BacktrackM,
-- * monad specific utilities
member,
cut,
-- * running the monad
foldBM, runBM,
foldSolutions, solutions,
foldFinalStates, finalStates,
-- * reexport the 'MonadState' class
module Control.Monad.State.Class,
) where
import Data.List
import Control.Applicative
@@ -70,7 +70,7 @@ instance Applicative (BacktrackM s) where
instance Monad (BacktrackM s) where
return a = BM (\c s b -> c a s b)
BM m >>= k = BM (\c s b -> m (\a s b -> unBM (k a) c s b) s b)
where unBM (BM m) = m
where unBM (BM m) = m
#if !(MIN_VERSION_base(4,13,0))
fail = Fail.fail

20
src/compiler/GF/Data/Graph.hs
View File

@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/10 16:43:44 $
-- > CVS $Date: 2005/11/10 16:43:44 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.2 $
--
@@ -34,7 +34,7 @@ import Data.Set (Set)
import qualified Data.Set as Set
data Graph n a b = Graph [n] ![Node n a] ![Edge n b]
deriving (Eq,Show)
deriving (Eq,Show)
type Node n a = (n,a)
type Edge n b = (n,n,b)
@@ -63,7 +63,7 @@ emap f (Graph c ns es) = Graph c ns [(x,y,f l) | (x,y,l) <- es]
-- | Add a node to the graph.
newNode :: a -- ^ Node label
-> Graph n a b
-> Graph n a b
-> (Graph n a b,n) -- ^ Node graph and name of new node
newNode l (Graph (c:cs) ns es) = (Graph cs ((c,l):ns) es, c)
@@ -83,7 +83,7 @@ newEdges es g = foldl' (flip newEdge) g es
-- lazy version:
-- newEdges es' (Graph c ns es) = Graph c ns (es'++es)
insertEdgeWith :: Eq n =>
insertEdgeWith :: Eq n =>
(b -> b -> b) -> Edge n b -> Graph n a b -> Graph n a b
insertEdgeWith f e@(x,y,l) (Graph c ns es) = Graph c ns (h es)
where h [] = [e]
@@ -97,7 +97,7 @@ removeNode n = removeNodes (Set.singleton n)
-- | Remove a set of nodes and all edges to and from those nodes.
removeNodes :: Ord n => Set n -> Graph n a b -> Graph n a b
removeNodes xs (Graph c ns es) = Graph c ns' es'
where
where
keepNode n = not (Set.member n xs)
ns' = [ x | x@(n,_) <- ns, keepNode n ]
es' = [ e | e@(f,t,_) <- es, keepNode f && keepNode t ]
@@ -105,7 +105,7 @@ removeNodes xs (Graph c ns es) = Graph c ns' es'
-- | Get a map of node names to info about each node.
nodeInfo :: Ord n => Graph n a b -> NodeInfo n a b
nodeInfo g = Map.fromList [ (n, (x, fn inc n, fn out n)) | (n,x) <- nodes g ]
where
where
inc = groupEdgesBy edgeTo g
out = groupEdgesBy edgeFrom g
fn m n = fromMaybe [] (Map.lookup n m)
@@ -148,16 +148,16 @@ reverseGraph :: Graph n a b -> Graph n a b
reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ]
-- | Add the nodes from the second graph to the first graph.
-- The nodes in the second graph will be renamed using the name
-- The nodes in the second graph will be renamed using the name
-- supply in the first graph.
-- This function is more efficient when the second graph
-- is smaller than the first.
mergeGraphs :: Ord m => Graph n a b -> Graph m a b
mergeGraphs :: Ord m => Graph n a b -> Graph m a b
-> (Graph n a b, m -> n) -- ^ The new graph and a function translating
-- the old names of nodes in the second graph
-- to names in the new graph.
mergeGraphs (Graph c ns1 es1) g2 = (Graph c' (ns2++ns1) (es2++es1), newName)
where
where
(xs,c') = splitAt (length (nodes g2)) c
newNames = Map.fromList (zip (map fst (nodes g2)) xs)
newName n = fromJust $ Map.lookup n newNames
@@ -170,7 +170,7 @@ renameNodes :: (n -> m) -- ^ renaming function
-> Graph n a b -> Graph m a b
renameNodes newName c (Graph _ ns es) = Graph c ns' es'
where ns' = map' (\ (n,x) -> (newName n,x)) ns
es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es
es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es
-- | A strict 'map'
map' :: (a -> b) -> [a] -> [b]

28
src/compiler/GF/Data/Graphviz.hs
View File

@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/09/15 18:10:44 $
-- > CVS $Date: 2005/09/15 18:10:44 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.2 $
--
@@ -13,14 +13,14 @@
-----------------------------------------------------------------------------
module GF.Data.Graphviz (
Graph(..), GraphType(..),
Node(..), Edge(..),
Attr,
addSubGraphs,
setName,
setAttr,
prGraphviz
) where
Graph(..), GraphType(..),
Node(..), Edge(..),
Attr,
addSubGraphs,
setName,
setAttr,
prGraphviz
) where
import Data.Char
@@ -70,14 +70,14 @@ prGraphviz g@(Graph t i _ _ _ _) =
graphtype t ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}\n"
prSubGraph :: Graph -> String
prSubGraph g@(Graph _ i _ _ _ _) =
prSubGraph g@(Graph _ i _ _ _ _) =
"subgraph" ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}"
prGraph :: Graph -> String
prGraph (Graph t id at ns es ss) =
prGraph (Graph t id at ns es ss) =
unlines $ map (++";") (map prAttr at
++ map prNode ns
++ map (prEdge t) es
++ map prNode ns
++ map (prEdge t) es
++ map prSubGraph ss)
graphtype :: GraphType -> String
@@ -96,7 +96,7 @@ edgeop Undirected = "--"
prAttrList :: [Attr] -> String
prAttrList [] = ""
prAttrList at = "[" ++ join "," (map prAttr at) ++ "]"
prAttrList at = "[" ++ join "," (map prAttr at) ++ "]"
prAttr :: Attr -> String
prAttr (n,v) = esc n ++ " = " ++ esc v

66
src/compiler/GF/Data/Operations.hs
View File

@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/11 16:12:41 $
-- > CVS $Date: 2005/11/11 16:12:41 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.22 $
--
@@ -15,34 +15,34 @@
-----------------------------------------------------------------------------
module GF.Data.Operations (
-- ** The Error monad
Err(..), err, maybeErr, testErr, fromErr, errIn,
lookupErr,
-- ** The Error monad
Err(..), err, maybeErr, testErr, fromErr, errIn,
lookupErr,
-- ** Error monad class
ErrorMonad(..), checks, --doUntil, allChecks, checkAgain,
liftErr,
-- ** Checking
checkUnique, unifyMaybeBy, unifyMaybe,
-- ** Error monad class
ErrorMonad(..), checks, --doUntil, allChecks, checkAgain,
liftErr,
-- ** Monadic operations on lists and pairs
mapPairsM, pairM,
-- ** Printing
indent, (+++), (++-), (++++), (+++-), (+++++),
prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly,
prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
numberedParagraphs, prConjList, prIfEmpty, wrapLines,
-- ** Checking
checkUnique, unifyMaybeBy, unifyMaybe,
-- ** Topological sorting
topoTest, topoTest2,
-- ** Monadic operations on lists and pairs
mapPairsM, pairM,
-- ** Misc
readIntArg,
iterFix, chunks,
) where
-- ** Printing
indent, (+++), (++-), (++++), (+++-), (+++++),
prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly,
prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
numberedParagraphs, prConjList, prIfEmpty, wrapLines,
-- ** Topological sorting
topoTest, topoTest2,
-- ** Misc
readIntArg,
iterFix, chunks,
) where
import Data.Char (isSpace, toUpper, isSpace, isDigit)
import Data.List (nub, partition, (\\))
@@ -107,7 +107,7 @@ indent i s = replicate i ' ' ++ s
(+++), (++-), (++++), (+++-), (+++++) :: String -> String -> String
a +++ b = a ++ " " ++ b
a ++- "" = a
a ++- "" = a
a ++- b = a +++ b
a ++++ b = a ++ "\n" ++ b
@@ -145,20 +145,20 @@ prCurly s = "{" ++ s ++ "}"
prBracket s = "[" ++ s ++ "]"
prArgList, prSemicList, prCurlyList :: [String] -> String
prArgList = prParenth . prTList ","
prArgList = prParenth . prTList ","
prSemicList = prTList " ; "
prCurlyList = prCurly . prSemicList
restoreEscapes :: String -> String
restoreEscapes s =
case s of
restoreEscapes s =
case s of
[] -> []
'"' : t -> '\\' : '"' : restoreEscapes t
'\\': t -> '\\' : '\\' : restoreEscapes t
c : t -> c : restoreEscapes t
numberedParagraphs :: [[String]] -> [String]
numberedParagraphs t = case t of
numberedParagraphs t = case t of
[] -> []
p:[] -> p
_ -> concat [(show n ++ ".") : s | (n,s) <- zip [1..] t]
@@ -204,12 +204,12 @@ topoTest2 g0 = maybe (Right cycles) Left (tsort g)
([],[]) -> Just []
([],_) -> Nothing
(ns,rest) -> (leaves:) `fmap` tsort [(n,es \\ leaves) | (n,es)<-rest]
where leaves = map fst ns
where leaves = map fst ns
-- | Fix point iterator (for computing e.g. transitive closures or reachability)
iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a]
iterFix more start = iter start start
iterFix more start = iter start start
where
iter old new = if (null new')
then old
@@ -241,7 +241,7 @@ liftErr e = err raise return e
{-
instance ErrorMonad (STM s) where
raise msg = STM (\s -> raise msg)
handle (STM f) g = STM (\s -> (f s)
handle (STM f) g = STM (\s -> (f s)
`handle` (\e -> let STM g' = (g e) in
g' s))

18
src/compiler/GF/Data/Relation.hs
View File

@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/26 17:13:13 $
-- > CVS $Date: 2005/10/26 17:13:13 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.1 $
--
@@ -83,7 +83,7 @@ transitiveClosure r = fix (Map.map growSet) r
where growSet ys = foldl Set.union ys (map (allRelated r) $ Set.toList ys)
reflexiveClosure_ :: Ord a => [a] -- ^ The set over which the relation is defined.
-> Rel a -> Rel a
-> Rel a -> Rel a
reflexiveClosure_ u r = relates [(x,x) | x <- u] r
-- | Uses 'domain'
@@ -104,7 +104,7 @@ reflexiveElements :: Ord a => Rel a -> Set a
reflexiveElements r = Set.fromList [ x | (x,ys) <- Map.toList r, x `Set.member` ys ]
-- | Keep the related pairs for which the predicate is true.
filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a
filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a
filterRel p = fst . purgeEmpty . Map.mapWithKey (Set.filter . p)
-- | Remove keys that map to no elements.
@@ -112,16 +112,16 @@ purgeEmpty :: Ord a => Rel a -> (Rel a, Set a)
purgeEmpty r = let (r',r'') = Map.partition (not . Set.null) r
in (r', Map.keysSet r'')
-- | Get the equivalence classes from an equivalence relation.
-- | Get the equivalence classes from an equivalence relation.
equivalenceClasses :: Ord a => Rel a -> [Set a]
equivalenceClasses r = equivalenceClasses_ (Map.keys r) r
where equivalenceClasses_ [] _ = []
equivalenceClasses_ (x:xs) r = ys:equivalenceClasses_ zs r
where ys = allRelated r x
zs = [x' | x' <- xs, not (x' `Set.member` ys)]
where ys = allRelated r x
zs = [x' | x' <- xs, not (x' `Set.member` ys)]
isTransitive :: Ord a => Rel a -> Bool
isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r,
isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r,
y <- Set.toList ys, z <- Set.toList (allRelated r y)]
isReflexive :: Ord a => Rel a -> Bool
@@ -181,7 +181,7 @@ remove x r = let (mss,r') = Map.updateLookupWithKey (\_ _ -> Nothing) x r
Nothing -> (r', Set.empty, Set.empty)
-- remove element from all incoming and outgoing sets
-- of other elements
Just (is,os) ->
Just (is,os) ->
let r'' = foldr (\i -> Map.adjust (\ (is',os') -> (is', Set.delete x os')) i) r' $ Set.toList is
r''' = foldr (\o -> Map.adjust (\ (is',os') -> (Set.delete x is', os')) o) r'' $ Set.toList os
in (r''', is, os)
@@ -190,4 +190,4 @@ incoming :: Ord a => a -> Rel' a -> Set a
incoming x r = maybe Set.empty fst $ Map.lookup x r
--outgoing :: Ord a => a -> Rel' a -> Set a
--outgoing x r = maybe Set.empty snd $ Map.lookup x r
--outgoing x r = maybe Set.empty snd $ Map.lookup x r

10
src/compiler/GF/Data/Utilities.hs
View File

@@ -4,7 +4,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/26 18:47:16 $
-- > CVS $Date: 2005/10/26 18:47:16 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.6 $
--
@@ -33,7 +33,7 @@ longerThan n = not . notLongerThan n
lookupList :: Eq a => a -> [(a, b)] -> [b]
lookupList a [] = []
lookupList a (p:ps) | a == fst p = snd p : lookupList a ps
| otherwise = lookupList a ps
| otherwise = lookupList a ps
split :: [a] -> ([a], [a])
split (x : y : as) = (x:xs, y:ys)
@@ -48,8 +48,8 @@ splitBy p (a : as) = if p a then (a:xs, ys) else (xs, a:ys)
foldMerge :: (a -> a -> a) -> a -> [a] -> a
foldMerge merge zero = fm
where fm [] = zero
fm [a] = a
fm abs = let (as, bs) = split abs in fm as `merge` fm bs
fm [a] = a
fm abs = let (as, bs) = split abs in fm as `merge` fm bs
select :: [a] -> [(a, [a])]
select [] = []
@@ -68,7 +68,7 @@ safeInit :: [a] -> [a]
safeInit [] = []
safeInit xs = init xs
-- | Sorts and then groups elements given an ordering of the
-- | Sorts and then groups elements given an ordering of the
-- elements.
sortGroupBy :: (a -> a -> Ordering) -> [a] -> [[a]]
sortGroupBy f = groupBy (compareEq f) . sortBy f

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

@@ -266,7 +266,6 @@ instance PPA LinPattern where
RecordPattern r -> block r
TuplePattern ps -> "<"<>punctuate "," ps<>">"
WildPattern -> pp "_"
_ -> parens p
instance RhsSeparator LinPattern where rhsSep _ = pp "="

2
src/compiler/GF/Grammar/Lexer.x
View File

@@ -267,7 +267,7 @@ type AlexInput2 = (AlexInput,AlexInput)
data ParseResult a
= POk AlexInput2 a
| PFailed Posn -- The position of the error
| PFailed Posn -- The position of the error
String -- The error message
newtype P a = P { unP :: AlexInput2 -> ParseResult a }

26
src/compiler/GF/Grammar/Lookup.hs
View File

@@ -6,7 +6,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/27 13:21:53 $
-- > CVS $Date: 2005/10/27 13:21:53 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.15 $
--
@@ -20,17 +20,17 @@ module GF.Grammar.Lookup (
lookupOrigInfo,
allOrigInfos,
lookupResDef, lookupResDefLoc,
lookupResType,
lookupResType,
lookupOverload,
lookupOverloadTypes,
lookupParamValues,
lookupParamValues,
allParamValues,
lookupAbsDef,
lookupLincat,
lookupAbsDef,
lookupLincat,
lookupFunType,
lookupCatContext,
allOpers, allOpersTo
) where
) where
import GF.Data.Operations
import GF.Infra.Ident
@@ -69,7 +69,7 @@ lookupResDef gr x = fmap unLoc (lookupResDefLoc gr x)
lookupResDefLoc gr (m,c)
| isPredefCat c = fmap noLoc (lock c defLinType)
| otherwise = look m c
where
where
look m c = do
info <- lookupQIdentInfo gr (m,c)
case info of
@@ -77,7 +77,7 @@ lookupResDefLoc gr (m,c)
ResOper _ Nothing -> return (noLoc (Q (m,c)))
CncCat (Just (L l ty)) _ _ _ _ -> fmap (L l) (lock c ty)
CncCat _ _ _ _ _ -> fmap noLoc (lock c defLinType)
CncFun (Just (cat,_,_)) (Just (L l tr)) _ _ -> fmap (L l) (unlock cat tr)
CncFun _ (Just ltr) _ _ -> return ltr
@@ -95,7 +95,7 @@ lookupResType gr (m,c) = do
-- used in reused concrete
CncCat _ _ _ _ _ -> return typeType
CncFun (Just (cat,cont,val)) _ _ _ -> do
val' <- lock cat val
val' <- lock cat val
return $ mkProd cont val' []
AnyInd _ n -> lookupResType gr (n,c)
ResParam _ _ -> return typePType
@@ -111,7 +111,7 @@ lookupOverloadTypes gr id@(m,c) = do
-- used in reused concrete
CncCat _ _ _ _ _ -> ret typeType
CncFun (Just (cat,cont,val)) _ _ _ -> do
val' <- lock cat val
val' <- lock cat val
ret $ mkProd cont val' []
ResParam _ _ -> ret typePType
ResValue (L _ t) -> ret t
@@ -130,8 +130,8 @@ lookupOverload gr (m,c) = do
case info of
ResOverload os tysts -> do
tss <- mapM (\x -> lookupOverload gr (x,c)) os
return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) |
(L _ ty,L _ tr) <- tysts] ++
return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) |
(L _ ty,L _ tr) <- tysts] ++
concat tss
AnyInd _ n -> lookupOverload gr (n,c)
@@ -216,7 +216,7 @@ lookupCatContext gr m c = do
-- notice that it only gives the modules that are reachable and the opers that are included
allOpers :: Grammar -> [(QIdent,Type,Location)]
allOpers gr =
allOpers gr =
[((m,op),typ,loc) |
(m,mi) <- maybe [] (allExtends gr) (greatestResource gr),
(op,info) <- Map.toList (jments mi),

33
src/compiler/GF/Grammar/PatternMatch.hs
View File

@@ -5,18 +5,19 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/12 12:38:29 $
-- > CVS $Date: 2005/10/12 12:38:29 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.7 $
--
-- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003
-----------------------------------------------------------------------------
module GF.Grammar.PatternMatch (matchPattern,
testOvershadow,
findMatch,
measurePatt
) where
module GF.Grammar.PatternMatch (
matchPattern,
testOvershadow,
findMatch,
measurePatt
) where
import GF.Data.Operations
import GF.Grammar.Grammar
@@ -30,7 +31,7 @@ import GF.Text.Pretty
--import Debug.Trace
matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution)
matchPattern pts term =
matchPattern pts term =
if not (isInConstantForm term)
then raise (render ("variables occur in" <+> pp term))
else do
@@ -61,15 +62,15 @@ testOvershadow pts vs = do
findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution)
findMatch cases terms = case cases of
[] -> raise (render ("no applicable case for" <+> hsep (punctuate ',' terms)))
(patts,_):_ | length patts /= length terms ->
raise (render ("wrong number of args for patterns :" <+> hsep patts <+>
(patts,_):_ | length patts /= length terms ->
raise (render ("wrong number of args for patterns :" <+> hsep patts <+>
"cannot take" <+> hsep terms))
(patts,val):cc -> case mapM tryMatch (zip patts terms) of
Ok substs -> return (val, concat substs)
_ -> findMatch cc terms
tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
tryMatch (p,t) = do
tryMatch (p,t) = do
t' <- termForm t
trym p t'
where
@@ -83,26 +84,26 @@ tryMatch (p,t) = do
(PString s, ([],K i,[])) | s==i -> return []
(PInt s, ([],EInt i,[])) | s==i -> return []
(PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
(PC p pp, ([], Con f, tt)) |
(PC p pp, ([], Con f, tt)) |
p `eqStrIdent` f && length pp == length tt ->
do matches <- mapM tryMatch (zip pp tt)
return (concat matches)
(PP (q,p) pp, ([], QC (r,f), tt)) |
(PP (q,p) pp, ([], QC (r,f), tt)) |
-- q `eqStrIdent` r && --- not for inherited AR 10/10/2005
p `eqStrIdent` f && length pp == length tt ->
do matches <- mapM tryMatch (zip pp tt)
return (concat matches)
---- hack for AppPredef bug
(PP (q,p) pp, ([], Q (r,f), tt)) |
-- q `eqStrIdent` r && ---
(PP (q,p) pp, ([], Q (r,f), tt)) |
-- q `eqStrIdent` r && ---
p `eqStrIdent` f && length pp == length tt ->
do matches <- mapM tryMatch (zip pp tt)
return (concat matches)
(PR r, ([],R r',[])) |
all (`elem` map fst r') (map fst r) ->
do matches <- mapM tryMatch
do matches <- mapM tryMatch
[(p,snd a) | (l,p) <- r, let Just a = lookup l r']
return (concat matches)
(PT _ p',_) -> trym p' t'
@@ -125,7 +126,7 @@ tryMatch (p,t) = do
(PMSeq mp1 mp2, ([],K s, [])) -> matchPMSeq mp1 mp2 s
(PRep p1, ([],K s, [])) -> checks [
trym (foldr (const (PSeq p1)) (PString "")
trym (foldr (const (PSeq p1)) (PString "")
[1..n]) t' | n <- [0 .. length s]
] >>
return []

729
src/compiler/GF/Grammar/Printer.hs
View File

@@ -1,365 +1,364 @@
----------------------------------------------------------------------
-- |
-- Module : GF.Grammar.Printer
-- Maintainer : Krasimir Angelov
-- Stability : (stable)
-- Portability : (portable)
--
-----------------------------------------------------------------------------
{-# LANGUAGE FlexibleContexts #-}
module GF.Grammar.Printer
( -- ** Pretty printing
TermPrintQual(..)
, ppModule
, ppJudgement
, ppParams
, ppTerm
, ppPatt
, ppValue
, ppConstrs
, ppQIdent
, ppMeta
, getAbs
) where
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
import GF.Infra.Ident
import GF.Infra.Option
import GF.Grammar.Values
import GF.Grammar.Grammar
import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq)
import GF.Text.Pretty
import Data.Maybe (isNothing)
import Data.List (intersperse)
import qualified Data.Map as Map
--import qualified Data.IntMap as IntMap
--import qualified Data.Set as Set
import qualified Data.Array.IArray as Array
data TermPrintQual
= Terse | Unqualified | Qualified | Internal
deriving Eq
instance Pretty Grammar where
pp = vcat . map (ppModule Qualified) . modules
ppModule :: TermPrintQual -> SourceModule -> Doc
ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
hdr $$
nest 2 (ppOptions opts $$
vcat (map (ppJudgement q) (Map.toList jments)) $$
maybe empty (ppSequences q) mseqs) $$
ftr
where
hdr = complModDoc <+> modTypeDoc <+> '=' <+>
hsep (intersperse (pp "**") $
filter (not . isEmpty) $ [ commaPunct ppExtends exts
, maybe empty ppWith with
, if null opens
then pp '{'
else "open" <+> commaPunct ppOpenSpec opens <+> "in" <+> '{'
])
ftr = '}'
complModDoc =
case mstat of
MSComplete -> empty
MSIncomplete -> pp "incomplete"
modTypeDoc =
case mtype of
MTAbstract -> "abstract" <+> mn
MTResource -> "resource" <+> mn
MTConcrete abs -> "concrete" <+> mn <+> "of" <+> abs
MTInterface -> "interface" <+> mn
MTInstance ie -> "instance" <+> mn <+> "of" <+> ppExtends ie
ppExtends (id,MIAll ) = pp id
ppExtends (id,MIOnly incs) = id <+> brackets (commaPunct pp incs)
ppExtends (id,MIExcept incs) = id <+> '-' <+> brackets (commaPunct pp incs)
ppWith (id,ext,opens) = ppExtends (id,ext) <+> "with" <+> commaPunct ppInstSpec opens
ppOptions opts =
"flags" $$
nest 2 (vcat [option <+> '=' <+> ppLit value <+> ';' | (option,value) <- optionsGFO opts])
ppJudgement q (id, AbsCat pcont ) =
"cat" <+> id <+>
(case pcont of
Just (L _ cont) -> hsep (map (ppDecl q) cont)
Nothing -> empty) <+> ';'
ppJudgement q (id, AbsFun ptype _ pexp poper) =
let kind | isNothing pexp = "data"
| poper == Just False = "oper"
| otherwise = "fun"
in
(case ptype of
Just (L _ typ) -> kind <+> id <+> ':' <+> ppTerm q 0 typ <+> ';'
Nothing -> empty) $$
(case pexp of
Just [] -> empty
Just eqs -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs]
Nothing -> empty)
ppJudgement q (id, ResParam pparams _) =
"param" <+> id <+>
(case pparams of
Just (L _ ps) -> '=' <+> ppParams q ps
_ -> empty) <+> ';'
ppJudgement q (id, ResValue pvalue) =
"-- param constructor" <+> id <+> ':' <+>
(case pvalue of
(L _ ty) -> ppTerm q 0 ty) <+> ';'
ppJudgement q (id, ResOper ptype pexp) =
"oper" <+> id <+>
(case ptype of {Just (L _ t) -> ':' <+> ppTerm q 0 t; Nothing -> empty} $$
case pexp of {Just (L _ e) -> '=' <+> ppTerm q 0 e; Nothing -> empty}) <+> ';'
ppJudgement q (id, ResOverload ids defs) =
"oper" <+> id <+> '=' <+>
("overload" <+> '{' $$
nest 2 (vcat [id <+> (':' <+> ppTerm q 0 ty $$ '=' <+> ppTerm q 0 e <+> ';') | (L _ ty,L _ e) <- defs]) $$
'}') <+> ';'
ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) =
(case pcat of
Just (L _ typ) -> "lincat" <+> id <+> '=' <+> ppTerm q 0 typ <+> ';'
Nothing -> empty) $$
(case pdef of
Just (L _ exp) -> "lindef" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
Nothing -> empty) $$
(case pref of
Just (L _ exp) -> "linref" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
Nothing -> empty) $$
(case pprn of
Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
Nothing -> empty) $$
(case (mpmcfg,q) of
(Just (PMCFG prods funs),Internal)
-> "pmcfg" <+> id <+> '=' <+> '{' $$
nest 2 (vcat (map ppProduction prods) $$
' ' $$
vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
(Array.assocs funs))) $$
'}'
_ -> empty)
ppJudgement q (id, CncFun ptype pdef pprn mpmcfg) =
(case pdef of
Just (L _ e) -> let (xs,e') = getAbs e
in "lin" <+> id <+> hsep (map ppBind xs) <+> '=' <+> ppTerm q 0 e' <+> ';'
Nothing -> empty) $$
(case pprn of
Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
Nothing -> empty) $$
(case (mpmcfg,q) of
(Just (PMCFG prods funs),Internal)
-> "pmcfg" <+> id <+> '=' <+> '{' $$
nest 2 (vcat (map ppProduction prods) $$
' ' $$
vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
(Array.assocs funs))) $$
'}'
_ -> empty)
ppJudgement q (id, AnyInd cann mid) =
case q of
Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
_ -> empty
instance Pretty Term where pp = ppTerm Unqualified 0
ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e)
in prec d 0 ('\\' <> commaPunct ppBind xs <+> "->" <+> ppTerm q 0 e')
ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of
([],_) -> "table" <+> '{' $$
nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
'}'
(vs,e) -> prec d 0 ("\\\\" <> commaPunct pp vs <+> "=>" <+> ppTerm q 0 e)
ppTerm q d (T (TTyped t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
'}'
ppTerm q d (T (TComp t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
'}'
ppTerm q d (T (TWild t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
'}'
ppTerm q d (Prod bt x a b)= if x == identW && bt == Explicit
then prec d 0 (ppTerm q 4 a <+> "->" <+> ppTerm q 0 b)
else prec d 0 (parens (ppBind (bt,x) <+> ':' <+> ppTerm q 0 a) <+> "->" <+> ppTerm q 0 b)
ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> "=>" <+> ppTerm q 0 vt)
ppTerm q d (Let l e) = let (ls,e') = getLet e
in prec d 0 ("let" <+> vcat (map (ppLocDef q) (l:ls)) $$ "in" <+> ppTerm q 0 e')
ppTerm q d (Example e s)=prec d 0 ("in" <+> ppTerm q 5 e <+> str s)
ppTerm q d (C e1 e2) =prec d 1 (hang (ppTerm q 2 e1) 2 ("++" <+> ppTerm q 1 e2))
ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> '+' <+> ppTerm q 2 e2)
ppTerm q d (S x y) = case x of
T annot xs -> let e = case annot of
TRaw -> y
TTyped t -> Typed y t
TComp t -> Typed y t
TWild t -> Typed y t
in "case" <+> ppTerm q 0 e <+>"of" <+> '{' $$
nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
'}'
_ -> prec d 3 (hang (ppTerm q 3 x) 2 ("!" <+> ppTerm q 4 y))
ppTerm q d (ExtR x y) = prec d 3 (ppTerm q 3 x <+> "**" <+> ppTerm q 4 y)
ppTerm q d (App x y) = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y)
ppTerm q d (V e es) = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))])
ppTerm q d (FV es) = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))))
ppTerm q d (AdHocOverload es) = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
ppTerm q d (Strs es) = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
ppTerm q d (EPatt p) = prec d 4 ('#' <+> ppPatt q 2 p)
ppTerm q d (EPattType t)=prec d 4 ("pattern" <+> ppTerm q 0 t)
ppTerm q d (P t l) = prec d 5 (ppTerm q 5 t <> '.' <> l)
ppTerm q d (Cn id) = pp id
ppTerm q d (Vr id) = pp id
ppTerm q d (Q id) = ppQIdent q id
ppTerm q d (QC id) = ppQIdent q id
ppTerm q d (Sort id) = pp id
ppTerm q d (K s) = str s
ppTerm q d (EInt n) = pp n
ppTerm q d (EFloat f) = pp f
ppTerm q d (Meta i) = ppMeta i
ppTerm q d (Empty) = pp "[]"
ppTerm q d (R []) = pp "<>" -- to distinguish from {} empty RecType
ppTerm q d (R xs) = braces (fsep (punctuate ';' [l <+>
fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty},
'=' <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))
ppTerm q d (RecType xs)
| q == Terse = case [cat | (l,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of
[cat] -> pp cat
_ -> doc
| otherwise = doc
where
doc = braces (fsep (punctuate ';' [l <+> ':' <+> ppTerm q 0 t | (l,t) <- xs]))
ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>'
ppTerm q d (ImplArg e) = braces (ppTerm q 0 e)
ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t)
ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t)
ppTerm q d (Error s) = prec d 4 ("Predef.error" <+> str s)
ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e
ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e
instance Pretty Patt where pp = ppPatt Unqualified 0
ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '|' <+> ppPatt q 1 p2)
ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
ppPatt q d (PMSeq (_,p1) (_,p2)) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
ppPatt q d (PC f ps) = if null ps
then pp f
else prec d 1 (f <+> hsep (map (ppPatt q 3) ps))
ppPatt q d (PP f ps) = if null ps
then ppQIdent q f
else prec d 1 (ppQIdent q f <+> hsep (map (ppPatt q 3) ps))
ppPatt q d (PRep p) = prec d 1 (ppPatt q 3 p <> '*')
ppPatt q d (PAs f p) = prec d 2 (f <> '@' <> ppPatt q 3 p)
ppPatt q d (PNeg p) = prec d 2 ('-' <> ppPatt q 3 p)
ppPatt q d (PChar) = pp '?'
ppPatt q d (PChars s) = brackets (str s)
ppPatt q d (PMacro id) = '#' <> id
ppPatt q d (PM id) = '#' <> ppQIdent q id
ppPatt q d PW = pp '_'
ppPatt q d (PV id) = pp id
ppPatt q d (PInt n) = pp n
ppPatt q d (PFloat f) = pp f
ppPatt q d (PString s) = str s
ppPatt q d (PR xs) = braces (hsep (punctuate ';' [l <+> '=' <+> ppPatt q 0 e | (l,e) <- xs]))
ppPatt q d (PImplArg p) = braces (ppPatt q 0 p)
ppPatt q d (PTilde t) = prec d 2 ('~' <> ppTerm q 6 t)
ppValue :: TermPrintQual -> Int -> Val -> Doc
ppValue q d (VGen i x) = x <> "{-" <> i <> "-}" ---- latter part for debugging
ppValue q d (VApp u v) = prec d 4 (ppValue q 4 u <+> ppValue q 5 v)
ppValue q d (VCn (_,c)) = pp c
ppValue q d (VClos env e) = case e of
Meta _ -> ppTerm q d e <> ppEnv env
_ -> ppTerm q d e ---- ++ prEnv env ---- for debugging
ppValue q d (VRecType xs) = braces (hsep (punctuate ',' [l <> '=' <> ppValue q 0 v | (l,v) <- xs]))
ppValue q d VType = pp "Type"
ppConstrs :: Constraints -> [Doc]
ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> "<>" <+> ppValue Unqualified 0 w))
ppEnv :: Env -> Doc
ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e)
str s = doubleQuotes s
ppDecl q (_,id,typ)
| id == identW = ppTerm q 3 typ
| otherwise = parens (id <+> ':' <+> ppTerm q 0 typ)
ppDDecl q (_,id,typ)
| id == identW = ppTerm q 6 typ
| otherwise = parens (id <+> ':' <+> ppTerm q 0 typ)
ppQIdent :: TermPrintQual -> QIdent -> Doc
ppQIdent q (m,id) =
case q of
Terse -> pp id
Unqualified -> pp id
Qualified -> m <> '.' <> id
Internal -> m <> '.' <> id
instance Pretty Label where pp = pp . label2ident
ppOpenSpec (OSimple id) = pp id
ppOpenSpec (OQualif id n) = parens (id <+> '=' <+> n)
ppInstSpec (id,n) = parens (id <+> '=' <+> n)
ppLocDef q (id, (mbt, e)) =
id <+>
(case mbt of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty} <+> '=' <+> ppTerm q 0 e) <+> ';'
ppBind (Explicit,v) = pp v
ppBind (Implicit,v) = braces v
ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps))
ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
ppProduction (Production fid funid args) =
ppFId fid <+> "->" <+> ppFunId funid <>
brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args)))
ppSequences q seqsArr
| null seqs || q /= Internal = empty
| otherwise = "sequences" <+> '{' $$
nest 2 (vcat (map ppSeq seqs)) $$
'}'
where
seqs = Array.assocs seqsArr
commaPunct f ds = (hcat (punctuate "," (map f ds)))
prec d1 d2 doc
| d1 > d2 = parens doc
| otherwise = doc
getAbs :: Term -> ([(BindType,Ident)], Term)
getAbs (Abs bt v e) = let (xs,e') = getAbs e
in ((bt,v):xs,e')
getAbs e = ([],e)
getCTable :: Term -> ([Ident], Term)
getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e
in (v:vs,e')
getCTable (T TRaw [(PW, e)]) = let (vs,e') = getCTable e
in (identW:vs,e')
getCTable e = ([],e)
getLet :: Term -> ([LocalDef], Term)
getLet (Let l e) = let (ls,e') = getLet e
in (l:ls,e')
getLet e = ([],e)
----------------------------------------------------------------------
-- |
-- Module : GF.Grammar.Printer
-- Maintainer : Krasimir Angelov
-- Stability : (stable)
-- Portability : (portable)
--
-----------------------------------------------------------------------------
{-# LANGUAGE FlexibleContexts #-}
module GF.Grammar.Printer
( -- ** Pretty printing
TermPrintQual(..)
, ppModule
, ppJudgement
, ppParams
, ppTerm
, ppPatt
, ppValue
, ppConstrs
, ppQIdent
, ppMeta
, getAbs
) where
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
import GF.Infra.Ident
import GF.Infra.Option
import GF.Grammar.Values
import GF.Grammar.Grammar
import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq)
import GF.Text.Pretty
import Data.Maybe (isNothing)
import Data.List (intersperse)
import qualified Data.Map as Map
--import qualified Data.IntMap as IntMap
--import qualified Data.Set as Set
import qualified Data.Array.IArray as Array
data TermPrintQual
= Terse | Unqualified | Qualified | Internal
deriving Eq
instance Pretty Grammar where
pp = vcat . map (ppModule Qualified) . modules
ppModule :: TermPrintQual -> SourceModule -> Doc
ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
hdr $$
nest 2 (ppOptions opts $$
vcat (map (ppJudgement q) (Map.toList jments)) $$
maybe empty (ppSequences q) mseqs) $$
ftr
where
hdr = complModDoc <+> modTypeDoc <+> '=' <+>
hsep (intersperse (pp "**") $
filter (not . isEmpty) $ [ commaPunct ppExtends exts
, maybe empty ppWith with
, if null opens
then pp '{'
else "open" <+> commaPunct ppOpenSpec opens <+> "in" <+> '{'
])
ftr = '}'
complModDoc =
case mstat of
MSComplete -> empty
MSIncomplete -> pp "incomplete"
modTypeDoc =
case mtype of
MTAbstract -> "abstract" <+> mn
MTResource -> "resource" <+> mn
MTConcrete abs -> "concrete" <+> mn <+> "of" <+> abs
MTInterface -> "interface" <+> mn
MTInstance ie -> "instance" <+> mn <+> "of" <+> ppExtends ie
ppExtends (id,MIAll ) = pp id
ppExtends (id,MIOnly incs) = id <+> brackets (commaPunct pp incs)
ppExtends (id,MIExcept incs) = id <+> '-' <+> brackets (commaPunct pp incs)
ppWith (id,ext,opens) = ppExtends (id,ext) <+> "with" <+> commaPunct ppInstSpec opens
ppOptions opts =
"flags" $$
nest 2 (vcat [option <+> '=' <+> ppLit value <+> ';' | (option,value) <- optionsGFO opts])
ppJudgement q (id, AbsCat pcont ) =
"cat" <+> id <+>
(case pcont of
Just (L _ cont) -> hsep (map (ppDecl q) cont)
Nothing -> empty) <+> ';'
ppJudgement q (id, AbsFun ptype _ pexp poper) =
let kind | isNothing pexp = "data"
| poper == Just False = "oper"
| otherwise = "fun"
in
(case ptype of
Just (L _ typ) -> kind <+> id <+> ':' <+> ppTerm q 0 typ <+> ';'
Nothing -> empty) $$
(case pexp of
Just [] -> empty
Just eqs -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs]
Nothing -> empty)
ppJudgement q (id, ResParam pparams _) =
"param" <+> id <+>
(case pparams of
Just (L _ ps) -> '=' <+> ppParams q ps
_ -> empty) <+> ';'
ppJudgement q (id, ResValue pvalue) =
"-- param constructor" <+> id <+> ':' <+>
(case pvalue of
(L _ ty) -> ppTerm q 0 ty) <+> ';'
ppJudgement q (id, ResOper ptype pexp) =
"oper" <+> id <+>
(case ptype of {Just (L _ t) -> ':' <+> ppTerm q 0 t; Nothing -> empty} $$
case pexp of {Just (L _ e) -> '=' <+> ppTerm q 0 e; Nothing -> empty}) <+> ';'
ppJudgement q (id, ResOverload ids defs) =
"oper" <+> id <+> '=' <+>
("overload" <+> '{' $$
nest 2 (vcat [id <+> (':' <+> ppTerm q 0 ty $$ '=' <+> ppTerm q 0 e <+> ';') | (L _ ty,L _ e) <- defs]) $$
'}') <+> ';'
ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) =
(case pcat of
Just (L _ typ) -> "lincat" <+> id <+> '=' <+> ppTerm q 0 typ <+> ';'
Nothing -> empty) $$
(case pdef of
Just (L _ exp) -> "lindef" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
Nothing -> empty) $$
(case pref of
Just (L _ exp) -> "linref" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
Nothing -> empty) $$
(case pprn of
Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
Nothing -> empty) $$
(case (mpmcfg,q) of
(Just (PMCFG prods funs),Internal)
-> "pmcfg" <+> id <+> '=' <+> '{' $$
nest 2 (vcat (map ppProduction prods) $$
' ' $$
vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
(Array.assocs funs))) $$
'}'
_ -> empty)
ppJudgement q (id, CncFun ptype pdef pprn mpmcfg) =
(case pdef of
Just (L _ e) -> let (xs,e') = getAbs e
in "lin" <+> id <+> hsep (map ppBind xs) <+> '=' <+> ppTerm q 0 e' <+> ';'
Nothing -> empty) $$
(case pprn of
Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
Nothing -> empty) $$
(case (mpmcfg,q) of
(Just (PMCFG prods funs),Internal)
-> "pmcfg" <+> id <+> '=' <+> '{' $$
nest 2 (vcat (map ppProduction prods) $$
' ' $$
vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
(Array.assocs funs))) $$
'}'
_ -> empty)
ppJudgement q (id, AnyInd cann mid) =
case q of
Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
_ -> empty
instance Pretty Term where pp = ppTerm Unqualified 0
ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e)
in prec d 0 ('\\' <> commaPunct ppBind xs <+> "->" <+> ppTerm q 0 e')
ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of
([],_) -> "table" <+> '{' $$
nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
'}'
(vs,e) -> prec d 0 ("\\\\" <> commaPunct pp vs <+> "=>" <+> ppTerm q 0 e)
ppTerm q d (T (TTyped t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
'}'
ppTerm q d (T (TComp t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
'}'
ppTerm q d (T (TWild t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
'}'
ppTerm q d (Prod bt x a b)= if x == identW && bt == Explicit
then prec d 0 (ppTerm q 4 a <+> "->" <+> ppTerm q 0 b)
else prec d 0 (parens (ppBind (bt,x) <+> ':' <+> ppTerm q 0 a) <+> "->" <+> ppTerm q 0 b)
ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> "=>" <+> ppTerm q 0 vt)
ppTerm q d (Let l e) = let (ls,e') = getLet e
in prec d 0 ("let" <+> vcat (map (ppLocDef q) (l:ls)) $$ "in" <+> ppTerm q 0 e')
ppTerm q d (Example e s)=prec d 0 ("in" <+> ppTerm q 5 e <+> str s)
ppTerm q d (C e1 e2) =prec d 1 (hang (ppTerm q 2 e1) 2 ("++" <+> ppTerm q 1 e2))
ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> '+' <+> ppTerm q 2 e2)
ppTerm q d (S x y) = case x of
T annot xs -> let e = case annot of
TRaw -> y
TTyped t -> Typed y t
TComp t -> Typed y t
TWild t -> Typed y t
in "case" <+> ppTerm q 0 e <+>"of" <+> '{' $$
nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
'}'
_ -> prec d 3 (hang (ppTerm q 3 x) 2 ("!" <+> ppTerm q 4 y))
ppTerm q d (ExtR x y) = prec d 3 (ppTerm q 3 x <+> "**" <+> ppTerm q 4 y)
ppTerm q d (App x y) = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y)
ppTerm q d (V e es) = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))])
ppTerm q d (FV es) = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))))
ppTerm q d (AdHocOverload es) = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
ppTerm q d (Strs es) = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
ppTerm q d (EPatt p) = prec d 4 ('#' <+> ppPatt q 2 p)
ppTerm q d (EPattType t)=prec d 4 ("pattern" <+> ppTerm q 0 t)
ppTerm q d (P t l) = prec d 5 (ppTerm q 5 t <> '.' <> l)
ppTerm q d (Cn id) = pp id
ppTerm q d (Vr id) = pp id
ppTerm q d (Q id) = ppQIdent q id
ppTerm q d (QC id) = ppQIdent q id
ppTerm q d (Sort id) = pp id
ppTerm q d (K s) = str s
ppTerm q d (EInt n) = pp n
ppTerm q d (EFloat f) = pp f
ppTerm q d (Meta i) = ppMeta i
ppTerm q d (Empty) = pp "[]"
ppTerm q d (R []) = pp "<>" -- to distinguish from {} empty RecType
ppTerm q d (R xs) = braces (fsep (punctuate ';' [l <+>
fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty},
'=' <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))
ppTerm q d (RecType xs)
| q == Terse = case [cat | (l,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of
[cat] -> pp cat
_ -> doc
| otherwise = doc
where
doc = braces (fsep (punctuate ';' [l <+> ':' <+> ppTerm q 0 t | (l,t) <- xs]))
ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>'
ppTerm q d (ImplArg e) = braces (ppTerm q 0 e)
ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t)
ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t)
ppTerm q d (Error s) = prec d 4 ("Predef.error" <+> str s)
ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e
ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e
instance Pretty Patt where pp = ppPatt Unqualified 0
ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '|' <+> ppPatt q 1 p2)
ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
ppPatt q d (PMSeq (_,p1) (_,p2)) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
ppPatt q d (PC f ps) = if null ps
then pp f
else prec d 1 (f <+> hsep (map (ppPatt q 3) ps))
ppPatt q d (PP f ps) = if null ps
then ppQIdent q f
else prec d 1 (ppQIdent q f <+> hsep (map (ppPatt q 3) ps))
ppPatt q d (PRep p) = prec d 1 (ppPatt q 3 p <> '*')
ppPatt q d (PAs f p) = prec d 2 (f <> '@' <> ppPatt q 3 p)
ppPatt q d (PNeg p) = prec d 2 ('-' <> ppPatt q 3 p)
ppPatt q d (PChar) = pp '?'
ppPatt q d (PChars s) = brackets (str s)
ppPatt q d (PMacro id) = '#' <> id
ppPatt q d (PM id) = '#' <> ppQIdent q id
ppPatt q d PW = pp '_'
ppPatt q d (PV id) = pp id
ppPatt q d (PInt n) = pp n
ppPatt q d (PFloat f) = pp f
ppPatt q d (PString s) = str s
ppPatt q d (PR xs) = braces (hsep (punctuate ';' [l <+> '=' <+> ppPatt q 0 e | (l,e) <- xs]))
ppPatt q d (PImplArg p) = braces (ppPatt q 0 p)
ppPatt q d (PTilde t) = prec d 2 ('~' <> ppTerm q 6 t)
ppValue :: TermPrintQual -> Int -> Val -> Doc
ppValue q d (VGen i x) = x <> "{-" <> i <> "-}" ---- latter part for debugging
ppValue q d (VApp u v) = prec d 4 (ppValue q 4 u <+> ppValue q 5 v)
ppValue q d (VCn (_,c)) = pp c
ppValue q d (VClos env e) = case e of
Meta _ -> ppTerm q d e <> ppEnv env
_ -> ppTerm q d e ---- ++ prEnv env ---- for debugging
ppValue q d (VRecType xs) = braces (hsep (punctuate ',' [l <> '=' <> ppValue q 0 v | (l,v) <- xs]))
ppValue q d VType = pp "Type"
ppConstrs :: Constraints -> [Doc]
ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> "<>" <+> ppValue Unqualified 0 w))
ppEnv :: Env -> Doc
ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e)
str s = doubleQuotes s
ppDecl q (_,id,typ)
| id == identW = ppTerm q 3 typ
| otherwise = parens (id <+> ':' <+> ppTerm q 0 typ)
ppDDecl q (_,id,typ)
| id == identW = ppTerm q 6 typ
| otherwise = parens (id <+> ':' <+> ppTerm q 0 typ)
ppQIdent :: TermPrintQual -> QIdent -> Doc
ppQIdent q (m,id) =
case q of
Terse -> pp id
Unqualified -> pp id
Qualified -> m <> '.' <> id
Internal -> m <> '.' <> id
instance Pretty Label where pp = pp . label2ident
ppOpenSpec (OSimple id) = pp id
ppOpenSpec (OQualif id n) = parens (id <+> '=' <+> n)
ppInstSpec (id,n) = parens (id <+> '=' <+> n)
ppLocDef q (id, (mbt, e)) =
id <+>
(case mbt of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty} <+> '=' <+> ppTerm q 0 e) <+> ';'
ppBind (Explicit,v) = pp v
ppBind (Implicit,v) = braces v
ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps))
ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
ppProduction (Production fid funid args) =
ppFId fid <+> "->" <+> ppFunId funid <>
brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args)))
ppSequences q seqsArr
| null seqs || q /= Internal = empty
| otherwise = "sequences" <+> '{' $$
nest 2 (vcat (map ppSeq seqs)) $$
'}'
where
seqs = Array.assocs seqsArr
commaPunct f ds = (hcat (punctuate "," (map f ds)))
prec d1 d2 doc
| d1 > d2 = parens doc
| otherwise = doc
getAbs :: Term -> ([(BindType,Ident)], Term)
getAbs (Abs bt v e) = let (xs,e') = getAbs e
in ((bt,v):xs,e')
getAbs e = ([],e)
getCTable :: Term -> ([Ident], Term)
getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e
in (v:vs,e')
getCTable (T TRaw [(PW, e)]) = let (vs,e') = getCTable e
in (identW:vs,e')
getCTable e = ([],e)
getLet :: Term -> ([LocalDef], Term)
getLet (Let l e) = let (ls,e') = getLet e
in (l:ls,e')
getLet e = ([],e)

19
src/compiler/GF/Grammar/Values.hs
View File

@@ -5,22 +5,23 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:22:32 $
-- > CVS $Date: 2005/04/21 16:22:32 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.7 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Grammar.Values (-- ** Values used in TC type checking
Val(..), Env,
-- ** Annotated tree used in editing
module GF.Grammar.Values (
-- ** Values used in TC type checking
Val(..), Env,
-- ** Annotated tree used in editing
Binds, Constraints, MetaSubst,
-- ** For TC
valAbsInt, valAbsFloat, valAbsString, vType,
isPredefCat,
eType,
) where
-- ** For TC
valAbsInt, valAbsFloat, valAbsString, vType,
isPredefCat,
eType,
) where
import GF.Infra.Ident
import GF.Grammar.Grammar

12
src/compiler/GF/Infra/CheckM.hs
View File

@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:22:33 $
-- > CVS $Date: 2005/04/21 16:22:33 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.5 $
--
@@ -14,10 +14,10 @@
module GF.Infra.CheckM
(Check, CheckResult, Message, runCheck, runCheck',
checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
checkIn, checkInModule, checkMap, checkMapRecover,
checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
checkIn, checkInModule, checkMap, checkMapRecover,
parallelCheck, accumulateError, commitCheck,
) where
) where
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
import GF.Data.Operations
@@ -141,10 +141,10 @@ checkMapRecover f = fmap Map.fromList . parallelCheck . map f' . Map.toList
where f' (k,v) = fmap ((,)k) (f k v)
{-
checkMapRecover f mp = do
checkMapRecover f mp = do
let xs = map (\ (k,v) -> (k,runCheck (f k v))) (Map.toList mp)
case [s | (_,Bad s) <- xs] of
ss@(_:_) -> checkError (text (unlines ss))
ss@(_:_) -> checkError (text (unlines ss))
_ -> do
let (kx,ss) = unzip [((k,x),s) | (k, Ok (x,s)) <- xs]
if not (all null ss) then checkWarn (text (unlines ss)) else return ()

2
src/compiler/GF/Interactive.hs
View File

@@ -433,7 +433,7 @@ wc_type = cmd_name
x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=' || c == '"') x1
cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of
[x] -> Just x
[x] -> Just x
_ -> Nothing
isIdent c = c == '_' || c == '\'' || isAlphaNum c

110
src/compiler/GF/Speech/FiniteState.hs
View File

@@ -5,37 +5,37 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/10 16:43:44 $
-- > CVS $Date: 2005/11/10 16:43:44 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.16 $
--
-- A simple finite state network module.
-----------------------------------------------------------------------------
module GF.Speech.FiniteState (FA(..), State, NFA, DFA,
startState, finalStates,
states, transitions,
startState, finalStates,
states, transitions,
isInternal,
newFA, newFA_,
addFinalState,
newState, newStates,
newFA, newFA_,
addFinalState,
newState, newStates,
newTransition, newTransitions,
insertTransitionWith, insertTransitionsWith,
mapStates, mapTransitions,
mapStates, mapTransitions,
modifyTransitions,
nonLoopTransitionsTo, nonLoopTransitionsFrom,
nonLoopTransitionsTo, nonLoopTransitionsFrom,
loops,
removeState,
oneFinalState,
insertNFA,
onGraph,
moveLabelsToNodes, removeTrivialEmptyNodes,
moveLabelsToNodes, removeTrivialEmptyNodes,
minimize,
dfa2nfa,
unusedNames, renameStates,
prFAGraphviz, faToGraphviz) where
prFAGraphviz, faToGraphviz) where
import Data.List
import Data.Maybe
import Data.Maybe
--import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
@@ -98,13 +98,13 @@ newTransition f t l = onGraph (newEdge (f,t,l))
newTransitions :: [(n, n, b)] -> FA n a b -> FA n a b
newTransitions es = onGraph (newEdges es)
insertTransitionWith :: Eq n =>
insertTransitionWith :: Eq n =>
(b -> b -> b) -> (n, n, b) -> FA n a b -> FA n a b
insertTransitionWith f t = onGraph (insertEdgeWith f t)
insertTransitionsWith :: Eq n =>
insertTransitionsWith :: Eq n =>
(b -> b -> b) -> [(n, n, b)] -> FA n a b -> FA n a b
insertTransitionsWith f ts fa =
insertTransitionsWith f ts fa =
foldl' (flip (insertTransitionWith f)) fa ts
mapStates :: (a -> c) -> FA n a b -> FA n c b
@@ -128,11 +128,11 @@ unusedNames (FA (Graph names _ _) _ _) = names
-- | Gets all incoming transitions to a given state, excluding
-- transtions from the state itself.
nonLoopTransitionsTo :: Eq n => n -> FA n a b -> [(n,b)]
nonLoopTransitionsTo s fa =
nonLoopTransitionsTo s fa =
[(f,l) | (f,t,l) <- transitions fa, t == s && f /= s]
nonLoopTransitionsFrom :: Eq n => n -> FA n a b -> [(n,b)]
nonLoopTransitionsFrom s fa =
nonLoopTransitionsFrom s fa =
[(t,l) | (f,t,l) <- transitions fa, f == s && t /= s]
loops :: Eq n => n -> FA n a b -> [b]
@@ -145,7 +145,7 @@ renameStates :: Ord x => [y] -- ^ Infinite supply of new names
renameStates supply (FA g s fs) = FA (renameNodes newName rest g) s' fs'
where (ns,rest) = splitAt (length (nodes g)) supply
newNodes = Map.fromList (zip (map fst (nodes g)) ns)
newName n = Map.findWithDefault (error "FiniteState.newName") n newNodes
newName n = Map.findWithDefault (error "FiniteState.newName") n newNodes
s' = newName s
fs' = map newName fs
@@ -154,9 +154,9 @@ insertNFA :: NFA a -- ^ NFA to insert into
-> (State, State) -- ^ States to insert between
-> NFA a -- ^ NFA to insert.
-> NFA a
insertNFA (FA g1 s1 fs1) (f,t) (FA g2 s2 fs2)
insertNFA (FA g1 s1 fs1) (f,t) (FA g2 s2 fs2)
= FA (newEdges es g') s1 fs1
where
where
es = (f,ren s2,Nothing):[(ren f2,t,Nothing) | f2 <- fs2]
(g',ren) = mergeGraphs g1 g2
@@ -182,9 +182,9 @@ oneFinalState nl el fa =
moveLabelsToNodes :: (Ord n,Eq a) => FA n () (Maybe a) -> FA n (Maybe a) ()
moveLabelsToNodes = onGraph f
where f g@(Graph c _ _) = Graph c' ns (concat ess)
where is = [ ((n,l),inc) | (n, (l,inc,_)) <- Map.toList (nodeInfo g)]
(c',is') = mapAccumL fixIncoming c is
(ns,ess) = unzip (concat is')
where is = [ ((n,l),inc) | (n, (l,inc,_)) <- Map.toList (nodeInfo g)]
(c',is') = mapAccumL fixIncoming c is
(ns,ess) = unzip (concat is')
-- | Remove empty nodes which are not start or final, and have
@@ -196,12 +196,12 @@ removeTrivialEmptyNodes = pruneUnusable . skipSimpleEmptyNodes
-- This is not done if the pointed-to node is a final node.
skipSimpleEmptyNodes :: (Eq a, Ord n) => FA n (Maybe a) () -> FA n (Maybe a) ()
skipSimpleEmptyNodes fa = onGraph og fa
where
where
og g@(Graph c ns es) = if es' == es then g else og (Graph c ns es')
where
es' = concatMap changeEdge es
info = nodeInfo g
changeEdge e@(f,t,())
changeEdge e@(f,t,())
| isNothing (getNodeLabel info t)
-- && (i * o <= i + o)
&& not (isFinal fa t)
@@ -223,28 +223,28 @@ pruneUnusable fa = onGraph f fa
where
f g = if Set.null rns then g else f (removeNodes rns g)
where info = nodeInfo g
rns = Set.fromList [ n | (n,_) <- nodes g,
rns = Set.fromList [ n | (n,_) <- nodes g,
isInternal fa n,
inDegree info n == 0
inDegree info n == 0
|| outDegree info n == 0]
fixIncoming :: (Ord n, Eq a) => [n]
fixIncoming :: (Ord n, Eq a) => [n]
-> (Node n (),[Edge n (Maybe a)]) -- ^ A node and its incoming edges
-> ([n],[(Node n (Maybe a),[Edge n ()])]) -- ^ Replacement nodes with their
-- incoming edges.
fixIncoming cs c@((n,()),es) = (cs'', ((n,Nothing),es'):newContexts)
where ls = nub $ map edgeLabel es
(cs',cs'') = splitAt (length ls) cs
newNodes = zip cs' ls
es' = [ (x,n,()) | x <- map fst newNodes ]
-- separate cyclic and non-cyclic edges
(cyc,ncyc) = partition (\ (f,_,_) -> f == n) es
-- keep all incoming non-cyclic edges with the right label
to (x,l) = [ (f,x,()) | (f,_,l') <- ncyc, l == l']
-- for each cyclic edge with the right label,
-- add an edge from each of the new nodes (including this one)
++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes]
newContexts = [ (v, to v) | v <- newNodes ]
(cs',cs'') = splitAt (length ls) cs
newNodes = zip cs' ls
es' = [ (x,n,()) | x <- map fst newNodes ]
-- separate cyclic and non-cyclic edges
(cyc,ncyc) = partition (\ (f,_,_) -> f == n) es
-- keep all incoming non-cyclic edges with the right label
to (x,l) = [ (f,x,()) | (f,_,l') <- ncyc, l == l']
-- for each cyclic edge with the right label,
-- add an edge from each of the new nodes (including this one)
++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes]
newContexts = [ (v, to v) | v <- newNodes ]
--alphabet :: Eq b => Graph n a (Maybe b) -> [b]
--alphabet = nub . catMaybes . map edgeLabel . edges
@@ -254,19 +254,19 @@ determinize (FA g s f) = let (ns,es) = h (Set.singleton start) Set.empty Set.emp
(ns',es') = (Set.toList ns, Set.toList es)
final = filter isDFAFinal ns'
fa = FA (Graph undefined [(n,()) | n <- ns'] es') start final
in renameStates [0..] fa
in renameStates [0..] fa
where info = nodeInfo g
-- reach = nodesReachable out
start = closure info $ Set.singleton s
start = closure info $ Set.singleton s
isDFAFinal n = not (Set.null (Set.fromList f `Set.intersection` n))
h currentStates oldStates es
| Set.null currentStates = (oldStates,es)
| otherwise = ((h $! uniqueNewStates) $! allOldStates) $! es'
where
allOldStates = oldStates `Set.union` currentStates
h currentStates oldStates es
| Set.null currentStates = (oldStates,es)
| otherwise = ((h $! uniqueNewStates) $! allOldStates) $! es'
where
allOldStates = oldStates `Set.union` currentStates
(newStates,es') = new (Set.toList currentStates) Set.empty es
uniqueNewStates = newStates Set.\\ allOldStates
-- Get the sets of states reachable from the given states
uniqueNewStates = newStates Set.\\ allOldStates
-- Get the sets of states reachable from the given states
-- by consuming one symbol, and the associated edges.
new [] rs es = (rs,es)
new (n:ns) rs es = new ns rs' es'
@@ -281,7 +281,7 @@ closure info x = closure_ x x
where closure_ acc check | Set.null check = acc
| otherwise = closure_ acc' check'
where
reach = Set.fromList [y | x <- Set.toList check,
reach = Set.fromList [y | x <- Set.toList check,
(_,y,Nothing) <- getOutgoing info x]
acc' = acc `Set.union` reach
check' = reach Set.\\ acc
@@ -296,8 +296,8 @@ reachable1 info ns = Map.fromListWith (++) [(c, [y]) | n <- Set.toList ns, (_,y,
reverseNFA :: NFA a -> NFA a
reverseNFA (FA g s fs) = FA g''' s' [s]
where g' = reverseGraph g
(g'',s') = newNode () g'
g''' = newEdges [(s',f,Nothing) | f <- fs] g''
(g'',s') = newNode () g'
g''' = newEdges [(s',f,Nothing) | f <- fs] g''
dfa2nfa :: DFA a -> NFA a
dfa2nfa = mapTransitions Just
@@ -313,13 +313,13 @@ prFAGraphviz = Dot.prGraphviz . faToGraphviz
--prFAGraphviz_ = Dot.prGraphviz . faToGraphviz . mapStates show . mapTransitions show
faToGraphviz :: (Eq n,Show n) => FA n String String -> Dot.Graph
faToGraphviz (FA (Graph _ ns es) s f)
faToGraphviz (FA (Graph _ ns es) s f)
= Dot.Graph Dot.Directed Nothing [] (map mkNode ns) (map mkEdge es) []
where mkNode (n,l) = Dot.Node (show n) attrs
where attrs = [("label",l)]
++ if n == s then [("shape","box")] else []
++ if n `elem` f then [("style","bold")] else []
mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)]
where attrs = [("label",l)]
++ if n == s then [("shape","box")] else []
++ if n `elem` f then [("style","bold")] else []
mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)]
--
-- * Utilities

6
src/compiler/GF/Speech/GSL.hs
View File

@@ -26,14 +26,14 @@ width = 75
gslPrinter :: Options -> PGF -> CId -> String
gslPrinter opts pgf cnc = renderStyle st $ prGSL $ makeNonLeftRecursiveSRG opts pgf cnc
where st = style { lineLength = width }
where st = style { lineLength = width }
prGSL :: SRG -> Doc
prGSL srg = header $++$ mainCat $++$ foldr ($++$) empty (map prRule (srgRules srg))
where
header = ";GSL2.0" $$
comment ("Nuance speech recognition grammar for " ++ srgName srg) $$
comment ("Generated by GF")
comment ("Nuance speech recognition grammar for " ++ srgName srg) $$
comment ("Generated by GF")
mainCat = ".MAIN" <+> prCat (srgStartCat srg)
prRule (SRGRule cat rhs) = prCat cat <+> union (map prAlt rhs)
-- FIXME: use the probability

7
src/compiler/GF/Speech/JSGF.hs
View File

@@ -31,7 +31,7 @@ width :: Int
width = 75
jsgfPrinter :: Options
-> PGF
-> PGF
-> CId -> String
jsgfPrinter opts pgf cnc = renderStyle st $ prJSGF sisr $ makeNonLeftRecursiveSRG opts pgf cnc
where st = style { lineLength = width }
@@ -44,7 +44,7 @@ prJSGF sisr srg
header = "#JSGF" <+> "V1.0" <+> "UTF-8" <+> lang <> ';' $$
comment ("JSGF speech recognition grammar for " ++ srgName srg) $$
comment "Generated by GF" $$
("grammar " ++ srgName srg ++ ";")
("grammar " ++ srgName srg ++ ";")
lang = maybe empty pp (srgLanguage srg)
mainCat = rule True "MAIN" [prCat (srgStartCat srg)]
prRule (SRGRule cat rhs) = rule (isExternalCat srg cat) cat (map prAlt rhs)
@@ -62,7 +62,7 @@ prItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> Doc
prItem sisr t = f 0
where
f _ (REUnion []) = pp "<VOID>"
f p (REUnion xs)
f p (REUnion xs)
| not (null es) = brackets (f 0 (REUnion nes))
| otherwise = (if p >= 1 then parens else id) (alts (map (f 1) xs))
where (es,nes) = partition isEpsilon xs
@@ -110,4 +110,3 @@ prepunctuate p (x:xs) = x : map (p <>) xs
($++$) :: Doc -> Doc -> Doc
x $++$ y = x $$ emptyLine $$ y

16
src/compiler/GF/Speech/PGFToCFG.hs
View File

@@ -28,7 +28,7 @@ toBNF f pgf cnc = prCFG $ f $ pgfToCFG pgf cnc
type Profile = [Int]
pgfToCFG :: PGF
pgfToCFG :: PGF
-> CId -- ^ Concrete syntax name
-> CFG
pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ concatMap ruleToCFRule rules)
@@ -40,8 +40,8 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
, prod <- Set.toList set]
fcatCats :: Map FId Cat
fcatCats = Map.fromList [(fc, showCId c ++ "_" ++ show i)
| (c,CncCat s e lbls) <- Map.toList (cnccats cnc),
fcatCats = Map.fromList [(fc, showCId c ++ "_" ++ show i)
| (c,CncCat s e lbls) <- Map.toList (cnccats cnc),
(fc,i) <- zip (range (s,e)) [1..]]
fcatCat :: FId -> Cat
@@ -58,7 +58,7 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
topdownRules cat = f cat []
where
f cat rules = maybe rules (Set.foldr g rules) (IntMap.lookup cat (productions cnc))
g (PApply funid args) rules = (cncfuns cnc ! funid,args) : rules
g (PCoerce cat) rules = f cat rules
@@ -67,13 +67,13 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
extCats = Set.fromList $ map ruleLhs startRules
startRules :: [CFRule]
startRules = [Rule (showCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0)
| (c,CncCat s e lbls) <- Map.toList (cnccats cnc),
startRules = [Rule (showCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0)
| (c,CncCat s e lbls) <- Map.toList (cnccats cnc),
fc <- range (s,e), not (isPredefFId fc),
r <- [0..catLinArity fc-1]]
ruleToCFRule :: (FId,Production) -> [CFRule]
ruleToCFRule (c,PApply funid args) =
ruleToCFRule (c,PApply funid args) =
[Rule (fcatToCat c l) (mkRhs row) (profilesToTerm [fixProfile row n | n <- [0..length args-1]])
| (l,seqid) <- Array.assocs rhs
, let row = sequences cnc ! seqid
@@ -106,7 +106,7 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
fixProfile row i = [k | (k,j) <- nts, j == i]
where
nts = zip [0..] [j | nt <- Array.elems row, j <- getPos nt]
getPos (SymCat j _) = [j]
getPos (SymLit j _) = [j]
getPos _ = []

50
src/compiler/GF/Speech/SRG.hs
View File

@@ -2,8 +2,8 @@
-- |
-- Module : SRG
--
-- Representation of, conversion to, and utilities for
-- printing of a general Speech Recognition Grammar.
-- Representation of, conversion to, and utilities for
-- printing of a general Speech Recognition Grammar.
--
-- FIXME: remove \/ warn \/ fail if there are int \/ string literal
-- categories in the grammar
@@ -40,20 +40,20 @@ import qualified Data.Set as Set
--import Debug.Trace
data SRG = SRG { srgName :: String -- ^ grammar name
, srgStartCat :: Cat -- ^ start category name
, srgExternalCats :: Set Cat
, srgLanguage :: Maybe String -- ^ The language for which the grammar
-- is intended, e.g. en-UK
, srgRules :: [SRGRule]
}
deriving (Eq,Show)
, srgStartCat :: Cat -- ^ start category name
, srgExternalCats :: Set Cat
, srgLanguage :: Maybe String -- ^ The language for which the grammar
-- is intended, e.g. en-UK
, srgRules :: [SRGRule]
}
deriving (Eq,Show)
data SRGRule = SRGRule Cat [SRGAlt]
deriving (Eq,Show)
deriving (Eq,Show)
-- | maybe a probability, a rule name and an EBNF right-hand side
data SRGAlt = SRGAlt (Maybe Double) CFTerm SRGItem
deriving (Eq,Show)
deriving (Eq,Show)
type SRGItem = RE SRGSymbol
@@ -65,7 +65,7 @@ type SRGNT = (Cat, Int)
ebnfPrinter :: Options -> PGF -> CId -> String
ebnfPrinter opts pgf cnc = prSRG opts $ makeSRG opts pgf cnc
-- | Create a compact filtered non-left-recursive SRG.
-- | Create a compact filtered non-left-recursive SRG.
makeNonLeftRecursiveSRG :: Options -> PGF -> CId -> SRG
makeNonLeftRecursiveSRG opts = makeSRG opts'
where
@@ -76,11 +76,11 @@ makeSRG opts = mkSRG cfgToSRG preprocess
where
cfgToSRG cfg = [cfRulesToSRGRule rs | (_,rs) <- allRulesGrouped cfg]
preprocess = maybeTransform opts CFGMergeIdentical mergeIdentical
. maybeTransform opts CFGNoLR removeLeftRecursion
. maybeTransform opts CFGNoLR removeLeftRecursion
. maybeTransform opts CFGRegular makeRegular
. maybeTransform opts CFGTopDownFilter topDownFilter
. maybeTransform opts CFGBottomUpFilter bottomUpFilter
. maybeTransform opts CFGRemoveCycles removeCycles
. maybeTransform opts CFGRemoveCycles removeCycles
. maybeTransform opts CFGStartCatOnly purgeExternalCats
setDefaultCFGTransform :: Options -> CFGTransform -> Bool -> Options
@@ -95,7 +95,7 @@ stats g = "Categories: " ++ show (countCats g)
++ ", External categories: " ++ show (Set.size (cfgExternalCats g))
++ ", Rules: " ++ show (countRules g)
-}
makeNonRecursiveSRG :: Options
makeNonRecursiveSRG :: Options
-> PGF
-> CId -- ^ Concrete syntax name.
-> SRG
@@ -111,26 +111,26 @@ makeNonRecursiveSRG opts = mkSRG cfgToSRG id
mkSRG :: (CFG -> [SRGRule]) -> (CFG -> CFG) -> PGF -> CId -> SRG
mkSRG mkRules preprocess pgf cnc =
SRG { srgName = showCId cnc,
srgStartCat = cfgStartCat cfg,
srgStartCat = cfgStartCat cfg,
srgExternalCats = cfgExternalCats cfg,
srgLanguage = languageCode pgf cnc,
srgRules = mkRules cfg }
srgRules = mkRules cfg }
where cfg = renameCats (showCId cnc) $ preprocess $ pgfToCFG pgf cnc
-- | Renames all external cats C to C_cat, and all internal cats C_X (where X is any string),
-- | Renames all external cats C to C_cat, and all internal cats C_X (where X is any string),
-- to C_N where N is an integer.
renameCats :: String -> CFG -> CFG
renameCats prefix cfg = mapCFGCats renameCat cfg
where renameCat c | isExternal c = c ++ "_cat"
| otherwise = Map.findWithDefault (badCat c) c names
isExternal c = c `Set.member` cfgExternalCats cfg
isExternal c = c `Set.member` cfgExternalCats cfg
catsByPrefix = buildMultiMap [(takeWhile (/='_') cat, cat) | cat <- allCats' cfg, not (isExternal cat)]
names = Map.fromList [(c,pref++"_"++show i) | (pref,cs) <- catsByPrefix, (c,i) <- zip cs [1..]]
badCat c = error ("GF.Speech.SRG.renameCats: " ++ c ++ "\n" ++ prCFG cfg)
cfRulesToSRGRule :: [CFRule] -> SRGRule
cfRulesToSRGRule rs@(r:_) = SRGRule (ruleLhs r) rhs
where
where
alts = [((n,Nothing),mkSRGSymbols 0 ss) | Rule c ss n <- rs]
rhs = [SRGAlt p n (srgItem sss) | ((n,p),sss) <- buildMultiMap alts ]
@@ -153,7 +153,7 @@ srgItem = unionRE . map mergeItems . sortGroupBy (compareBy filterCats)
-- non-optimizing version:
--srgItem = unionRE . map seqRE
-- | Merges a list of right-hand sides which all have the same
-- | Merges a list of right-hand sides which all have the same
-- sequence of non-terminals.
mergeItems :: [[SRGSymbol]] -> SRGItem
mergeItems = minimizeRE . ungroupTokens . minimizeRE . unionRE . map seqRE . map groupTokens
@@ -174,16 +174,16 @@ ungroupTokens = joinRE . mapRE (symbol (RESymbol . NonTerminal) (REConcat . map
prSRG :: Options -> SRG -> String
prSRG opts srg = prProductions $ map prRule $ ext ++ int
where
where
sisr = flag optSISR opts
(ext,int) = partition (isExternalCat srg . srgLHSCat) (srgRules srg)
prRule (SRGRule c alts) = (c,unwords (intersperse "|" (concatMap prAlt alts)))
prAlt (SRGAlt _ t rhs) =
-- FIXME: hack: we high-jack the --sisr flag to add
prAlt (SRGAlt _ t rhs) =
-- FIXME: hack: we high-jack the --sisr flag to add
-- a simple lambda calculus format for semantic interpretation
-- Maybe the --sisr flag should be renamed.
case sisr of
Just _ ->
Just _ ->
-- copy tags to each part of a top-level union,
-- to get simpler output
case rhs of

11
src/compiler/GF/Speech/SRGS_ABNF.hs
View File

@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/01 20:09:04 $
-- > CVS $Date: 2005/11/01 20:09:04 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.16 $
--
@@ -38,7 +38,7 @@ width :: Int
width = 75
srgsAbnfPrinter :: Options
-> PGF -> CId -> String
-> PGF -> CId -> String
srgsAbnfPrinter opts pgf cnc = showDoc $ prABNF sisr $ makeNonLeftRecursiveSRG opts pgf cnc
where sisr = flag optSISR opts
@@ -72,7 +72,7 @@ prItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> Doc
prItem sisr t = f 0
where
f _ (REUnion []) = pp "$VOID"
f p (REUnion xs)
f p (REUnion xs)
| not (null es) = brackets (f 0 (REUnion nes))
| otherwise = (if p >= 1 then parens else id) (alts (map (f 1) xs))
where (es,nes) = partition isEpsilon xs
@@ -84,13 +84,13 @@ prItem sisr t = f 0
prSymbol :: Maybe SISRFormat -> CFTerm -> SRGSymbol -> Doc
prSymbol sisr cn (NonTerminal n@(c,_)) = prCat c <+> tag sisr (catSISR cn n)
prSymbol _ cn (Terminal t)
prSymbol _ cn (Terminal t)
| all isPunct t = empty -- removes punctuation
| otherwise = pp t -- FIXME: quote if there is whitespace or odd chars
tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> Doc
tag Nothing _ = empty
tag (Just fmt) t =
tag (Just fmt) t =
case t fmt of
[] -> empty
-- grr, silly SRGS ABNF does not have an escaping mechanism
@@ -125,4 +125,3 @@ prepunctuate p (x:xs) = x : map (p <>) xs
($++$) :: Doc -> Doc -> Doc
x $++$ y = x $$ emptyLine $$ y

24
src/compiler/GF/Speech/SRGS_XML.hs
View File

@@ -34,13 +34,13 @@ prSrgsXml :: Maybe SISRFormat -> SRG -> String
prSrgsXml sisr srg = showXMLDoc (optimizeSRGS xmlGr)
where
xmlGr = grammar sisr (srgStartCat srg) (srgLanguage srg) $
[meta "description"
[meta "description"
("SRGS XML speech recognition grammar for " ++ srgName srg ++ "."),
meta "generator" "Grammatical Framework"]
++ map ruleToXML (srgRules srg)
++ map ruleToXML (srgRules srg)
ruleToXML (SRGRule cat alts) = Tag "rule" ([("id",cat)]++pub) (prRhs alts)
where pub = if isExternalCat srg cat then [("scope","public")] else []
prRhs rhss = [oneOf (map (mkProd sisr) rhss)]
prRhs rhss = [oneOf (map (mkProd sisr) rhss)]
mkProd :: Maybe SISRFormat -> SRGAlt -> XML
mkProd sisr (SRGAlt mp n rhs) = Tag "item" [] (ti ++ [x] ++ tf)
@@ -50,9 +50,9 @@ mkProd sisr (SRGAlt mp n rhs) = Tag "item" [] (ti ++ [x] ++ tf)
mkItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> XML
mkItem sisr cn = f
where
where
f (REUnion []) = ETag "ruleref" [("special","VOID")]
f (REUnion xs)
f (REUnion xs)
| not (null es) = Tag "item" [("repeat","0-1")] [f (REUnion nes)]
| otherwise = oneOf (map f xs)
where (es,nes) = partition isEpsilon xs
@@ -62,7 +62,7 @@ mkItem sisr cn = f
f (RESymbol s) = symItem sisr cn s
symItem :: Maybe SISRFormat -> CFTerm -> Symbol SRGNT Token -> XML
symItem sisr cn (NonTerminal n@(c,_)) =
symItem sisr cn (NonTerminal n@(c,_)) =
Tag "item" [] $ [ETag "ruleref" [("uri","#" ++ c)]] ++ tag sisr (catSISR cn n)
symItem _ _ (Terminal t) = Tag "item" [] [Data (showToken t)]
@@ -81,12 +81,12 @@ oneOf = Tag "one-of" []
grammar :: Maybe SISRFormat
-> String -- ^ root
-> Maybe String -- ^language
-> [XML] -> XML
grammar sisr root ml =
-> [XML] -> XML
grammar sisr root ml =
Tag "grammar" $ [("xmlns","http://www.w3.org/2001/06/grammar"),
("version","1.0"),
("mode","voice"),
("root",root)]
("version","1.0"),
("mode","voice"),
("root",root)]
++ (if isJust sisr then [("tag-format","semantics/1.0")] else [])
++ maybe [] (\l -> [("xml:lang", l)]) ml
@@ -94,7 +94,7 @@ meta :: String -> String -> XML
meta n c = ETag "meta" [("name",n),("content",c)]
optimizeSRGS :: XML -> XML
optimizeSRGS = bottomUpXML f
optimizeSRGS = bottomUpXML f
where f (Tag "item" [] [x@(Tag "item" _ _)]) = x
f (Tag "item" [] [x@(Tag "one-of" _ _)]) = x
f (Tag "item" as [Tag "item" [] xs]) = Tag "item" as xs

132
src/compiler/GF/Text/Transliterations.hs
View File

@@ -17,7 +17,7 @@ import qualified Data.Map as Map
-- to add a new one: define the Unicode range and the corresponding ASCII strings,
-- which may be one or more characters long
-- conventions to be followed:
-- conventions to be followed:
-- each character is either [letter] or [letter+nonletters]
-- when using a sparse range of unicodes, mark missing codes as "-" in transliterations
-- characters can be invisible: ignored in translation to unicode
@@ -33,7 +33,7 @@ transliterateWithFile name src isFrom =
(if isFrom then appTransFromUnicode else appTransToUnicode) (getTransliterationFile name src)
transliteration :: String -> Maybe Transliteration
transliteration s = Map.lookup s allTransliterations
transliteration s = Map.lookup s allTransliterations
allTransliterations = Map.fromList [
("amharic",transAmharic),
@@ -67,25 +67,25 @@ data Transliteration = Trans {
}
appTransToUnicode :: Transliteration -> String -> String
appTransToUnicode trans =
appTransToUnicode trans =
concat .
map (\c -> maybe c (return . toEnum) $
Map.lookup c (trans_to_unicode trans)
) .
filter (flip notElem (invisible_chars trans)) .
) .
filter (flip notElem (invisible_chars trans)) .
unchar
appTransFromUnicode :: Transliteration -> String -> String
appTransFromUnicode trans =
appTransFromUnicode trans =
concat .
map (\c -> maybe [toEnum c] id $
map (\c -> maybe [toEnum c] id $
Map.lookup c (trans_from_unicode trans)
) .
) .
map fromEnum
mkTransliteration :: String -> [String] -> [Int] -> Transliteration
mkTransliteration name ts us =
mkTransliteration name ts us =
Trans (Map.fromList (tzip ts us)) (Map.fromList (uzip us ts)) [] name
where
tzip ts us = [(t,u) | (t,u) <- zip ts us, t /= "-"]
@@ -102,7 +102,7 @@ getTransliterationFile name = uncurry (mkTransliteration name) . codes
unchar :: String -> [String]
unchar s = case s of
c:d:cs
c:d:cs
| isAlpha d -> [c] : unchar (d:cs)
| isSpace d -> [c]:[d]: unchar cs
| otherwise -> let (ds,cs2) = break (\x -> isAlpha x || isSpace x) cs in
@@ -122,8 +122,8 @@ transThai = mkTransliteration "Thai" allTrans allCodes where
allCodes = [0x0e00 .. 0x0e7f]
transDevanagari :: Transliteration
transDevanagari =
(mkTransliteration "Devanagari"
transDevanagari =
(mkTransliteration "Devanagari"
allTransUrduHindi allCodes){invisible_chars = ["a"]} where
allCodes = [0x0900 .. 0x095f] ++ [0x0966 .. 0x096f]
@@ -136,13 +136,13 @@ allTransUrduHindi = words $
"- - - - - - - - q x g. z R R' f - " ++
"N0 N1 N2 N3 N4 N5 N6 N7 N8 N9 "
transUrdu :: Transliteration
transUrdu =
transUrdu =
(mkTransliteration "Urdu" allTrans allCodes) where
allCodes = [0x0622 .. 0x062f] ++ [0x0630 .. 0x063a] ++ [0x0641,0x0642] ++ [0x06A9] ++ [0x0644 .. 0x0648] ++
allCodes = [0x0622 .. 0x062f] ++ [0x0630 .. 0x063a] ++ [0x0641,0x0642] ++ [0x06A9] ++ [0x0644 .. 0x0648] ++
[0x0654,0x0658,0x0679,0x067e,0x0686,0x0688,0x0691,0x0698,0x06af,0x06c1,0x06c3,0x06cc,0x06ba,0x06be,0x06d2] ++
[0x06f0 .. 0x06f9] ++ [0x061f,0x06D4]
[0x06f0 .. 0x06f9] ++ [0x061f,0x06D4]
allTrans = words $
"A - w^ - y^ a b - t C j H K d " ++ -- 0622 - 062f
"Z r z s X S Z- t- z- e G " ++ -- 0630 - 063a
@@ -151,22 +151,22 @@ transUrdu =
"N0 N1 N2 N3 N4 N5 N6 N7 N8 N9 " ++ "? ."
transSindhi :: Transliteration
transSindhi =
transSindhi =
(mkTransliteration "Sindhi" allTrans allCodes) where
allCodes = [0x062e] ++ [0x0627 .. 0x062f] ++ [0x0630 .. 0x063a] ++ [0x0641 .. 0x0648] ++
[0x067a,0x067b,0x067d,0x067e,0x067f] ++ [0x0680 .. 0x068f] ++
[0x0699,0x0918,0x06a6,0x061d,0x06a9,0x06af,0x06b3,0x06bb,0x06be,0x06f6,0x064a,0x06b1, 0x06aa, 0x06fd, 0x06fe] ++
[0x06f0 .. 0x06f9] ++ [0x061f,0x06D4]
[0x06f0 .. 0x06f9] ++ [0x061f,0x06D4]
allTrans = words $
"K a b - t C j H - d " ++ -- 0626 - 062f
"Z r z s X S Z- t- z- e G " ++ -- 0630 - 063a
"f q - L m n - W " ++ -- 0641 - 0648
"T! B T p T' " ++ -- 067a,067b,067d,067e,067f
"B' - - Y' J' - c c' - - d! - d' D - D' " ++ -- 0680 - 068f
"R - F' - k' g G' t' h' e' y c! k A M " ++ -- 0699, 0918, 06a6, 061d, 06a9,06af,06b3,06bb,06be,06f6,06cc,06b1
"R - F' - k' g G' t' h' e' y c! k A M " ++ -- 0699, 0918, 06a6, 061d, 06a9,06af,06b3,06bb,06be,06f6,06cc,06b1
"N0 N1 N2 N3 N4 N5 N6 N7 N8 N9 " ++ "? ."
transArabic :: Transliteration
transArabic = mkTransliteration "Arabic" allTrans allCodes where
@@ -175,8 +175,8 @@ transArabic = mkTransliteration "Arabic" allTrans allCodes where
"W r z s C S D T Z c G " ++ -- 0630 - 063a
" f q k l m n h w y. y a. u. i. a u " ++ -- 0641 - 064f
"i v2 o a: V+ V- i: a+ " ++ -- 0650 - 0657
"A* q?" -- 0671 (used by AED)
allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++
"A* q?" -- 0671 (used by AED)
allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++
[0x0641..0x064f] ++ [0x0650..0x0657] ++ [0x0671,0x061f]
@@ -193,16 +193,16 @@ transPersian = (mkTransliteration "Persian/Farsi" allTrans allCodes)
" V A: A? w? A- y? A b t. t t- j H K d " ++ -- 0621 - 062f
"W r z s C S D T Z c G " ++ -- 0630 - 063a
" f q - l m n h v - y. a. u. i. a u " ++ -- 0640 - 064f
"i v2 o a: V+ V- i: a+ " ++ -- 0650 - 0657
"i v2 o a: V+ V- i: a+ " ++ -- 0650 - 0657
"p c^ J k g y q? Z0"
allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++
[0x0641..0x064f] ++ [0x0650..0x0657] ++
allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++
[0x0641..0x064f] ++ [0x0650..0x0657] ++
[0x067e,0x0686,0x0698,0x06a9,0x06af,0x06cc,0x061f,0x200c]
transNepali :: Transliteration
transNepali = mkTransliteration "Nepali" allTrans allCodes where
allTrans = words $
"z+ z= " ++
"z+ z= " ++
"- V M h: - H A i: I: f F Z - - - e: " ++
"E: - - O W k K g G n: C c j J Y q " ++
"Q x X N t T d D n - p P b B m y " ++
@@ -241,7 +241,7 @@ transGreek = mkTransliteration "modern Greek" allTrans allCodes where
"i= A B G D E Z H V I K L M N X O " ++
"P R - S T Y F C Q W I- Y- a' e' h' i' " ++
"y= a b g d e z h v i k l m n x o " ++
"p r s* s t y f c q w i- y- o' y' w' - "
"p r s* s t y f c q w i- y- o' y' w' - "
allCodes = [0x0380 .. 0x03cf]
transAncientGreek :: Transliteration
@@ -261,32 +261,32 @@ transAncientGreek = mkTransliteration "ancient Greek" allTrans allCodes where
"y) y( y)` y(` y)' y(' y)~ y(~ - Y( - Y(` - Y(' - Y(~ " ++
"w) w( w)` w(` w)' w(' w)~ w(~ W) W( W)` W(` W)' W(' W)~ W(~ " ++
"a` a' e` e' h` h' i` i' o` o' y` y' w` w' - - " ++
"a|) a|( a|)` a|(` a|)' a|(' a|)~ a|(~ - - - - - - - - " ++ -- 1f80-
"h|) h|( h|)` h|(` h|)' h|(' h|)~ h|(~ - - - - - - - - " ++ -- 1f90-
"w|) w|( w|)` w|(` w|)' w|(' w|)~ w|(~ - - - - - - - - " ++ -- 1fa0-
"a|) a|( a|)` a|(` a|)' a|(' a|)~ a|(~ - - - - - - - - " ++ -- 1f80-
"h|) h|( h|)` h|(` h|)' h|(' h|)~ h|(~ - - - - - - - - " ++ -- 1f90-
"w|) w|( w|)` w|(` w|)' w|(' w|)~ w|(~ - - - - - - - - " ++ -- 1fa0-
"a. a_ a|` a| a|' - a~ a|~ - - - - - - - - " ++ -- 1fb0-
"- - h|` h| h|' - h~ h|~ - - - - - - - - " ++ -- 1fc0-
"i. i_ i=` i=' - - i~ i=~ - - - - - - - - " ++ -- 1fd0-
"y. y_ y=` y=' r) r( y~ y=~ - - - - - - - - " ++ -- 1fe0-
"y. y_ y=` y=' r) r( y~ y=~ - - - - - - - - " ++ -- 1fe0-
"- - w|` w| w|' - w~ w|~ - - - - - - - - " ++ -- 1ff0-
-- HL, Private Use Area Code Points (New Athena Unicode, Cardo, ALPHABETUM, Antioch)
-- see: http://apagreekkeys.org/technicalDetails.html
-- GreekKeys Support by Donald Mastronarde
"- - - - - - - - - e. o. R) Y) Y)` Y)' Y)~ " ++ -- e1a0-e1af
"- - - - - - - - - e. o. R) Y) Y)` Y)' Y)~ " ++ -- e1a0-e1af
"e~ e)~ e(~ e_ e_' e_` e_) e_( e_)` e_(` e_)' e_(' E)~ E(~ E_ E. " ++ -- e1b0-e1bf
"o~ o)~ o(~ o_ o_' o_` o_) o_( o_)` o_(` o_)' o_(' O)~ O(~ O_ O. " ++ -- e1c0-e1cf
"a_` - a_~ a_)` a_(` a_)~ a_(~ - a.` a.) a.)` a.(' a.(` - - - " ++ -- eaf0-eaff
"a_' - - - a_) a_( - a_)' - a_(' a.' a.( a.)' - - - " ++ -- eb00-eb0f
"a_` - a_~ a_)` a_(` a_)~ a_(~ - a.` a.) a.)` a.(' a.(` - - - " ++ -- eaf0-eaff
"a_' - - - a_) a_( - a_)' - a_(' a.' a.( a.)' - - - " ++ -- eb00-eb0f
"e_)~ e_(~ - - - - - e_~ - - - - - - - - " ++ -- eb20-eb2f
"- - - - - - i_~ - i_` i_' - - i_) i_)' i_( i_(' " ++ -- eb30-eb3f
"- - - - - - i_~ - i_` i_' - - i_) i_)' i_( i_(' " ++ -- eb30-eb3f
"i.' i.) i.)' i.( i.` i.)` - i.(' i.(` - - - - - - - " ++ -- eb40-eb4f
"- - - - i_)` i_(` - i_)~ i_(~ - o_~ o_)~ o_(~ - - - " ++ -- eb50-eb5f
"y_` " ++ -- eb6f
"y_~ y_)` - - - y_(` - y_)~ y_(~ - y_' - - y_) y_( y_)' " ++ -- eb70-eb7f
"y_(' y.' y.( y.` y.) y.)' - - y.)` y.(' y.(` - - - - - " -- eb80-eb8f
allCodes = -- [0x00B0 .. 0x00Bf]
[0x0380 .. 0x03cf] ++ [0x1f00 .. 0x1fff]
++ [0xe1a0 .. 0xe1af]
allCodes = -- [0x00B0 .. 0x00Bf]
[0x0380 .. 0x03cf] ++ [0x1f00 .. 0x1fff]
++ [0xe1a0 .. 0xe1af]
++ [0xe1b0 .. 0xe1bf]
++ [0xe1c0 .. 0xe1cf]
++ [0xeaf0 .. 0xeaff]
@@ -297,36 +297,34 @@ transAncientGreek = mkTransliteration "ancient Greek" allTrans allCodes where
++ [0xeb50 .. 0xeb5f] ++ [0xeb6f]
++ [0xeb70 .. 0xeb7f]
++ [0xeb80 .. 0xeb8f]
transAmharic :: Transliteration
transAmharic :: Transliteration
transAmharic = mkTransliteration "Amharic" allTrans allCodes where
allTrans = words $
" h. h- h' h( h) h h? h* l. l- l' l( l) l l? l* "++
" H. H- H' H( H) H H? H* m. m- m' m( m) m m? m* "++
" s. s- s' s( s) s s? s* r. r- r' r( r) r r? r* "++
" - - - - - - - - x. x- x' x( x) x x? x* "++
" q. q- q' q( q) q q? q* - - - - - - - - "++
" - - - - - - - - - - - - - - - - "++
" b. b- b' b( b) b b? b* v. v- v' v( v) v v? v* "++
" t. t- t' t( t) t t? t* c. c- c' c( c) c c? c* "++
" X. X- X' X( X) X X? - - - - X* - - - - "++
" n. n- n' n( n) n n? n* N. N- N' N( N) N N? N* "++
" a u i A E e o e* k. k- k' k( k) k k? - "++
" - - - k* - - - - - - - - - - - - "++
" - - - - - - - - w. w- w' w( w) w w? w* "++
" - - - - - - - - z. z- z' z( z) z z? z* "++
" Z. Z- Z' Z( Z) Z Z? Z* y. y- y' y( y) y y? y* "++
" d. d- d' d( d) d d? d* - - - - - - - - "++
" j. j- j' j( j) j j? j* g. g- g' g( g) g g? - "++
" - - - g* - - - - - - - - - - - - "++
" T. T- T' T( T) T T? T* C. C- C' C( C) C C? C* "++
" P. P- P' P( P) P P? P* S. S- S' S( S) S S? S* "++
" - - - - - - - - f. f- f' f( f) f f? f*"++
" p. p- p' p( p) p p? p*"
allCodes = [0x1200..0x1357]
allTrans = words $
" h. h- h' h( h) h h? h* l. l- l' l( l) l l? l* "++
" H. H- H' H( H) H H? H* m. m- m' m( m) m m? m* "++
" s. s- s' s( s) s s? s* r. r- r' r( r) r r? r* "++
" - - - - - - - - x. x- x' x( x) x x? x* "++
" q. q- q' q( q) q q? q* - - - - - - - - "++
" - - - - - - - - - - - - - - - - "++
" b. b- b' b( b) b b? b* v. v- v' v( v) v v? v* "++
" t. t- t' t( t) t t? t* c. c- c' c( c) c c? c* "++
" X. X- X' X( X) X X? - - - - X* - - - - "++
" n. n- n' n( n) n n? n* N. N- N' N( N) N N? N* "++
" a u i A E e o e* k. k- k' k( k) k k? - "++
" - - - k* - - - - - - - - - - - - "++
" - - - - - - - - w. w- w' w( w) w w? w* "++
" - - - - - - - - z. z- z' z( z) z z? z* "++
" Z. Z- Z' Z( Z) Z Z? Z* y. y- y' y( y) y y? y* "++
" d. d- d' d( d) d d? d* - - - - - - - - "++
" j. j- j' j( j) j j? j* g. g- g' g( g) g g? - "++
" - - - g* - - - - - - - - - - - - "++
" T. T- T' T( T) T T? T* C. C- C' C( C) C C? C* "++
" P. P- P' P( P) P P? P* S. S- S' S( S) S S? S* "++
" - - - - - - - - f. f- f' f( f) f f? f*"++
" p. p- p' p( p) p p? p*"
allCodes = [0x1200..0x1357]
-- by Prasad 31/5/2013
transSanskrit :: Transliteration
transSanskrit = (mkTransliteration "Sanskrit" allTrans allCodes) {invisible_chars = ["a"]} where

2
src/runtime/haskell-bind/pgf2.cabal
View File

@@ -26,7 +26,7 @@ library
PGF2.Expr,
PGF2.Type
build-depends:
base >= 4.9.1 && <4.15,
base >= 4.9.1 && < 4.15,
containers >= 0.5.7 && < 0.7,
pretty >= 1.1.3 && < 1.2
default-language: Haskell2010

2
src/runtime/haskell/pgf.cabal
View File

@@ -14,7 +14,7 @@ tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.10.4
library
default-language: Haskell2010
build-depends:
base >= 4.9.1 && <4.15,
base >= 4.9.1 && < 4.15,
array >= 0.5.1 && < 0.6,
containers >= 0.5.7 && < 0.7,
bytestring >= 0.10.8 && < 0.11,