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

Replace tabs for whitespace in source code

Browse Source
This commit is contained in:
John J. Camilleri
2021-07-07 09:40:41 +02:00
parent a2b23d5897
commit f2e52d6f2c
32 changed files with 799 additions and 803 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -18,7 +18,7 @@ import Data.List
-------------------------- --------------------------
cf2pgf :: FilePath -> ParamCFG -> PGF cf2pgf :: FilePath -> ParamCFG -> PGF
cf2pgf fpath cf = cf2pgf fpath cf =
let pgf = PGF Map.empty aname (cf2abstr cf) (Map.singleton cname (cf2concr cf)) let pgf = PGF Map.empty aname (cf2abstr cf) (Map.singleton cname (cf2concr cf))
in updateProductionIndices pgf in updateProductionIndices pgf
where where
@@ -33,7 +33,7 @@ cf2abstr cfg = Abstr aflags afuns acats
acats = Map.fromList [(cat, ([], [(0,mkRuleName rule) | rule <- rules], 0)) acats = Map.fromList [(cat, ([], [(0,mkRuleName rule) | rule <- rules], 0))
| (cat,rules) <- (Map.toList . Map.fromListWith (++)) | (cat,rules) <- (Map.toList . Map.fromListWith (++))
[(cat2id cat, catRules cfg cat) | [(cat2id cat, catRules cfg cat) |
cat <- allCats' cfg]] cat <- allCats' cfg]]
afuns = Map.fromList [(mkRuleName rule, (cftype [cat2id c | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)), 0, Nothing, 0)) afuns = Map.fromList [(mkRuleName rule, (cftype [cat2id c | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)), 0, Nothing, 0))
| rule <- allRules cfg] | rule <- allRules cfg]
@@ -52,7 +52,7 @@ cf2concr cfg = Concr Map.empty Map.empty
cats = allCats' cfg cats = allCats' cfg
rules = allRules 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) map mkSequence rules)
sequences = listArray (0,Set.size sequences0-1) (Set.toList sequences0) sequences = listArray (0,Set.size sequences0-1) (Set.toList sequences0)
@@ -102,7 +102,7 @@ cf2concr cfg = Concr Map.empty Map.empty
mkLinDefRef (cat,_) = mkLinDefRef (cat,_) =
(cat2fid cat 0,[0]) (cat2fid cat 0,[0])
addProd prods (fid,prod) = addProd prods (fid,prod) =
case IntMap.lookup fid prods of case IntMap.lookup fid prods of
Just set -> IntMap.insert fid (Set.insert prod set) prods Just set -> IntMap.insert fid (Set.insert prod set) prods
@@ -130,5 +130,5 @@ cf2concr cfg = Concr Map.empty Map.empty
mkRuleName rule = mkRuleName rule =
case ruleName rule of case ruleName rule of
CFObj n _ -> n CFObj n _ -> n
_ -> wildCId _ -> 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 checkTyp gr typ
case md of case md of
Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $ 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 () Nothing -> return ()
return (AbsFun (Just (L loc typ)) ma md moper) 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 mkLinArg (i,(n,mc@(m,cat))) = do
val <- lookLin mc val <- lookLin mc
let vars = mkRecType varLabel $ replicate n typeStr 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 rec <- if n==0 then return val else
errIn (render ("extending" $$ errIn (render ("extending" $$
nest 2 vars $$ nest 2 vars $$

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

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

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

@@ -5,7 +5,7 @@
-- Stability : (stable) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/09/15 16:22:02 $ -- > CVS $Date: 2005/09/15 16:22:02 $
-- > CVS $Author: aarne $ -- > CVS $Author: aarne $
-- > CVS $Revision: 1.16 $ -- > CVS $Revision: 1.16 $
-- --
@@ -13,11 +13,11 @@
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module GF.Compile.TypeCheck.Abstract (-- * top-level type checking functions; TC should not be called directly. module GF.Compile.TypeCheck.Abstract (-- * top-level type checking functions; TC should not be called directly.
checkContext, checkContext,
checkTyp, checkTyp,
checkDef, checkDef,
checkConstrs, checkConstrs,
) where ) where
import GF.Data.Operations import GF.Data.Operations
@@ -33,8 +33,8 @@ import GF.Text.Pretty
--import Control.Monad (foldM, liftM, liftM2) --import Control.Monad (foldM, liftM, liftM2)
-- | invariant way of creating TCEnv from context -- | invariant way of creating TCEnv from context
initTCEnv gamma = initTCEnv gamma =
(length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma) (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma)
-- interface to TC type checker -- 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 lockRecType c t' ---- locking to be removed AR 20/6/2009
_ | ty == typeTok -> return typeStr _ | ty == typeTok -> return typeStr
_ | isPredefConstant ty -> return ty
_ -> composOp (comp g) 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) return ((l,ty):rs,mb_ty)
-- | Invariant: if the third argument is (Just rho), -- | 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 :: GlobalEnv -> Scope -> Term -> Sigma -> Maybe Rho -> TcM (Term, Rho)
instSigma ge scope t ty1 Nothing = return (t,ty1) -- INST1 instSigma ge scope t ty1 Nothing = return (t,ty1) -- INST1
instSigma ge scope t ty1 (Just ty2) = do -- INST2 instSigma ge scope t ty1 (Just ty2) = do -- INST2
@@ -631,8 +631,8 @@ allBinders = [ identS [x] | x <- ['a'..'z'] ] ++
type Scope = [(Ident,Value)] type Scope = [(Ident,Value)]
type Sigma = Value type Sigma = Value
type Rho = Value -- No top-level ForAll type Rho = Value -- No top-level ForAll
type Tau = Value -- No ForAlls anywhere type Tau = Value -- No ForAlls anywhere
data MetaValue data MetaValue
= Unbound Scope Sigma = Unbound Scope Sigma
@@ -724,8 +724,8 @@ getMetaVars loc sc_tys = do
go (Vr tv) acc = acc go (Vr tv) acc = acc
go (App x y) acc = go x (go y acc) go (App x y) acc = go x (go y acc)
go (Meta i) acc go (Meta i) acc
| i `elem` acc = acc | i `elem` acc = acc
| otherwise = i : acc | otherwise = i : acc
go (Q _) acc = acc go (Q _) acc = acc
go (QC _) acc = acc go (QC _) acc = acc
go (Sort _) acc = acc go (Sort _) acc = acc
@@ -742,9 +742,9 @@ getFreeVars loc sc_tys = do
return (foldr (go []) [] tys) return (foldr (go []) [] tys)
where where
go bound (Vr tv) acc go bound (Vr tv) acc
| tv `elem` bound = acc | tv `elem` bound = acc
| tv `elem` acc = acc | tv `elem` acc = acc
| otherwise = tv : acc | otherwise = tv : acc
go bound (App x y) acc = go bound x (go bound y acc) go bound (App x y) acc = go bound x (go bound y acc)
go bound (Meta _) acc = acc go bound (Meta _) acc = acc
go bound (Q _) acc = acc go bound (Q _) acc = acc

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

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

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

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

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

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

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

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

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

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

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

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

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

@@ -5,7 +5,7 @@
-- Stability : (stable) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/10/26 17:13:13 $ -- > CVS $Date: 2005/10/26 17:13:13 $
-- > CVS $Author: bringert $ -- > CVS $Author: bringert $
-- > CVS $Revision: 1.1 $ -- > 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) 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. 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 reflexiveClosure_ u r = relates [(x,x) | x <- u] r
-- | Uses 'domain' -- | 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 ] reflexiveElements r = Set.fromList [ x | (x,ys) <- Map.toList r, x `Set.member` ys ]
-- | Keep the related pairs for which the predicate is true. -- | 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) filterRel p = fst . purgeEmpty . Map.mapWithKey (Set.filter . p)
-- | Remove keys that map to no elements. -- | 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 purgeEmpty r = let (r',r'') = Map.partition (not . Set.null) r
in (r', Map.keysSet 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 :: Ord a => Rel a -> [Set a]
equivalenceClasses r = equivalenceClasses_ (Map.keys r) r equivalenceClasses r = equivalenceClasses_ (Map.keys r) r
where equivalenceClasses_ [] _ = [] where equivalenceClasses_ [] _ = []
equivalenceClasses_ (x:xs) r = ys:equivalenceClasses_ zs r equivalenceClasses_ (x:xs) r = ys:equivalenceClasses_ zs r
where ys = allRelated r x where ys = allRelated r x
zs = [x' | x' <- xs, not (x' `Set.member` ys)] zs = [x' | x' <- xs, not (x' `Set.member` ys)]
isTransitive :: Ord a => Rel a -> Bool 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)] y <- Set.toList ys, z <- Set.toList (allRelated r y)]
isReflexive :: Ord a => Rel a -> Bool 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) Nothing -> (r', Set.empty, Set.empty)
-- remove element from all incoming and outgoing sets -- remove element from all incoming and outgoing sets
-- of other elements -- 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 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 r''' = foldr (\o -> Map.adjust (\ (is',os') -> (Set.delete x is', os')) o) r'' $ Set.toList os
in (r''', is, 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 incoming x r = maybe Set.empty fst $ Map.lookup x r
--outgoing :: Ord a => a -> Rel' a -> Set a --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) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/10/26 18:47:16 $ -- > CVS $Date: 2005/10/26 18:47:16 $
-- > CVS $Author: bringert $ -- > CVS $Author: bringert $
-- > CVS $Revision: 1.6 $ -- > CVS $Revision: 1.6 $
-- --
@@ -33,7 +33,7 @@ longerThan n = not . notLongerThan n
lookupList :: Eq a => a -> [(a, b)] -> [b] lookupList :: Eq a => a -> [(a, b)] -> [b]
lookupList a [] = [] lookupList a [] = []
lookupList a (p:ps) | a == fst p = snd p : lookupList a ps 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 :: [a] -> ([a], [a])
split (x : y : as) = (x:xs, y:ys) 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 :: (a -> a -> a) -> a -> [a] -> a
foldMerge merge zero = fm foldMerge merge zero = fm
where fm [] = zero where fm [] = zero
fm [a] = a fm [a] = a
fm abs = let (as, bs) = split abs in fm as `merge` fm bs fm abs = let (as, bs) = split abs in fm as `merge` fm bs
select :: [a] -> [(a, [a])] select :: [a] -> [(a, [a])]
select [] = [] select [] = []
@@ -68,7 +68,7 @@ safeInit :: [a] -> [a]
safeInit [] = [] safeInit [] = []
safeInit xs = init xs 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. -- elements.
sortGroupBy :: (a -> a -> Ordering) -> [a] -> [[a]] sortGroupBy :: (a -> a -> Ordering) -> [a] -> [[a]]
sortGroupBy f = groupBy (compareEq f) . sortBy f sortGroupBy f = groupBy (compareEq f) . sortBy f

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

@@ -45,12 +45,12 @@ data LincatDef = LincatDef CatId LinType deriving Show
data LinDef = LinDef FunId [VarId] LinValue deriving Show data LinDef = LinDef FunId [VarId] LinValue deriving Show
-- | Linearization type, RHS of @lincat@ -- | Linearization type, RHS of @lincat@
data LinType = FloatType data LinType = FloatType
| IntType | IntType
| ParamType ParamType | ParamType ParamType
| RecordType [RecordRowType] | RecordType [RecordRowType]
| StrType | StrType
| TableType LinType LinType | TableType LinType LinType
| TupleType [LinType] | TupleType [LinType]
deriving (Eq,Ord,Show) deriving (Eq,Ord,Show)
@@ -60,7 +60,7 @@ newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
data LinValue = ConcatValue LinValue LinValue data LinValue = ConcatValue LinValue LinValue
| LiteralValue LinLiteral | LiteralValue LinLiteral
| ErrorValue String | ErrorValue String
| ParamConstant ParamValue | ParamConstant ParamValue
| PredefValue PredefId | PredefValue PredefId
| RecordValue [RecordRowValue] | RecordValue [RecordRowValue]
| TableValue LinType [TableRowValue] | TableValue LinType [TableRowValue]
@@ -74,9 +74,9 @@ data LinValue = ConcatValue LinValue LinValue
| CommentedValue String LinValue | CommentedValue String LinValue
deriving (Eq,Ord,Show) deriving (Eq,Ord,Show)
data LinLiteral = FloatConstant Float data LinLiteral = FloatConstant Float
| IntConstant Int | IntConstant Int
| StrConstant String | StrConstant String
deriving (Eq,Ord,Show) deriving (Eq,Ord,Show)
data LinPattern = ParamPattern ParamPattern data LinPattern = ParamPattern ParamPattern
@@ -107,7 +107,7 @@ newtype PredefId = PredefId Id deriving (Eq,Ord,Show)
newtype LabelId = LabelId Id deriving (Eq,Ord,Show) newtype LabelId = LabelId Id deriving (Eq,Ord,Show)
data VarValueId = VarValueId QualId deriving (Eq,Ord,Show) data VarValueId = VarValueId QualId deriving (Eq,Ord,Show)
-- | Name of param type or param value -- | Name of param type or param value
newtype ParamId = ParamId QualId deriving (Eq,Ord,Show) newtype ParamId = ParamId QualId deriving (Eq,Ord,Show)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@@ -250,7 +250,7 @@ instance PPA LinLiteral where
FloatConstant f -> pp f FloatConstant f -> pp f
IntConstant n -> pp n IntConstant n -> pp n
StrConstant s -> doubleQuotes s -- hmm StrConstant s -> doubleQuotes s -- hmm
instance RhsSeparator LinValue where rhsSep _ = pp "=" instance RhsSeparator LinValue where rhsSep _ = pp "="
instance Pretty LinPattern where instance Pretty LinPattern where
@@ -265,7 +265,7 @@ instance PPA LinPattern where
ParamPattern pv -> ppA pv ParamPattern pv -> ppA pv
RecordPattern r -> block r RecordPattern r -> block r
TuplePattern ps -> "<"<>punctuate "," ps<>">" TuplePattern ps -> "<"<>punctuate "," ps<>">"
WildPattern -> pp "_" WildPattern -> pp "_"
instance RhsSeparator LinPattern where rhsSep _ = pp "=" 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 data ParseResult a
= POk AlexInput2 a = POk AlexInput2 a
| PFailed Posn -- The position of the error | PFailed Posn -- The position of the error
String -- The error message String -- The error message
newtype P a = P { unP :: AlexInput2 -> ParseResult a } newtype P a = P { unP :: AlexInput2 -> ParseResult a }

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@@ -31,7 +31,7 @@ width :: Int
width = 75 width = 75
jsgfPrinter :: Options jsgfPrinter :: Options
-> PGF -> PGF
-> CId -> String -> CId -> String
jsgfPrinter opts pgf cnc = renderStyle st $ prJSGF sisr $ makeNonLeftRecursiveSRG opts pgf cnc jsgfPrinter opts pgf cnc = renderStyle st $ prJSGF sisr $ makeNonLeftRecursiveSRG opts pgf cnc
where st = style { lineLength = width } where st = style { lineLength = width }
@@ -44,7 +44,7 @@ prJSGF sisr srg
header = "#JSGF" <+> "V1.0" <+> "UTF-8" <+> lang <> ';' $$ header = "#JSGF" <+> "V1.0" <+> "UTF-8" <+> lang <> ';' $$
comment ("JSGF speech recognition grammar for " ++ srgName srg) $$ comment ("JSGF speech recognition grammar for " ++ srgName srg) $$
comment "Generated by GF" $$ comment "Generated by GF" $$
("grammar " ++ srgName srg ++ ";") ("grammar " ++ srgName srg ++ ";")
lang = maybe empty pp (srgLanguage srg) lang = maybe empty pp (srgLanguage srg)
mainCat = rule True "MAIN" [prCat (srgStartCat srg)] mainCat = rule True "MAIN" [prCat (srgStartCat srg)]
prRule (SRGRule cat rhs) = rule (isExternalCat srg cat) cat (map prAlt rhs) 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 prItem sisr t = f 0
where where
f _ (REUnion []) = pp "<VOID>" f _ (REUnion []) = pp "<VOID>"
f p (REUnion xs) f p (REUnion xs)
| not (null es) = brackets (f 0 (REUnion nes)) | not (null es) = brackets (f 0 (REUnion nes))
| otherwise = (if p >= 1 then parens else id) (alts (map (f 1) xs)) | otherwise = (if p >= 1 then parens else id) (alts (map (f 1) xs))
where (es,nes) = partition isEpsilon xs where (es,nes) = partition isEpsilon xs
@@ -110,4 +110,3 @@ prepunctuate p (x:xs) = x : map (p <>) xs
($++$) :: Doc -> Doc -> Doc ($++$) :: Doc -> Doc -> Doc
x $++$ y = x $$ emptyLine $$ y 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] type Profile = [Int]
pgfToCFG :: PGF pgfToCFG :: PGF
-> CId -- ^ Concrete syntax name -> CId -- ^ Concrete syntax name
-> CFG -> CFG
pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ concatMap ruleToCFRule rules) 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] , prod <- Set.toList set]
fcatCats :: Map FId Cat fcatCats :: Map FId Cat
fcatCats = Map.fromList [(fc, showCId c ++ "_" ++ show i) fcatCats = Map.fromList [(fc, showCId c ++ "_" ++ show i)
| (c,CncCat s e lbls) <- Map.toList (cnccats cnc), | (c,CncCat s e lbls) <- Map.toList (cnccats cnc),
(fc,i) <- zip (range (s,e)) [1..]] (fc,i) <- zip (range (s,e)) [1..]]
fcatCat :: FId -> Cat fcatCat :: FId -> Cat
@@ -58,7 +58,7 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
topdownRules cat = f cat [] topdownRules cat = f cat []
where where
f cat rules = maybe rules (Set.foldr g rules) (IntMap.lookup cat (productions cnc)) 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 (PApply funid args) rules = (cncfuns cnc ! funid,args) : rules
g (PCoerce cat) rules = f cat 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 extCats = Set.fromList $ map ruleLhs startRules
startRules :: [CFRule] startRules :: [CFRule]
startRules = [Rule (showCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0) startRules = [Rule (showCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0)
| (c,CncCat s e lbls) <- Map.toList (cnccats cnc), | (c,CncCat s e lbls) <- Map.toList (cnccats cnc),
fc <- range (s,e), not (isPredefFId fc), fc <- range (s,e), not (isPredefFId fc),
r <- [0..catLinArity fc-1]] r <- [0..catLinArity fc-1]]
ruleToCFRule :: (FId,Production) -> [CFRule] 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]]) [Rule (fcatToCat c l) (mkRhs row) (profilesToTerm [fixProfile row n | n <- [0..length args-1]])
| (l,seqid) <- Array.assocs rhs | (l,seqid) <- Array.assocs rhs
, let row = sequences cnc ! seqid , 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] fixProfile row i = [k | (k,j) <- nts, j == i]
where where
nts = zip [0..] [j | nt <- Array.elems row, j <- getPos nt] nts = zip [0..] [j | nt <- Array.elems row, j <- getPos nt]
getPos (SymCat j _) = [j] getPos (SymCat j _) = [j]
getPos (SymLit j _) = [j] getPos (SymLit j _) = [j]
getPos _ = [] getPos _ = []

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

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

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

@@ -5,7 +5,7 @@
-- Stability : (stable) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/11/01 20:09:04 $ -- > CVS $Date: 2005/11/01 20:09:04 $
-- > CVS $Author: bringert $ -- > CVS $Author: bringert $
-- > CVS $Revision: 1.16 $ -- > CVS $Revision: 1.16 $
-- --
@@ -38,7 +38,7 @@ width :: Int
width = 75 width = 75
srgsAbnfPrinter :: Options srgsAbnfPrinter :: Options
-> PGF -> CId -> String -> PGF -> CId -> String
srgsAbnfPrinter opts pgf cnc = showDoc $ prABNF sisr $ makeNonLeftRecursiveSRG opts pgf cnc srgsAbnfPrinter opts pgf cnc = showDoc $ prABNF sisr $ makeNonLeftRecursiveSRG opts pgf cnc
where sisr = flag optSISR opts where sisr = flag optSISR opts
@@ -72,7 +72,7 @@ prItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> Doc
prItem sisr t = f 0 prItem sisr t = f 0
where where
f _ (REUnion []) = pp "$VOID" f _ (REUnion []) = pp "$VOID"
f p (REUnion xs) f p (REUnion xs)
| not (null es) = brackets (f 0 (REUnion nes)) | not (null es) = brackets (f 0 (REUnion nes))
| otherwise = (if p >= 1 then parens else id) (alts (map (f 1) xs)) | otherwise = (if p >= 1 then parens else id) (alts (map (f 1) xs))
where (es,nes) = partition isEpsilon xs where (es,nes) = partition isEpsilon xs
@@ -84,13 +84,13 @@ prItem sisr t = f 0
prSymbol :: Maybe SISRFormat -> CFTerm -> SRGSymbol -> Doc prSymbol :: Maybe SISRFormat -> CFTerm -> SRGSymbol -> Doc
prSymbol sisr cn (NonTerminal n@(c,_)) = prCat c <+> tag sisr (catSISR cn n) 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 | all isPunct t = empty -- removes punctuation
| otherwise = pp t -- FIXME: quote if there is whitespace or odd chars | otherwise = pp t -- FIXME: quote if there is whitespace or odd chars
tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> Doc tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> Doc
tag Nothing _ = empty tag Nothing _ = empty
tag (Just fmt) t = tag (Just fmt) t =
case t fmt of case t fmt of
[] -> empty [] -> empty
-- grr, silly SRGS ABNF does not have an escaping mechanism -- 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 ($++$) :: Doc -> Doc -> Doc
x $++$ y = x $$ emptyLine $$ y 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) prSrgsXml sisr srg = showXMLDoc (optimizeSRGS xmlGr)
where where
xmlGr = grammar sisr (srgStartCat srg) (srgLanguage srg) $ xmlGr = grammar sisr (srgStartCat srg) (srgLanguage srg) $
[meta "description" [meta "description"
("SRGS XML speech recognition grammar for " ++ srgName srg ++ "."), ("SRGS XML speech recognition grammar for " ++ srgName srg ++ "."),
meta "generator" "Grammatical Framework"] meta "generator" "Grammatical Framework"]
++ map ruleToXML (srgRules srg) ++ map ruleToXML (srgRules srg)
ruleToXML (SRGRule cat alts) = Tag "rule" ([("id",cat)]++pub) (prRhs alts) ruleToXML (SRGRule cat alts) = Tag "rule" ([("id",cat)]++pub) (prRhs alts)
where pub = if isExternalCat srg cat then [("scope","public")] else [] 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 :: Maybe SISRFormat -> SRGAlt -> XML
mkProd sisr (SRGAlt mp n rhs) = Tag "item" [] (ti ++ [x] ++ tf) 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 :: Maybe SISRFormat -> CFTerm -> SRGItem -> XML
mkItem sisr cn = f mkItem sisr cn = f
where where
f (REUnion []) = ETag "ruleref" [("special","VOID")] f (REUnion []) = ETag "ruleref" [("special","VOID")]
f (REUnion xs) f (REUnion xs)
| not (null es) = Tag "item" [("repeat","0-1")] [f (REUnion nes)] | not (null es) = Tag "item" [("repeat","0-1")] [f (REUnion nes)]
| otherwise = oneOf (map f xs) | otherwise = oneOf (map f xs)
where (es,nes) = partition isEpsilon xs where (es,nes) = partition isEpsilon xs
@@ -62,7 +62,7 @@ mkItem sisr cn = f
f (RESymbol s) = symItem sisr cn s f (RESymbol s) = symItem sisr cn s
symItem :: Maybe SISRFormat -> CFTerm -> Symbol SRGNT Token -> XML 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) Tag "item" [] $ [ETag "ruleref" [("uri","#" ++ c)]] ++ tag sisr (catSISR cn n)
symItem _ _ (Terminal t) = Tag "item" [] [Data (showToken t)] symItem _ _ (Terminal t) = Tag "item" [] [Data (showToken t)]
@@ -81,12 +81,12 @@ oneOf = Tag "one-of" []
grammar :: Maybe SISRFormat grammar :: Maybe SISRFormat
-> String -- ^ root -> String -- ^ root
-> Maybe String -- ^language -> Maybe String -- ^language
-> [XML] -> XML -> [XML] -> XML
grammar sisr root ml = grammar sisr root ml =
Tag "grammar" $ [("xmlns","http://www.w3.org/2001/06/grammar"), Tag "grammar" $ [("xmlns","http://www.w3.org/2001/06/grammar"),
("version","1.0"), ("version","1.0"),
("mode","voice"), ("mode","voice"),
("root",root)] ("root",root)]
++ (if isJust sisr then [("tag-format","semantics/1.0")] else []) ++ (if isJust sisr then [("tag-format","semantics/1.0")] else [])
++ maybe [] (\l -> [("xml:lang", l)]) ml ++ maybe [] (\l -> [("xml:lang", l)]) ml
@@ -94,7 +94,7 @@ meta :: String -> String -> XML
meta n c = ETag "meta" [("name",n),("content",c)] meta n c = ETag "meta" [("name",n),("content",c)]
optimizeSRGS :: XML -> XML optimizeSRGS :: XML -> XML
optimizeSRGS = bottomUpXML f optimizeSRGS = bottomUpXML f
where f (Tag "item" [] [x@(Tag "item" _ _)]) = x where f (Tag "item" [] [x@(Tag "item" _ _)]) = x
f (Tag "item" [] [x@(Tag "one-of" _ _)]) = x f (Tag "item" [] [x@(Tag "one-of" _ _)]) = x
f (Tag "item" as [Tag "item" [] xs]) = Tag "item" as xs 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, -- to add a new one: define the Unicode range and the corresponding ASCII strings,
-- which may be one or more characters long -- which may be one or more characters long
-- conventions to be followed: -- conventions to be followed:
-- each character is either [letter] or [letter+nonletters] -- each character is either [letter] or [letter+nonletters]
-- when using a sparse range of unicodes, mark missing codes as "-" in transliterations -- when using a sparse range of unicodes, mark missing codes as "-" in transliterations
-- characters can be invisible: ignored in translation to unicode -- 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) (if isFrom then appTransFromUnicode else appTransToUnicode) (getTransliterationFile name src)
transliteration :: String -> Maybe Transliteration transliteration :: String -> Maybe Transliteration
transliteration s = Map.lookup s allTransliterations transliteration s = Map.lookup s allTransliterations
allTransliterations = Map.fromList [ allTransliterations = Map.fromList [
("amharic",transAmharic), ("amharic",transAmharic),
@@ -67,25 +67,25 @@ data Transliteration = Trans {
} }
appTransToUnicode :: Transliteration -> String -> String appTransToUnicode :: Transliteration -> String -> String
appTransToUnicode trans = appTransToUnicode trans =
concat . concat .
map (\c -> maybe c (return . toEnum) $ map (\c -> maybe c (return . toEnum) $
Map.lookup c (trans_to_unicode trans) Map.lookup c (trans_to_unicode trans)
) . ) .
filter (flip notElem (invisible_chars trans)) . filter (flip notElem (invisible_chars trans)) .
unchar unchar
appTransFromUnicode :: Transliteration -> String -> String appTransFromUnicode :: Transliteration -> String -> String
appTransFromUnicode trans = appTransFromUnicode trans =
concat . concat .
map (\c -> maybe [toEnum c] id $ map (\c -> maybe [toEnum c] id $
Map.lookup c (trans_from_unicode trans) Map.lookup c (trans_from_unicode trans)
) . ) .
map fromEnum map fromEnum
mkTransliteration :: String -> [String] -> [Int] -> Transliteration 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 Trans (Map.fromList (tzip ts us)) (Map.fromList (uzip us ts)) [] name
where where
tzip ts us = [(t,u) | (t,u) <- zip ts us, t /= "-"] 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 :: String -> [String]
unchar s = case s of unchar s = case s of
c:d:cs c:d:cs
| isAlpha d -> [c] : unchar (d:cs) | isAlpha d -> [c] : unchar (d:cs)
| isSpace d -> [c]:[d]: unchar cs | isSpace d -> [c]:[d]: unchar cs
| otherwise -> let (ds,cs2) = break (\x -> isAlpha x || isSpace x) cs in | 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] allCodes = [0x0e00 .. 0x0e7f]
transDevanagari :: Transliteration transDevanagari :: Transliteration
transDevanagari = transDevanagari =
(mkTransliteration "Devanagari" (mkTransliteration "Devanagari"
allTransUrduHindi allCodes){invisible_chars = ["a"]} where allTransUrduHindi allCodes){invisible_chars = ["a"]} where
allCodes = [0x0900 .. 0x095f] ++ [0x0966 .. 0x096f] allCodes = [0x0900 .. 0x095f] ++ [0x0966 .. 0x096f]
@@ -136,13 +136,13 @@ allTransUrduHindi = words $
"- - - - - - - - q x g. z R R' f - " ++ "- - - - - - - - q x g. z R R' f - " ++
"N0 N1 N2 N3 N4 N5 N6 N7 N8 N9 " "N0 N1 N2 N3 N4 N5 N6 N7 N8 N9 "
transUrdu :: Transliteration transUrdu :: Transliteration
transUrdu = transUrdu =
(mkTransliteration "Urdu" allTrans allCodes) where (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] ++ [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 $ allTrans = words $
"A - w^ - y^ a b - t C j H K d " ++ -- 0622 - 062f "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 "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 " ++ "? ." "N0 N1 N2 N3 N4 N5 N6 N7 N8 N9 " ++ "? ."
transSindhi :: Transliteration transSindhi :: Transliteration
transSindhi = transSindhi =
(mkTransliteration "Sindhi" allTrans allCodes) where (mkTransliteration "Sindhi" allTrans allCodes) where
allCodes = [0x062e] ++ [0x0627 .. 0x062f] ++ [0x0630 .. 0x063a] ++ [0x0641 .. 0x0648] ++ allCodes = [0x062e] ++ [0x0627 .. 0x062f] ++ [0x0630 .. 0x063a] ++ [0x0641 .. 0x0648] ++
[0x067a,0x067b,0x067d,0x067e,0x067f] ++ [0x0680 .. 0x068f] ++ [0x067a,0x067b,0x067d,0x067e,0x067f] ++ [0x0680 .. 0x068f] ++
[0x0699,0x0918,0x06a6,0x061d,0x06a9,0x06af,0x06b3,0x06bb,0x06be,0x06f6,0x064a,0x06b1, 0x06aa, 0x06fd, 0x06fe] ++ [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 $ allTrans = words $
"K a b - t C j H - d " ++ -- 0626 - 062f "K a b - t C j H - d " ++ -- 0626 - 062f
"Z r z s X S Z- t- z- e G " ++ -- 0630 - 063a "Z r z s X S Z- t- z- e G " ++ -- 0630 - 063a
"f q - L m n - W " ++ -- 0641 - 0648 "f q - L m n - W " ++ -- 0641 - 0648
"T! B T p T' " ++ -- 067a,067b,067d,067e,067f "T! B T p T' " ++ -- 067a,067b,067d,067e,067f
"B' - - Y' J' - c c' - - d! - d' D - D' " ++ -- 0680 - 068f "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 " ++ "? ." "N0 N1 N2 N3 N4 N5 N6 N7 N8 N9 " ++ "? ."
transArabic :: Transliteration transArabic :: Transliteration
transArabic = mkTransliteration "Arabic" allTrans allCodes where 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 "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 " 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 "i v2 o a: V+ V- i: a+ " ++ -- 0650 - 0657
"A* q?" -- 0671 (used by AED) "A* q?" -- 0671 (used by AED)
allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++ allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++
[0x0641..0x064f] ++ [0x0650..0x0657] ++ [0x0671,0x061f] [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 " 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 "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 " 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" "p c^ J k g y q? Z0"
allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++ allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++
[0x0641..0x064f] ++ [0x0650..0x0657] ++ [0x0641..0x064f] ++ [0x0650..0x0657] ++
[0x067e,0x0686,0x0698,0x06a9,0x06af,0x06cc,0x061f,0x200c] [0x067e,0x0686,0x0698,0x06a9,0x06af,0x06cc,0x061f,0x200c]
transNepali :: Transliteration transNepali :: Transliteration
transNepali = mkTransliteration "Nepali" allTrans allCodes where transNepali = mkTransliteration "Nepali" allTrans allCodes where
allTrans = words $ allTrans = words $
"z+ z= " ++ "z+ z= " ++
"- V M h: - H A i: I: f F Z - - - e: " ++ "- 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 " ++ "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 " ++ "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 " ++ "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' " ++ "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 " ++ "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] allCodes = [0x0380 .. 0x03cf]
transAncientGreek :: Transliteration 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(~ " ++ "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(~ " ++ "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' e` e' h` h' i` i' o` o' y` y' w` w' - - " ++
"a|) a|( a|)` a|(` a|)' a|(' a|)~ a|(~ - - - - - - - - " ++ -- 1f80- "a|) a|( a|)` a|(` a|)' a|(' a|)~ a|(~ - - - - - - - - " ++ -- 1f80-
"h|) h|( h|)` h|(` h|)' h|(' h|)~ h|(~ - - - - - - - - " ++ -- 1f90- "h|) h|( h|)` h|(` h|)' h|(' h|)~ h|(~ - - - - - - - - " ++ -- 1f90-
"w|) w|( w|)` w|(` w|)' w|(' w|)~ w|(~ - - - - - - - - " ++ -- 1fa0- "w|) w|( w|)` w|(` w|)' w|(' w|)~ w|(~ - - - - - - - - " ++ -- 1fa0-
"a. a_ a|` a| a|' - a~ a|~ - - - - - - - - " ++ -- 1fb0- "a. a_ a|` a| a|' - a~ a|~ - - - - - - - - " ++ -- 1fb0-
"- - h|` h| h|' - h~ h|~ - - - - - - - - " ++ -- 1fc0- "- - h|` h| h|' - h~ h|~ - - - - - - - - " ++ -- 1fc0-
"i. i_ i=` i=' - - i~ i=~ - - - - - - - - " ++ -- 1fd0- "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- "- - w|` w| w|' - w~ w|~ - - - - - - - - " ++ -- 1ff0-
-- HL, Private Use Area Code Points (New Athena Unicode, Cardo, ALPHABETUM, Antioch) -- HL, Private Use Area Code Points (New Athena Unicode, Cardo, ALPHABETUM, Antioch)
-- see: http://apagreekkeys.org/technicalDetails.html -- see: http://apagreekkeys.org/technicalDetails.html
-- GreekKeys Support by Donald Mastronarde -- 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 "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 "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.) a.)` a.(' a.(` - - - " ++ -- eaf0-eaff
"a_' - - - a_) a_( - a_)' - a_(' a.' a.( a.)' - - - " ++ -- eb00-eb0f "a_' - - - a_) a_( - a_)' - a_(' a.' a.( a.)' - - - " ++ -- eb00-eb0f
"e_)~ e_(~ - - - - - e_~ - - - - - - - - " ++ -- eb20-eb2f "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.( i.` i.)` - i.(' i.(` - - - - - - - " ++ -- eb40-eb4f
"- - - - i_)` i_(` - i_)~ i_(~ - o_~ o_)~ o_(~ - - - " ++ -- eb50-eb5f "- - - - i_)` i_(` - i_)~ i_(~ - o_~ o_)~ o_(~ - - - " ++ -- eb50-eb5f
"y_` " ++ -- eb6f "y_` " ++ -- eb6f
"y_~ y_)` - - - y_(` - y_)~ y_(~ - y_' - - y_) y_( y_)' " ++ -- eb70-eb7f "y_~ y_)` - - - y_(` - y_)~ y_(~ - y_' - - y_) y_( y_)' " ++ -- eb70-eb7f
"y_(' y.' y.( y.` y.) y.)' - - y.)` y.(' y.(` - - - - - " -- eb80-eb8f "y_(' y.' y.( y.` y.) y.)' - - y.)` y.(' y.(` - - - - - " -- eb80-eb8f
allCodes = -- [0x00B0 .. 0x00Bf] allCodes = -- [0x00B0 .. 0x00Bf]
[0x0380 .. 0x03cf] ++ [0x1f00 .. 0x1fff] [0x0380 .. 0x03cf] ++ [0x1f00 .. 0x1fff]
++ [0xe1a0 .. 0xe1af] ++ [0xe1a0 .. 0xe1af]
++ [0xe1b0 .. 0xe1bf] ++ [0xe1b0 .. 0xe1bf]
++ [0xe1c0 .. 0xe1cf] ++ [0xe1c0 .. 0xe1cf]
++ [0xeaf0 .. 0xeaff] ++ [0xeaf0 .. 0xeaff]
@@ -297,36 +297,34 @@ transAncientGreek = mkTransliteration "ancient Greek" allTrans allCodes where
++ [0xeb50 .. 0xeb5f] ++ [0xeb6f] ++ [0xeb50 .. 0xeb5f] ++ [0xeb6f]
++ [0xeb70 .. 0xeb7f] ++ [0xeb70 .. 0xeb7f]
++ [0xeb80 .. 0xeb8f] ++ [0xeb80 .. 0xeb8f]
transAmharic :: Transliteration transAmharic :: Transliteration
transAmharic = mkTransliteration "Amharic" allTrans allCodes where transAmharic = mkTransliteration "Amharic" allTrans allCodes where
allTrans = words $
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* "++
" h. h- h' h( h) h h? h* l. l- l' l( l) l l? l* "++ " s. s- s' s( s) s s? s* r. r- r' r( r) r r? r* "++
" H. H- H' H( H) H H? H* m. m- m' m( m) m m? m* "++ " - - - - - - - - x. x- x' x( x) x x? x* "++
" s. s- s' s( s) s s? s* r. r- r' r( r) r r? r* "++ " q. q- q' q( q) q q? q* - - - - - - - - "++
" - - - - - - - - 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* "++
" b. b- b' b( b) b b? b* v. v- v' v( v) v v? v* "++ " X. X- X' X( X) X X? - - - - X* - - - - "++
" t. t- t' t( t) t t? t* c. c- c' c( c) c c? c* "++ " n. n- n' n( n) n n? n* N. N- N' N( N) N N? N* "++
" X. X- X' X( X) X X? - - - - X* - - - - "++ " a u i A E e o e* k. k- k' k( k) k k? - "++
" n. n- n' n( n) n n? n* N. N- N' N( N) N N? N* "++ " - - - k* - - - - - - - - - - - - "++
" a u i A E e o e* k. k- k' k( k) k k? - "++ " - - - - - - - - w. w- w' w( w) w w? w* "++
" - - - k* - - - - - - - - - - - - "++ " - - - - - - - - z. z- z' z( z) z z? z* "++
" - - - - - - - - w. w- w' w( w) w w? w* "++ " Z. Z- Z' Z( Z) Z Z? Z* y. y- y' y( y) y y? y* "++
" - - - - - - - - z. z- z' z( z) z z? z* "++ " d. d- d' d( d) d d? d* - - - - - - - - "++
" Z. Z- Z' Z( Z) Z Z? Z* y. y- y' y( y) y y? y* "++ " j. j- j' j( j) j j? j* g. g- g' g( g) g g? - "++
" d. d- d' d( d) d d? d* - - - - - - - - "++ " - - - g* - - - - - - - - - - - - "++
" j. j- j' j( j) j j? j* g. g- g' g( g) g g? - "++ " T. T- T' T( T) T T? T* C. C- C' C( C) C C? C* "++
" - - - g* - - - - - - - - - - - - "++ " P. P- P' P( P) P P? P* S. S- S' S( S) S S? S* "++
" T. T- T' T( T) T T? T* C. C- C' C( C) C C? C* "++ " - - - - - - - - f. f- f' f( f) f f? f*"++
" P. P- P' P( P) P P? P* S. S- S' S( S) S S? S* "++ " p. p- p' p( p) p p? p*"
" - - - - - - - - f. f- f' f( f) f f? f*"++ allCodes = [0x1200..0x1357]
" p. p- p' p( p) p p? p*"
allCodes = [0x1200..0x1357]
-- by Prasad 31/5/2013 -- by Prasad 31/5/2013
transSanskrit :: Transliteration transSanskrit :: Transliteration
transSanskrit = (mkTransliteration "Sanskrit" allTrans allCodes) {invisible_chars = ["a"]} where 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.Expr,
PGF2.Type PGF2.Type
build-depends: build-depends:
base >= 4.9.1 && <4.15, base >= 4.9.1 && < 4.15,
containers >= 0.5.7 && < 0.7, containers >= 0.5.7 && < 0.7,
pretty >= 1.1.3 && < 1.2 pretty >= 1.1.3 && < 1.2
default-language: Haskell2010 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 library
default-language: Haskell2010 default-language: Haskell2010
build-depends: build-depends:
base >= 4.9.1 && <4.15, base >= 4.9.1 && < 4.15,
array >= 0.5.1 && < 0.6, array >= 0.5.1 && < 0.6,
containers >= 0.5.7 && < 0.7, containers >= 0.5.7 && < 0.7,
bytestring >= 0.10.8 && < 0.11, bytestring >= 0.10.8 && < 0.11,