summaryrefslogtreecommitdiff
path: root/src/compiler/GF
diff options
context:
space:
mode:
authorJohn J. Camilleri <john@digitalgrammars.com>2021-07-07 09:40:41 +0200
committerJohn J. Camilleri <john@digitalgrammars.com>2021-07-07 09:40:41 +0200
commitf2e52d6f2c2bc90febceebdea0268b40ea37476c (patch)
tree710619761319d65c5d997ec008f57f9253eae5dd /src/compiler/GF
parenta2b23d5897b4c04b50cd222ce8f215e45a3b6e40 (diff)
Replace tabs for whitespace in source code
Diffstat (limited to 'src/compiler/GF')
-rw-r--r--src/compiler/GF/Compile/CFGtoPGF.hs12
-rw-r--r--src/compiler/GF/Compile/CheckGrammar.hs4
-rw-r--r--src/compiler/GF/Compile/Rename.hs26
-rw-r--r--src/compiler/GF/Compile/TypeCheck/Abstract.hs16
-rw-r--r--src/compiler/GF/Compile/TypeCheck/Concrete.hs1
-rw-r--r--src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs16
-rw-r--r--src/compiler/GF/Compile/TypeCheck/TC.hs88
-rw-r--r--src/compiler/GF/Compile/Update.hs66
-rw-r--r--src/compiler/GF/Data/BacktrackM.hs26
-rw-r--r--src/compiler/GF/Data/Graph.hs20
-rw-r--r--src/compiler/GF/Data/Graphviz.hs28
-rw-r--r--src/compiler/GF/Data/Operations.hs74
-rw-r--r--src/compiler/GF/Data/Relation.hs18
-rw-r--r--src/compiler/GF/Data/Utilities.hs10
-rw-r--r--src/compiler/GF/Grammar/Canonical.hs22
-rw-r--r--src/compiler/GF/Grammar/Lexer.x2
-rw-r--r--src/compiler/GF/Grammar/Lookup.hs26
-rw-r--r--src/compiler/GF/Grammar/PatternMatch.hs33
-rw-r--r--src/compiler/GF/Grammar/Printer.hs729
-rw-r--r--src/compiler/GF/Grammar/Values.hs19
-rw-r--r--src/compiler/GF/Infra/CheckM.hs12
-rw-r--r--src/compiler/GF/Interactive.hs2
-rw-r--r--src/compiler/GF/Speech/FiniteState.hs110
-rw-r--r--src/compiler/GF/Speech/GSL.hs6
-rw-r--r--src/compiler/GF/Speech/JSGF.hs7
-rw-r--r--src/compiler/GF/Speech/PGFToCFG.hs16
-rw-r--r--src/compiler/GF/Speech/SRG.hs50
-rw-r--r--src/compiler/GF/Speech/SRGS_ABNF.hs11
-rw-r--r--src/compiler/GF/Speech/SRGS_XML.hs24
-rw-r--r--src/compiler/GF/Text/Transliterations.hs132
30 files changed, 801 insertions, 805 deletions
diff --git a/src/compiler/GF/Compile/CFGtoPGF.hs b/src/compiler/GF/Compile/CFGtoPGF.hs
index f9ab8afcf..59448ce97 100644
--- a/src/compiler/GF/Compile/CFGtoPGF.hs
+++ b/src/compiler/GF/Compile/CFGtoPGF.hs
@@ -18,7 +18,7 @@ import Data.List
--------------------------
cf2pgf :: FilePath -> ParamCFG -> PGF
-cf2pgf fpath cf =
+cf2pgf fpath cf =
let pgf = PGF Map.empty aname (cf2abstr cf) (Map.singleton cname (cf2concr cf))
in updateProductionIndices pgf
where
@@ -33,7 +33,7 @@ cf2abstr cfg = Abstr aflags afuns acats
acats = Map.fromList [(cat, ([], [(0,mkRuleName rule) | rule <- rules], 0))
| (cat,rules) <- (Map.toList . Map.fromListWith (++))
- [(cat2id cat, catRules cfg cat) |
+ [(cat2id cat, catRules cfg cat) |
cat <- allCats' cfg]]
afuns = Map.fromList [(mkRuleName rule, (cftype [cat2id c | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)), 0, Nothing, 0))
| rule <- allRules cfg]
@@ -52,7 +52,7 @@ cf2concr cfg = Concr Map.empty Map.empty
cats = allCats' cfg
rules = allRules cfg
- sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] :
+ sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] :
map mkSequence rules)
sequences = listArray (0,Set.size sequences0-1) (Set.toList sequences0)
@@ -102,7 +102,7 @@ cf2concr cfg = Concr Map.empty Map.empty
mkLinDefRef (cat,_) =
(cat2fid cat 0,[0])
-
+
addProd prods (fid,prod) =
case IntMap.lookup fid prods of
Just set -> IntMap.insert fid (Set.insert prod set) prods
@@ -130,5 +130,5 @@ cf2concr cfg = Concr Map.empty Map.empty
mkRuleName rule =
case ruleName rule of
- CFObj n _ -> n
- _ -> wildCId
+ CFObj n _ -> n
+ _ -> wildCId
diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs
index 71bce96c4..7f053f85c 100644
--- a/src/compiler/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/GF/Compile/CheckGrammar.hs
@@ -175,7 +175,7 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
checkTyp gr typ
case md of
Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $
- checkDef gr (m,c) typ eq) eqs
+ checkDef gr (m,c) typ eq) eqs
Nothing -> return ()
return (AbsFun (Just (L loc typ)) ma md moper)
@@ -316,7 +316,7 @@ linTypeOfType cnc m typ = do
mkLinArg (i,(n,mc@(m,cat))) = do
val <- lookLin mc
let vars = mkRecType varLabel $ replicate n typeStr
- symb = argIdent n cat i
+ symb = argIdent n cat i
rec <- if n==0 then return val else
errIn (render ("extending" $$
nest 2 vars $$
diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs
index c7ea56b45..41b2cdc67 100644
--- a/src/compiler/GF/Compile/Rename.hs
+++ b/src/compiler/GF/Compile/Rename.hs
@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/05/30 18:39:44 $
+-- > CVS $Date: 2005/05/30 18:39:44 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.19 $
--
@@ -23,9 +23,9 @@
-----------------------------------------------------------------------------
module GF.Compile.Rename (
- renameSourceTerm,
- renameModule
- ) where
+ renameSourceTerm,
+ renameModule
+ ) where
import GF.Infra.Ident
import GF.Infra.CheckM
@@ -68,7 +68,7 @@ renameIdentTerm env = accumulateError (renameIdentTerm' env)
-- Fails immediately on error, makes it possible to try other possibilities
renameIdentTerm' :: Status -> Term -> Check Term
-renameIdentTerm' env@(act,imps) t0 =
+renameIdentTerm' env@(act,imps) t0 =
case t0 of
Vr c -> ident predefAbs c
Cn c -> ident (\_ s -> checkError s) c
@@ -85,8 +85,8 @@ renameIdentTerm' env@(act,imps) t0 =
_ -> return t0
where
opens = [st | (OSimple _,st) <- imps]
- qualifs = [(m, st) | (OQualif m _, st) <- imps] ++
- [(m, st) | (OQualif _ m, st) <- imps] ++
+ qualifs = [(m, st) | (OQualif m _, st) <- imps] ++
+ [(m, st) | (OQualif _ m, st) <- imps] ++
[(m, st) | (OSimple m, st) <- imps] -- qualif is always possible
-- this facility is mainly for BWC with GF1: you need not import PredefAbs
@@ -94,7 +94,7 @@ renameIdentTerm' env@(act,imps) t0 =
| isPredefCat c = return (Q (cPredefAbs,c))
| otherwise = checkError s
- ident alt c =
+ ident alt c =
case Map.lookup c act of
Just f -> return (f c)
_ -> case mapMaybe (Map.lookup c) opens of
@@ -157,7 +157,7 @@ modInfo2status (o,mo) = (o,tree2status o (jments mo))
self2status :: ModuleName -> ModuleInfo -> StatusMap
self2status c m = Map.mapWithKey (info2status (Just c)) (jments m)
-
+
renameInfo :: FilePath -> Status -> Module -> Ident -> Info -> Check Info
renameInfo cwd status (m,mi) i info =
case info of
@@ -208,7 +208,7 @@ renameTerm env vars = ren vars where
Abs b x t -> liftM (Abs b x) (ren (x:vs) t)
Prod bt x a b -> liftM2 (Prod bt x) (ren vs a) (ren (x:vs) b)
Typed a b -> liftM2 Typed (ren vs a) (ren vs b)
- Vr x
+ Vr x
| elem x vs -> return trm
| otherwise -> renid trm
Cn _ -> renid trm
@@ -219,7 +219,7 @@ renameTerm env vars = ren vars where
i' <- case i of
TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source
_ -> return i
- liftM (T i') $ mapM (renCase vs) cs
+ liftM (T i') $ mapM (renCase vs) cs
Let (x,(m,a)) b -> do
m' <- case m of
@@ -229,7 +229,7 @@ renameTerm env vars = ren vars where
b' <- ren (x:vs) b
return $ Let (x,(m',a')) b'
- P t@(Vr r) l -- Here we have $r.l$ and this is ambiguous it could be either
+ P t@(Vr r) l -- Here we have $r.l$ and this is ambiguous it could be either
-- record projection from variable or constant $r$ or qualified expression with module $r$
| elem r vs -> return trm -- try var proj first ..
| otherwise -> checks [ renid' (Q (MN r,label2ident l)) -- .. and qualified expression second.
@@ -331,7 +331,7 @@ renamePattern env patt =
renameContext :: Status -> Context -> Check Context
renameContext b = renc [] where
renc vs cont = case cont of
- (bt,x,t) : xts
+ (bt,x,t) : xts
| isWildIdent x -> do
t' <- ren vs t
xts' <- renc vs xts
diff --git a/src/compiler/GF/Compile/TypeCheck/Abstract.hs b/src/compiler/GF/Compile/TypeCheck/Abstract.hs
index 196e1a646..c76660259 100644
--- a/src/compiler/GF/Compile/TypeCheck/Abstract.hs
+++ b/src/compiler/GF/Compile/TypeCheck/Abstract.hs
@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/09/15 16:22:02 $
+-- > CVS $Date: 2005/09/15 16:22:02 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.16 $
--
@@ -13,11 +13,11 @@
-----------------------------------------------------------------------------
module GF.Compile.TypeCheck.Abstract (-- * top-level type checking functions; TC should not be called directly.
- checkContext,
- checkTyp,
- checkDef,
- checkConstrs,
- ) where
+ checkContext,
+ checkTyp,
+ checkDef,
+ checkConstrs,
+ ) where
import GF.Data.Operations
@@ -33,8 +33,8 @@ import GF.Text.Pretty
--import Control.Monad (foldM, liftM, liftM2)
-- | invariant way of creating TCEnv from context
-initTCEnv gamma =
- (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma)
+initTCEnv gamma =
+ (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma)
-- interface to TC type checker
diff --git a/src/compiler/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/GF/Compile/TypeCheck/Concrete.hs
index 380970405..e9420290a 100644
--- a/src/compiler/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/GF/Compile/TypeCheck/Concrete.hs
@@ -69,7 +69,6 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
lockRecType c t' ---- locking to be removed AR 20/6/2009
_ | ty == typeTok -> return typeStr
- _ | isPredefConstant ty -> return ty
_ -> composOp (comp g) ty
diff --git a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
index c32afa7a5..d85af5361 100644
--- a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
+++ b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
@@ -396,7 +396,7 @@ tcRecTypeFields ge scope ((l,ty):rs) mb_ty = do
return ((l,ty):rs,mb_ty)
-- | Invariant: if the third argument is (Just rho),
--- then rho is in weak-prenex form
+-- then rho is in weak-prenex form
instSigma :: GlobalEnv -> Scope -> Term -> Sigma -> Maybe Rho -> TcM (Term, Rho)
instSigma ge scope t ty1 Nothing = return (t,ty1) -- INST1
instSigma ge scope t ty1 (Just ty2) = do -- INST2
@@ -631,8 +631,8 @@ allBinders = [ identS [x] | x <- ['a'..'z'] ] ++
type Scope = [(Ident,Value)]
type Sigma = Value
-type Rho = Value -- No top-level ForAll
-type Tau = Value -- No ForAlls anywhere
+type Rho = Value -- No top-level ForAll
+type Tau = Value -- No ForAlls anywhere
data MetaValue
= Unbound Scope Sigma
@@ -724,8 +724,8 @@ getMetaVars loc sc_tys = do
go (Vr tv) acc = acc
go (App x y) acc = go x (go y acc)
go (Meta i) acc
- | i `elem` acc = acc
- | otherwise = i : acc
+ | i `elem` acc = acc
+ | otherwise = i : acc
go (Q _) acc = acc
go (QC _) acc = acc
go (Sort _) acc = acc
@@ -742,9 +742,9 @@ getFreeVars loc sc_tys = do
return (foldr (go []) [] tys)
where
go bound (Vr tv) acc
- | tv `elem` bound = acc
- | tv `elem` acc = acc
- | otherwise = tv : acc
+ | tv `elem` bound = acc
+ | tv `elem` acc = acc
+ | otherwise = tv : acc
go bound (App x y) acc = go bound x (go bound y acc)
go bound (Meta _) acc = acc
go bound (Q _) acc = acc
diff --git a/src/compiler/GF/Compile/TypeCheck/TC.hs b/src/compiler/GF/Compile/TypeCheck/TC.hs
index abcb24617..c0df83394 100644
--- a/src/compiler/GF/Compile/TypeCheck/TC.hs
+++ b/src/compiler/GF/Compile/TypeCheck/TC.hs
@@ -5,21 +5,22 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/10/02 20:50:19 $
+-- > CVS $Date: 2005/10/02 20:50:19 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.11 $
--
-- Thierry Coquand's type checking algorithm that creates a trace
-----------------------------------------------------------------------------
-module GF.Compile.TypeCheck.TC (AExp(..),
- Theory,
- checkExp,
- inferExp,
- checkBranch,
- eqVal,
- whnf
- ) where
+module GF.Compile.TypeCheck.TC (
+ AExp(..),
+ Theory,
+ checkExp,
+ inferExp,
+ checkBranch,
+ eqVal,
+ whnf
+ ) where
import GF.Data.Operations
import GF.Grammar
@@ -31,17 +32,17 @@ import Data.Maybe
import GF.Text.Pretty
data AExp =
- AVr Ident Val
+ AVr Ident Val
| ACn QIdent Val
- | AType
- | AInt Int
+ | AType
+ | AInt Int
| AFloat Double
| AStr String
| AMeta MetaId Val
| ALet (Ident,(Val,AExp)) AExp
- | AApp AExp AExp Val
- | AAbs Ident Val AExp
- | AProd Ident AExp AExp
+ | AApp AExp AExp Val
+ | AAbs Ident Val AExp
+ | AProd Ident AExp AExp
-- -- | AEqs [([Exp],AExp)] --- not used
| ARecType [ALabelling]
| AR [AAssign]
@@ -50,7 +51,7 @@ data AExp =
| AData Val
deriving (Eq,Show)
-type ALabelling = (Label, AExp)
+type ALabelling = (Label, AExp)
type AAssign = (Label, (Val, AExp))
type Theory = QIdent -> Err Val
@@ -71,7 +72,7 @@ whnf :: Val -> Err Val
whnf v = ---- errIn ("whnf" +++ prt v) $ ---- debug
case v of
VApp u w -> do
- u' <- whnf u
+ u' <- whnf u
w' <- whnf w
app u' w'
VClos env e -> eval env e
@@ -81,9 +82,9 @@ app :: Val -> Val -> Err Val
app u v = case u of
VClos env (Abs _ x e) -> eval ((x,v):env) e
_ -> return $ VApp u v
-
+
eval :: Env -> Term -> Err Val
-eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
+eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
case e of
Vr x -> lookupVar env x
Q c -> return $ VCn c
@@ -95,23 +96,23 @@ eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
_ -> return $ VClos env e
eqVal :: Int -> Val -> Val -> Err [(Val,Val)]
-eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $
+eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $
do
w1 <- whnf u1
- w2 <- whnf u2
+ w2 <- whnf u2
let v = VGen k
case (w1,w2) of
(VApp f1 a1, VApp f2 a2) -> liftM2 (++) (eqVal k f1 f2) (eqVal k a1 a2)
(VClos env1 (Abs _ x1 e1), VClos env2 (Abs _ x2 e2)) ->
eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2)
(VClos env1 (Prod _ x1 a1 e1), VClos env2 (Prod _ x2 a2 e2)) ->
- liftM2 (++)
+ liftM2 (++)
(eqVal k (VClos env1 a1) (VClos env2 a2))
(eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2))
(VGen i _, VGen j _) -> return [(w1,w2) | i /= j]
- (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j]
+ (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j]
--- thus ignore qualifications; valid because inheritance cannot
- --- be qualified. Simplifies annotation. AR 17/3/2005
+ --- be qualified. Simplifies annotation. AR 17/3/2005
_ -> return [(w1,w2) | w1 /= w2]
-- invariant: constraints are in whnf
@@ -127,10 +128,10 @@ checkExp th tenv@(k,rho,gamma) e ty = do
Abs _ x t -> case typ of
VClos env (Prod _ y a b) -> do
- a' <- whnf $ VClos env a ---
- (t',cs) <- checkExp th
- (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
- return (AAbs x a' t', cs)
+ a' <- whnf $ VClos env a ---
+ (t',cs) <- checkExp th
+ (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
+ return (AAbs x a' t', cs)
_ -> Bad (render ("function type expected for" <+> ppTerm Unqualified 0 e <+> "instead of" <+> ppValue Unqualified 0 typ))
Let (x, (mb_typ, e1)) e2 -> do
@@ -150,7 +151,7 @@ checkExp th tenv@(k,rho,gamma) e ty = do
(b',csb) <- checkType th (k+1, (x,v x):rho, (x,VClos rho a):gamma) b
return (AProd x a' b', csa ++ csb)
- R xs ->
+ R xs ->
case typ of
VRecType ys -> do case [l | (l,_) <- ys, isNothing (lookup l xs)] of
[] -> return ()
@@ -174,7 +175,7 @@ checkInferExp th tenv@(k,_,_) e typ = do
(e',w,cs1) <- inferExp th tenv e
cs2 <- eqVal k w typ
return (e',cs1 ++ cs2)
-
+
inferExp :: Theory -> TCEnv -> Term -> Err (AExp, Val, [(Val,Val)])
inferExp th tenv@(k,rho,gamma) e = case e of
Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x
@@ -200,13 +201,13 @@ inferExp th tenv@(k,rho,gamma) e = case e of
(e2,val2,cs2) <- inferExp th (k,rho,(x,val1):gamma) e2
return (ALet (x,(val1,e1)) e2, val2, cs1++cs2)
App f t -> do
- (f',w,csf) <- inferExp th tenv f
+ (f',w,csf) <- inferExp th tenv f
typ <- whnf w
case typ of
VClos env (Prod _ x a b) -> do
(a',csa) <- checkExp th tenv t (VClos env a)
- b' <- whnf $ VClos ((x,VClos rho t):env) b
- return $ (AApp f' a' b', b', csf ++ csa)
+ b' <- whnf $ VClos ((x,VClos rho t):env) b
+ return $ (AApp f' a' b', b', csf ++ csa)
_ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
_ -> Bad (render ("cannot infer type of expression" <+> ppTerm Unqualified 0 e))
@@ -232,9 +233,9 @@ checkAssign th tenv@(k,rho,gamma) typs (lbl,(Nothing,exp)) = do
return ((lbl,(val,aexp)),cs)
checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Term],AExp),[(Val,Val)])
-checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
- chB tenv' ps' ty
- where
+checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
+ chB tenv' ps' ty
+ where
(ps',_,rho2,k') = ps2ts k ps
tenv' = (k, rho2++rho, gamma) ---- k' ?
@@ -245,11 +246,11 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
typ <- whnf ty
case typ of
VClos env (Prod _ y a b) -> do
- a' <- whnf $ VClos env a
+ a' <- whnf $ VClos env a
(p', sigma, binds, cs1) <- checkP tenv p y a'
let tenv' = (length binds, sigma ++ rho, binds ++ gamma)
((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b)
- return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
+ return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
_ -> Bad (render ("Product expected for definiens" <+> ppTerm Unqualified 0 t <+> "instead of" <+> ppValue Unqualified 0 typ))
[] -> do
(e,cs) <- checkExp th tenv t ty
@@ -259,15 +260,15 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
let sigma = [(x, VGen i x) | ((x,_),i) <- zip delta [k..]]
return (VClos sigma t, sigma, delta, cs)
- ps2ts k = foldr p2t ([],0,[],k)
+ ps2ts k = foldr p2t ([],0,[],k)
p2t p (ps,i,g,k) = case p of
- PW -> (Meta i : ps, i+1,g,k)
+ PW -> (Meta i : ps, i+1,g,k)
PV x -> (Vr x : ps, i, upd x k g,k+1)
PAs x p -> p2t p (ps,i,g,k)
PString s -> (K s : ps, i, g, k)
PInt n -> (EInt n : ps, i, g, k)
PFloat n -> (EFloat n : ps, i, g, k)
- PP c xs -> (mkApp (Q c) xss : ps, j, g',k')
+ PP c xs -> (mkApp (Q c) xss : ps, j, g',k')
where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
PImplArg p -> p2t p (ps,i,g,k)
PTilde t -> (t : ps, i, g, k)
@@ -307,8 +308,8 @@ checkPatt th tenv exp val = do
case typ of
VClos env (Prod _ x a b) -> do
(a',_,csa) <- checkExpP tenv t (VClos env a)
- b' <- whnf $ VClos ((x,VClos rho t):env) b
- return $ (AApp f' a' b', b', csf ++ csa)
+ b' <- whnf $ VClos ((x,VClos rho t):env) b
+ return $ (AApp f' a' b', b', csf ++ csa)
_ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
_ -> Bad (render ("cannot typecheck pattern" <+> ppTerm Unqualified 0 exp))
@@ -321,4 +322,3 @@ mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)])
mkAnnot a ti = do
(v,cs) <- ti
return (a v, v, cs)
-
diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs
index 4399405b8..7bbe1d8dc 100644
--- a/src/compiler/GF/Compile/Update.hs
+++ b/src/compiler/GF/Compile/Update.hs
@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/05/30 18:39:44 $
+-- > CVS $Date: 2005/05/30 18:39:44 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.8 $
--
@@ -34,14 +34,14 @@ buildAnyTree :: Fail.MonadFail m => ModuleName -> [(Ident,Info)] -> m (Map.Map I
buildAnyTree m = go Map.empty
where
go map [] = return map
- go map ((c,j):is) = do
+ go map ((c,j):is) =
case Map.lookup c map of
Just i -> case unifyAnyInfo m i j of
- Ok k -> go (Map.insert c k map) is
- Bad _ -> fail $ render ("conflicting information in module"<+>m $$
- nest 4 (ppJudgement Qualified (c,i)) $$
- "and" $+$
- nest 4 (ppJudgement Qualified (c,j)))
+ Ok k -> go (Map.insert c k map) is
+ Bad _ -> fail $ render ("conflicting information in module"<+>m $$
+ nest 4 (ppJudgement Qualified (c,i)) $$
+ "and" $+$
+ nest 4 (ppJudgement Qualified (c,j)))
Nothing -> go (Map.insert c j map) is
extendModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
@@ -51,14 +51,14 @@ extendModule cwd gr (name,m)
---- Should be replaced by real control. AR 4/2/2005
| mstatus m == MSIncomplete && isModCnc m = return (name,m)
| otherwise = checkInModule cwd m NoLoc empty $ do
- m' <- foldM extOne m (mextend m)
+ m' <- foldM extOne m (mextend m)
return (name,m')
where
extOne mo (n,cond) = do
m0 <- lookupModule gr n
-- test that the module types match, and find out if the old is complete
- unless (sameMType (mtype m) (mtype mo))
+ unless (sameMType (mtype m) (mtype mo))
(checkError ("illegal extension type to module" <+> name))
let isCompl = isCompleteModule m0
@@ -67,7 +67,7 @@ extendModule cwd gr (name,m)
js1 <- extendMod gr isCompl ((n,m0), isInherited cond) name (jments mo)
-- if incomplete, throw away extension information
- return $
+ return $
if isCompl
then mo {jments = js1}
else mo {mextend= filter ((/=n) . fst) (mextend mo)
@@ -75,7 +75,7 @@ extendModule cwd gr (name,m)
,jments = js1
}
--- | rebuilding instance + interface, and "with" modules, prior to renaming.
+-- | rebuilding instance + interface, and "with" modules, prior to renaming.
-- AR 24/10/2003
rebuildModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_)) =
@@ -88,8 +88,8 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
-- add the information given in interface into an instance module
Nothing -> do
- unless (null is || mstatus mi == MSIncomplete)
- (checkError ("module" <+> i <+>
+ unless (null is || mstatus mi == MSIncomplete)
+ (checkError ("module" <+> i <+>
"has open interfaces and must therefore be declared incomplete"))
case mt of
MTInstance (i0,mincl) -> do
@@ -113,7 +113,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
let stat' = if all (flip elem infs) is
then MSComplete
else MSIncomplete
- unless (stat' == MSComplete || stat == MSIncomplete)
+ unless (stat' == MSComplete || stat == MSIncomplete)
(checkError ("module" <+> i <+> "remains incomplete"))
ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext
let ops1 = nub $
@@ -141,24 +141,24 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
extendMod :: Grammar ->
Bool -> (Module,Ident -> Bool) -> ModuleName ->
Map.Map Ident Info -> Check (Map.Map Ident Info)
-extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi)
+extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi)
where
try new (c,i0)
| not (cond c) = return new
| otherwise = case Map.lookup c new of
Just j -> case unifyAnyInfo name i j of
- Ok k -> return $ Map.insert c k new
- Bad _ -> do (base,j) <- case j of
- AnyInd _ m -> lookupOrigInfo gr (m,c)
- _ -> return (base,j)
- (name,i) <- case i of
+ Ok k -> return $ Map.insert c k new
+ Bad _ -> do (base,j) <- case j of
+ AnyInd _ m -> lookupOrigInfo gr (m,c)
+ _ -> return (base,j)
+ (name,i) <- case i of
AnyInd _ m -> lookupOrigInfo gr (m,c)
_ -> return (name,i)
- checkError ("cannot unify the information" $$
- nest 4 (ppJudgement Qualified (c,i)) $$
- "in module" <+> name <+> "with" $$
- nest 4 (ppJudgement Qualified (c,j)) $$
- "in module" <+> base)
+ checkError ("cannot unify the information" $$
+ nest 4 (ppJudgement Qualified (c,i)) $$
+ "in module" <+> name <+> "with" $$
+ nest 4 (ppJudgement Qualified (c,j)) $$
+ "in module" <+> base)
Nothing-> if isCompl
then return $ Map.insert c (indirInfo name i) new
else return $ Map.insert c i new
@@ -166,11 +166,11 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme
i = globalizeLoc (msrc mi) i0
indirInfo :: ModuleName -> Info -> Info
- indirInfo n info = AnyInd b n' where
+ indirInfo n info = AnyInd b n' where
(b,n') = case info of
ResValue _ -> (True,n)
ResParam _ _ -> (True,n)
- AbsFun _ _ Nothing _ -> (True,n)
+ AbsFun _ _ Nothing _ -> (True,n)
AnyInd b k -> (b,k)
_ -> (False,n) ---- canonical in Abs
@@ -194,24 +194,24 @@ globalizeLoc fpath i =
unifyAnyInfo :: ModuleName -> Info -> Info -> Err Info
unifyAnyInfo m i j = case (i,j) of
- (AbsCat mc1, AbsCat mc2) ->
+ (AbsCat mc1, AbsCat mc2) ->
liftM AbsCat (unifyMaybeL mc1 mc2)
- (AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) ->
+ (AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) ->
liftM4 AbsFun (unifyMaybeL mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) (unifyMaybe moper1 moper2) -- adding defs
(ResParam mt1 mv1, ResParam mt2 mv2) ->
liftM2 ResParam (unifyMaybeL mt1 mt2) (unifyMaybe mv1 mv2)
- (ResValue (L l1 t1), ResValue (L l2 t2))
+ (ResValue (L l1 t1), ResValue (L l2 t2))
| t1==t2 -> return (ResValue (L l1 t1))
| otherwise -> fail ""
(_, ResOverload ms t) | elem m ms ->
return $ ResOverload ms t
- (ResOper mt1 m1, ResOper mt2 m2) ->
+ (ResOper mt1 m1, ResOper mt2 m2) ->
liftM2 ResOper (unifyMaybeL mt1 mt2) (unifyMaybeL m1 m2)
- (CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) ->
+ (CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) ->
liftM5 CncCat (unifyMaybeL mc1 mc2) (unifyMaybeL md1 md2) (unifyMaybeL mr1 mr2) (unifyMaybeL mp1 mp2) (unifyMaybe mpmcfg1 mpmcfg2)
- (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) ->
+ (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) ->
liftM3 (CncFun m) (unifyMaybeL mt1 mt2) (unifyMaybeL md1 md2) (unifyMaybe mpmcfg1 mpmcfg2)
(AnyInd b1 m1, AnyInd b2 m2) -> do
diff --git a/src/compiler/GF/Data/BacktrackM.hs b/src/compiler/GF/Data/BacktrackM.hs
index 14cbf90d2..970de5c06 100644
--- a/src/compiler/GF/Data/BacktrackM.hs
+++ b/src/compiler/GF/Data/BacktrackM.hs
@@ -16,18 +16,18 @@
{-# LANGUAGE CPP #-}
module GF.Data.BacktrackM (
-- * the backtracking state monad
- BacktrackM,
- -- * monad specific utilities
- member,
- cut,
- -- * running the monad
- foldBM, runBM,
- foldSolutions, solutions,
- foldFinalStates, finalStates,
-
- -- * reexport the 'MonadState' class
- module Control.Monad.State.Class,
- ) where
+ BacktrackM,
+ -- * monad specific utilities
+ member,
+ cut,
+ -- * running the monad
+ foldBM, runBM,
+ foldSolutions, solutions,
+ foldFinalStates, finalStates,
+
+ -- * reexport the 'MonadState' class
+ module Control.Monad.State.Class,
+ ) where
import Data.List
import Control.Applicative
@@ -70,7 +70,7 @@ instance Applicative (BacktrackM s) where
instance Monad (BacktrackM s) where
return a = BM (\c s b -> c a s b)
BM m >>= k = BM (\c s b -> m (\a s b -> unBM (k a) c s b) s b)
- where unBM (BM m) = m
+ where unBM (BM m) = m
#if !(MIN_VERSION_base(4,13,0))
fail = Fail.fail
diff --git a/src/compiler/GF/Data/Graph.hs b/src/compiler/GF/Data/Graph.hs
index 797325bbb..fd8ec9d99 100644
--- a/src/compiler/GF/Data/Graph.hs
+++ b/src/compiler/GF/Data/Graph.hs
@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/11/10 16:43:44 $
+-- > CVS $Date: 2005/11/10 16:43:44 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.2 $
--
@@ -34,7 +34,7 @@ import Data.Set (Set)
import qualified Data.Set as Set
data Graph n a b = Graph [n] ![Node n a] ![Edge n b]
- deriving (Eq,Show)
+ deriving (Eq,Show)
type Node n a = (n,a)
type Edge n b = (n,n,b)
@@ -63,7 +63,7 @@ emap f (Graph c ns es) = Graph c ns [(x,y,f l) | (x,y,l) <- es]
-- | Add a node to the graph.
newNode :: a -- ^ Node label
- -> Graph n a b
+ -> Graph n a b
-> (Graph n a b,n) -- ^ Node graph and name of new node
newNode l (Graph (c:cs) ns es) = (Graph cs ((c,l):ns) es, c)
@@ -83,7 +83,7 @@ newEdges es g = foldl' (flip newEdge) g es
-- lazy version:
-- newEdges es' (Graph c ns es) = Graph c ns (es'++es)
-insertEdgeWith :: Eq n =>
+insertEdgeWith :: Eq n =>
(b -> b -> b) -> Edge n b -> Graph n a b -> Graph n a b
insertEdgeWith f e@(x,y,l) (Graph c ns es) = Graph c ns (h es)
where h [] = [e]
@@ -97,7 +97,7 @@ removeNode n = removeNodes (Set.singleton n)
-- | Remove a set of nodes and all edges to and from those nodes.
removeNodes :: Ord n => Set n -> Graph n a b -> Graph n a b
removeNodes xs (Graph c ns es) = Graph c ns' es'
- where
+ where
keepNode n = not (Set.member n xs)
ns' = [ x | x@(n,_) <- ns, keepNode n ]
es' = [ e | e@(f,t,_) <- es, keepNode f && keepNode t ]
@@ -105,7 +105,7 @@ removeNodes xs (Graph c ns es) = Graph c ns' es'
-- | Get a map of node names to info about each node.
nodeInfo :: Ord n => Graph n a b -> NodeInfo n a b
nodeInfo g = Map.fromList [ (n, (x, fn inc n, fn out n)) | (n,x) <- nodes g ]
- where
+ where
inc = groupEdgesBy edgeTo g
out = groupEdgesBy edgeFrom g
fn m n = fromMaybe [] (Map.lookup n m)
@@ -148,16 +148,16 @@ reverseGraph :: Graph n a b -> Graph n a b
reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ]
-- | Add the nodes from the second graph to the first graph.
--- The nodes in the second graph will be renamed using the name
+-- The nodes in the second graph will be renamed using the name
-- supply in the first graph.
-- This function is more efficient when the second graph
-- is smaller than the first.
-mergeGraphs :: Ord m => Graph n a b -> Graph m a b
+mergeGraphs :: Ord m => Graph n a b -> Graph m a b
-> (Graph n a b, m -> n) -- ^ The new graph and a function translating
-- the old names of nodes in the second graph
-- to names in the new graph.
mergeGraphs (Graph c ns1 es1) g2 = (Graph c' (ns2++ns1) (es2++es1), newName)
- where
+ where
(xs,c') = splitAt (length (nodes g2)) c
newNames = Map.fromList (zip (map fst (nodes g2)) xs)
newName n = fromJust $ Map.lookup n newNames
@@ -170,7 +170,7 @@ renameNodes :: (n -> m) -- ^ renaming function
-> Graph n a b -> Graph m a b
renameNodes newName c (Graph _ ns es) = Graph c ns' es'
where ns' = map' (\ (n,x) -> (newName n,x)) ns
- es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es
+ es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es
-- | A strict 'map'
map' :: (a -> b) -> [a] -> [b]
diff --git a/src/compiler/GF/Data/Graphviz.hs b/src/compiler/GF/Data/Graphviz.hs
index 411f76898..fa47bac67 100644
--- a/src/compiler/GF/Data/Graphviz.hs
+++ b/src/compiler/GF/Data/Graphviz.hs
@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/09/15 18:10:44 $
+-- > CVS $Date: 2005/09/15 18:10:44 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.2 $
--
@@ -13,14 +13,14 @@
-----------------------------------------------------------------------------
module GF.Data.Graphviz (
- Graph(..), GraphType(..),
- Node(..), Edge(..),
- Attr,
- addSubGraphs,
- setName,
- setAttr,
- prGraphviz
- ) where
+ Graph(..), GraphType(..),
+ Node(..), Edge(..),
+ Attr,
+ addSubGraphs,
+ setName,
+ setAttr,
+ prGraphviz
+ ) where
import Data.Char
@@ -70,14 +70,14 @@ prGraphviz g@(Graph t i _ _ _ _) =
graphtype t ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}\n"
prSubGraph :: Graph -> String
-prSubGraph g@(Graph _ i _ _ _ _) =
+prSubGraph g@(Graph _ i _ _ _ _) =
"subgraph" ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}"
prGraph :: Graph -> String
-prGraph (Graph t id at ns es ss) =
+prGraph (Graph t id at ns es ss) =
unlines $ map (++";") (map prAttr at
- ++ map prNode ns
- ++ map (prEdge t) es
+ ++ map prNode ns
+ ++ map (prEdge t) es
++ map prSubGraph ss)
graphtype :: GraphType -> String
@@ -96,7 +96,7 @@ edgeop Undirected = "--"
prAttrList :: [Attr] -> String
prAttrList [] = ""
-prAttrList at = "[" ++ join "," (map prAttr at) ++ "]"
+prAttrList at = "[" ++ join "," (map prAttr at) ++ "]"
prAttr :: Attr -> String
prAttr (n,v) = esc n ++ " = " ++ esc v
diff --git a/src/compiler/GF/Data/Operations.hs b/src/compiler/GF/Data/Operations.hs
index 08fa15c3e..e9b95f8ab 100644
--- a/src/compiler/GF/Data/Operations.hs
+++ b/src/compiler/GF/Data/Operations.hs
@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/11/11 16:12:41 $
+-- > CVS $Date: 2005/11/11 16:12:41 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.22 $
--
@@ -15,34 +15,34 @@
-----------------------------------------------------------------------------
module GF.Data.Operations (
- -- ** The Error monad
- Err(..), err, maybeErr, testErr, fromErr, errIn,
- lookupErr,
-
- -- ** Error monad class
- ErrorMonad(..), checks, --doUntil, allChecks, checkAgain,
- liftErr,
-
- -- ** Checking
- checkUnique, unifyMaybeBy, unifyMaybe,
-
- -- ** Monadic operations on lists and pairs
- mapPairsM, pairM,
-
- -- ** Printing
- indent, (+++), (++-), (++++), (+++-), (+++++),
- prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly,
- prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
- numberedParagraphs, prConjList, prIfEmpty, wrapLines,
-
- -- ** Topological sorting
- topoTest, topoTest2,
-
- -- ** Misc
- readIntArg,
- iterFix, chunks,
-
- ) where
+ -- ** The Error monad
+ Err(..), err, maybeErr, testErr, fromErr, errIn,
+ lookupErr,
+
+ -- ** Error monad class
+ ErrorMonad(..), checks, --doUntil, allChecks, checkAgain,
+ liftErr,
+
+ -- ** Checking
+ checkUnique, unifyMaybeBy, unifyMaybe,
+
+ -- ** Monadic operations on lists and pairs
+ mapPairsM, pairM,
+
+ -- ** Printing
+ indent, (+++), (++-), (++++), (+++-), (+++++),
+ prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly,
+ prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
+ numberedParagraphs, prConjList, prIfEmpty, wrapLines,
+
+ -- ** Topological sorting
+ topoTest, topoTest2,
+
+ -- ** Misc
+ readIntArg,
+ iterFix, chunks,
+
+ ) where
import Data.Char (isSpace, toUpper, isSpace, isDigit)
import Data.List (nub, partition, (\\))
@@ -107,7 +107,7 @@ indent i s = replicate i ' ' ++ s
(+++), (++-), (++++), (+++-), (+++++) :: String -> String -> String
a +++ b = a ++ " " ++ b
-a ++- "" = a
+a ++- "" = a
a ++- b = a +++ b
a ++++ b = a ++ "\n" ++ b
@@ -145,20 +145,20 @@ prCurly s = "{" ++ s ++ "}"
prBracket s = "[" ++ s ++ "]"
prArgList, prSemicList, prCurlyList :: [String] -> String
-prArgList = prParenth . prTList ","
+prArgList = prParenth . prTList ","
prSemicList = prTList " ; "
prCurlyList = prCurly . prSemicList
restoreEscapes :: String -> String
-restoreEscapes s =
- case s of
+restoreEscapes s =
+ case s of
[] -> []
'"' : t -> '\\' : '"' : restoreEscapes t
'\\': t -> '\\' : '\\' : restoreEscapes t
c : t -> c : restoreEscapes t
numberedParagraphs :: [[String]] -> [String]
-numberedParagraphs t = case t of
+numberedParagraphs t = case t of
[] -> []
p:[] -> p
_ -> concat [(show n ++ ".") : s | (n,s) <- zip [1..] t]
@@ -204,12 +204,12 @@ topoTest2 g0 = maybe (Right cycles) Left (tsort g)
([],[]) -> Just []
([],_) -> Nothing
(ns,rest) -> (leaves:) `fmap` tsort [(n,es \\ leaves) | (n,es)<-rest]
- where leaves = map fst ns
+ where leaves = map fst ns
-- | Fix point iterator (for computing e.g. transitive closures or reachability)
iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a]
-iterFix more start = iter start start
+iterFix more start = iter start start
where
iter old new = if (null new')
then old
@@ -241,7 +241,7 @@ liftErr e = err raise return e
{-
instance ErrorMonad (STM s) where
raise msg = STM (\s -> raise msg)
- handle (STM f) g = STM (\s -> (f s)
+ handle (STM f) g = STM (\s -> (f s)
`handle` (\e -> let STM g' = (g e) in
g' s))
diff --git a/src/compiler/GF/Data/Relation.hs b/src/compiler/GF/Data/Relation.hs
index 5a3e80e6f..62da769b5 100644
--- a/src/compiler/GF/Data/Relation.hs
+++ b/src/compiler/GF/Data/Relation.hs
@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/10/26 17:13:13 $
+-- > CVS $Date: 2005/10/26 17:13:13 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.1 $
--
@@ -83,7 +83,7 @@ transitiveClosure r = fix (Map.map growSet) r
where growSet ys = foldl Set.union ys (map (allRelated r) $ Set.toList ys)
reflexiveClosure_ :: Ord a => [a] -- ^ The set over which the relation is defined.
- -> Rel a -> Rel a
+ -> Rel a -> Rel a
reflexiveClosure_ u r = relates [(x,x) | x <- u] r
-- | Uses 'domain'
@@ -104,7 +104,7 @@ reflexiveElements :: Ord a => Rel a -> Set a
reflexiveElements r = Set.fromList [ x | (x,ys) <- Map.toList r, x `Set.member` ys ]
-- | Keep the related pairs for which the predicate is true.
-filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a
+filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a
filterRel p = fst . purgeEmpty . Map.mapWithKey (Set.filter . p)
-- | Remove keys that map to no elements.
@@ -112,16 +112,16 @@ purgeEmpty :: Ord a => Rel a -> (Rel a, Set a)
purgeEmpty r = let (r',r'') = Map.partition (not . Set.null) r
in (r', Map.keysSet r'')
--- | Get the equivalence classes from an equivalence relation.
+-- | Get the equivalence classes from an equivalence relation.
equivalenceClasses :: Ord a => Rel a -> [Set a]
equivalenceClasses r = equivalenceClasses_ (Map.keys r) r
where equivalenceClasses_ [] _ = []
equivalenceClasses_ (x:xs) r = ys:equivalenceClasses_ zs r
- where ys = allRelated r x
- zs = [x' | x' <- xs, not (x' `Set.member` ys)]
+ where ys = allRelated r x
+ zs = [x' | x' <- xs, not (x' `Set.member` ys)]
isTransitive :: Ord a => Rel a -> Bool
-isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r,
+isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r,
y <- Set.toList ys, z <- Set.toList (allRelated r y)]
isReflexive :: Ord a => Rel a -> Bool
@@ -181,7 +181,7 @@ remove x r = let (mss,r') = Map.updateLookupWithKey (\_ _ -> Nothing) x r
Nothing -> (r', Set.empty, Set.empty)
-- remove element from all incoming and outgoing sets
-- of other elements
- Just (is,os) ->
+ Just (is,os) ->
let r'' = foldr (\i -> Map.adjust (\ (is',os') -> (is', Set.delete x os')) i) r' $ Set.toList is
r''' = foldr (\o -> Map.adjust (\ (is',os') -> (Set.delete x is', os')) o) r'' $ Set.toList os
in (r''', is, os)
@@ -190,4 +190,4 @@ incoming :: Ord a => a -> Rel' a -> Set a
incoming x r = maybe Set.empty fst $ Map.lookup x r
--outgoing :: Ord a => a -> Rel' a -> Set a
---outgoing x r = maybe Set.empty snd $ Map.lookup x r \ No newline at end of file
+--outgoing x r = maybe Set.empty snd $ Map.lookup x r
diff --git a/src/compiler/GF/Data/Utilities.hs b/src/compiler/GF/Data/Utilities.hs
index 29ed329dc..913953b6e 100644
--- a/src/compiler/GF/Data/Utilities.hs
+++ b/src/compiler/GF/Data/Utilities.hs
@@ -4,7 +4,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/10/26 18:47:16 $
+-- > CVS $Date: 2005/10/26 18:47:16 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.6 $
--
@@ -33,7 +33,7 @@ longerThan n = not . notLongerThan n
lookupList :: Eq a => a -> [(a, b)] -> [b]
lookupList a [] = []
lookupList a (p:ps) | a == fst p = snd p : lookupList a ps
- | otherwise = lookupList a ps
+ | otherwise = lookupList a ps
split :: [a] -> ([a], [a])
split (x : y : as) = (x:xs, y:ys)
@@ -48,8 +48,8 @@ splitBy p (a : as) = if p a then (a:xs, ys) else (xs, a:ys)
foldMerge :: (a -> a -> a) -> a -> [a] -> a
foldMerge merge zero = fm
where fm [] = zero
- fm [a] = a
- fm abs = let (as, bs) = split abs in fm as `merge` fm bs
+ fm [a] = a
+ fm abs = let (as, bs) = split abs in fm as `merge` fm bs
select :: [a] -> [(a, [a])]
select [] = []
@@ -68,7 +68,7 @@ safeInit :: [a] -> [a]
safeInit [] = []
safeInit xs = init xs
--- | Sorts and then groups elements given an ordering of the
+-- | Sorts and then groups elements given an ordering of the
-- elements.
sortGroupBy :: (a -> a -> Ordering) -> [a] -> [[a]]
sortGroupBy f = groupBy (compareEq f) . sortBy f
diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs
index 80e9f5e7b..e62424f6a 100644
--- a/src/compiler/GF/Grammar/Canonical.hs
+++ b/src/compiler/GF/Grammar/Canonical.hs
@@ -45,12 +45,12 @@ data LincatDef = LincatDef CatId LinType deriving Show
data LinDef = LinDef FunId [VarId] LinValue deriving Show
-- | Linearization type, RHS of @lincat@
-data LinType = FloatType
- | IntType
+data LinType = FloatType
+ | IntType
| ParamType ParamType
| RecordType [RecordRowType]
- | StrType
- | TableType LinType LinType
+ | StrType
+ | TableType LinType LinType
| TupleType [LinType]
deriving (Eq,Ord,Show)
@@ -60,7 +60,7 @@ newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
data LinValue = ConcatValue LinValue LinValue
| LiteralValue LinLiteral
| ErrorValue String
- | ParamConstant ParamValue
+ | ParamConstant ParamValue
| PredefValue PredefId
| RecordValue [RecordRowValue]
| TableValue LinType [TableRowValue]
@@ -74,9 +74,9 @@ data LinValue = ConcatValue LinValue LinValue
| CommentedValue String LinValue
deriving (Eq,Ord,Show)
-data LinLiteral = FloatConstant Float
- | IntConstant Int
- | StrConstant String
+data LinLiteral = FloatConstant Float
+ | IntConstant Int
+ | StrConstant String
deriving (Eq,Ord,Show)
data LinPattern = ParamPattern ParamPattern
@@ -107,7 +107,7 @@ newtype PredefId = PredefId Id deriving (Eq,Ord,Show)
newtype LabelId = LabelId Id 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)
--------------------------------------------------------------------------------
@@ -250,7 +250,7 @@ instance PPA LinLiteral where
FloatConstant f -> pp f
IntConstant n -> pp n
StrConstant s -> doubleQuotes s -- hmm
-
+
instance RhsSeparator LinValue where rhsSep _ = pp "="
instance Pretty LinPattern where
@@ -265,7 +265,7 @@ instance PPA LinPattern where
ParamPattern pv -> ppA pv
RecordPattern r -> block r
TuplePattern ps -> "<"<>punctuate "," ps<>">"
- WildPattern -> pp "_"
+ WildPattern -> pp "_"
instance RhsSeparator LinPattern where rhsSep _ = pp "="
diff --git a/src/compiler/GF/Grammar/Lexer.x b/src/compiler/GF/Grammar/Lexer.x
index bde0aa064..365388726 100644
--- a/src/compiler/GF/Grammar/Lexer.x
+++ b/src/compiler/GF/Grammar/Lexer.x
@@ -267,7 +267,7 @@ type AlexInput2 = (AlexInput,AlexInput)
data ParseResult a
= POk AlexInput2 a
- | PFailed Posn -- The position of the error
+ | PFailed Posn -- The position of the error
String -- The error message
newtype P a = P { unP :: AlexInput2 -> ParseResult a }
diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs
index 9f774fb2c..97aa5639e 100644
--- a/src/compiler/GF/Grammar/Lookup.hs
+++ b/src/compiler/GF/Grammar/Lookup.hs
@@ -6,7 +6,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/10/27 13:21:53 $
+-- > CVS $Date: 2005/10/27 13:21:53 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.15 $
--
@@ -20,17 +20,17 @@ module GF.Grammar.Lookup (
lookupOrigInfo,
allOrigInfos,
lookupResDef, lookupResDefLoc,
- lookupResType,
+ lookupResType,
lookupOverload,
lookupOverloadTypes,
- lookupParamValues,
+ lookupParamValues,
allParamValues,
- lookupAbsDef,
- lookupLincat,
+ lookupAbsDef,
+ lookupLincat,
lookupFunType,
lookupCatContext,
allOpers, allOpersTo
- ) where
+ ) where
import GF.Data.Operations
import GF.Infra.Ident
@@ -69,7 +69,7 @@ lookupResDef gr x = fmap unLoc (lookupResDefLoc gr x)
lookupResDefLoc gr (m,c)
| isPredefCat c = fmap noLoc (lock c defLinType)
| otherwise = look m c
- where
+ where
look m c = do
info <- lookupQIdentInfo gr (m,c)
case info of
@@ -77,7 +77,7 @@ lookupResDefLoc gr (m,c)
ResOper _ Nothing -> return (noLoc (Q (m,c)))
CncCat (Just (L l ty)) _ _ _ _ -> fmap (L l) (lock c ty)
CncCat _ _ _ _ _ -> fmap noLoc (lock c defLinType)
-
+
CncFun (Just (cat,_,_)) (Just (L l tr)) _ _ -> fmap (L l) (unlock cat tr)
CncFun _ (Just ltr) _ _ -> return ltr
@@ -95,7 +95,7 @@ lookupResType gr (m,c) = do
-- used in reused concrete
CncCat _ _ _ _ _ -> return typeType
CncFun (Just (cat,cont,val)) _ _ _ -> do
- val' <- lock cat val
+ val' <- lock cat val
return $ mkProd cont val' []
AnyInd _ n -> lookupResType gr (n,c)
ResParam _ _ -> return typePType
@@ -111,7 +111,7 @@ lookupOverloadTypes gr id@(m,c) = do
-- used in reused concrete
CncCat _ _ _ _ _ -> ret typeType
CncFun (Just (cat,cont,val)) _ _ _ -> do
- val' <- lock cat val
+ val' <- lock cat val
ret $ mkProd cont val' []
ResParam _ _ -> ret typePType
ResValue (L _ t) -> ret t
@@ -130,8 +130,8 @@ lookupOverload gr (m,c) = do
case info of
ResOverload os tysts -> do
tss <- mapM (\x -> lookupOverload gr (x,c)) os
- return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) |
- (L _ ty,L _ tr) <- tysts] ++
+ return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) |
+ (L _ ty,L _ tr) <- tysts] ++
concat tss
AnyInd _ n -> lookupOverload gr (n,c)
@@ -216,7 +216,7 @@ lookupCatContext gr m c = do
-- notice that it only gives the modules that are reachable and the opers that are included
allOpers :: Grammar -> [(QIdent,Type,Location)]
-allOpers gr =
+allOpers gr =
[((m,op),typ,loc) |
(m,mi) <- maybe [] (allExtends gr) (greatestResource gr),
(op,info) <- Map.toList (jments mi),
diff --git a/src/compiler/GF/Grammar/PatternMatch.hs b/src/compiler/GF/Grammar/PatternMatch.hs
index 9ef191554..dc0a5d3a5 100644
--- a/src/compiler/GF/Grammar/PatternMatch.hs
+++ b/src/compiler/GF/Grammar/PatternMatch.hs
@@ -5,18 +5,19 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/10/12 12:38:29 $
+-- > CVS $Date: 2005/10/12 12:38:29 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.7 $
--
-- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003
-----------------------------------------------------------------------------
-module GF.Grammar.PatternMatch (matchPattern,
- testOvershadow,
- findMatch,
- measurePatt
- ) where
+module GF.Grammar.PatternMatch (
+ matchPattern,
+ testOvershadow,
+ findMatch,
+ measurePatt
+ ) where
import GF.Data.Operations
import GF.Grammar.Grammar
@@ -30,7 +31,7 @@ import GF.Text.Pretty
--import Debug.Trace
matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution)
-matchPattern pts term =
+matchPattern pts term =
if not (isInConstantForm term)
then raise (render ("variables occur in" <+> pp term))
else do
@@ -61,15 +62,15 @@ testOvershadow pts vs = do
findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution)
findMatch cases terms = case cases of
[] -> raise (render ("no applicable case for" <+> hsep (punctuate ',' terms)))
- (patts,_):_ | length patts /= length terms ->
- raise (render ("wrong number of args for patterns :" <+> hsep patts <+>
+ (patts,_):_ | length patts /= length terms ->
+ raise (render ("wrong number of args for patterns :" <+> hsep patts <+>
"cannot take" <+> hsep terms))
(patts,val):cc -> case mapM tryMatch (zip patts terms) of
Ok substs -> return (val, concat substs)
_ -> findMatch cc terms
tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
-tryMatch (p,t) = do
+tryMatch (p,t) = do
t' <- termForm t
trym p t'
where
@@ -83,26 +84,26 @@ tryMatch (p,t) = do
(PString s, ([],K i,[])) | s==i -> return []
(PInt s, ([],EInt i,[])) | s==i -> return []
(PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
- (PC p pp, ([], Con f, tt)) |
+ (PC p pp, ([], Con f, tt)) |
p `eqStrIdent` f && length pp == length tt ->
do matches <- mapM tryMatch (zip pp tt)
return (concat matches)
- (PP (q,p) pp, ([], QC (r,f), tt)) |
+ (PP (q,p) pp, ([], QC (r,f), tt)) |
-- q `eqStrIdent` r && --- not for inherited AR 10/10/2005
p `eqStrIdent` f && length pp == length tt ->
do matches <- mapM tryMatch (zip pp tt)
return (concat matches)
---- hack for AppPredef bug
- (PP (q,p) pp, ([], Q (r,f), tt)) |
- -- q `eqStrIdent` r && ---
+ (PP (q,p) pp, ([], Q (r,f), tt)) |
+ -- q `eqStrIdent` r && ---
p `eqStrIdent` f && length pp == length tt ->
do matches <- mapM tryMatch (zip pp tt)
return (concat matches)
(PR r, ([],R r',[])) |
all (`elem` map fst r') (map fst r) ->
- do matches <- mapM tryMatch
+ do matches <- mapM tryMatch
[(p,snd a) | (l,p) <- r, let Just a = lookup l r']
return (concat matches)
(PT _ p',_) -> trym p' t'
@@ -125,7 +126,7 @@ tryMatch (p,t) = do
(PMSeq mp1 mp2, ([],K s, [])) -> matchPMSeq mp1 mp2 s
(PRep p1, ([],K s, [])) -> checks [
- trym (foldr (const (PSeq p1)) (PString "")
+ trym (foldr (const (PSeq p1)) (PString "")
[1..n]) t' | n <- [0 .. length s]
] >>
return []
diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs
index 341dae39b..74fd511b7 100644
--- a/src/compiler/GF/Grammar/Printer.hs
+++ b/src/compiler/GF/Grammar/Printer.hs
@@ -1,365 +1,364 @@
-----------------------------------------------------------------------
--- |
--- Module : GF.Grammar.Printer
--- Maintainer : Krasimir Angelov
--- Stability : (stable)
--- Portability : (portable)
---
------------------------------------------------------------------------------
-
-{-# LANGUAGE FlexibleContexts #-}
-module GF.Grammar.Printer
- ( -- ** Pretty printing
- TermPrintQual(..)
- , ppModule
- , ppJudgement
- , ppParams
- , ppTerm
- , ppPatt
- , ppValue
- , ppConstrs
- , ppQIdent
- , ppMeta
- , getAbs
- ) where
-import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
-
-import GF.Infra.Ident
-import GF.Infra.Option
-import GF.Grammar.Values
-import GF.Grammar.Grammar
-
-import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq)
-
-import GF.Text.Pretty
-import Data.Maybe (isNothing)
-import Data.List (intersperse)
-import qualified Data.Map as Map
---import qualified Data.IntMap as IntMap
---import qualified Data.Set as Set
-import qualified Data.Array.IArray as Array
-
-data TermPrintQual
- = Terse | Unqualified | Qualified | Internal
- deriving Eq
-
-instance Pretty Grammar where
- pp = vcat . map (ppModule Qualified) . modules
-
-ppModule :: TermPrintQual -> SourceModule -> Doc
-ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
- hdr $$
- nest 2 (ppOptions opts $$
- vcat (map (ppJudgement q) (Map.toList jments)) $$
- maybe empty (ppSequences q) mseqs) $$
- ftr
- where
- hdr = complModDoc <+> modTypeDoc <+> '=' <+>
- hsep (intersperse (pp "**") $
- filter (not . isEmpty) $ [ commaPunct ppExtends exts
- , maybe empty ppWith with
- , if null opens
- then pp '{'
- else "open" <+> commaPunct ppOpenSpec opens <+> "in" <+> '{'
- ])
-
- ftr = '}'
-
- complModDoc =
- case mstat of
- MSComplete -> empty
- MSIncomplete -> pp "incomplete"
-
- modTypeDoc =
- case mtype of
- MTAbstract -> "abstract" <+> mn
- MTResource -> "resource" <+> mn
- MTConcrete abs -> "concrete" <+> mn <+> "of" <+> abs
- MTInterface -> "interface" <+> mn
- MTInstance ie -> "instance" <+> mn <+> "of" <+> ppExtends ie
-
- ppExtends (id,MIAll ) = pp id
- ppExtends (id,MIOnly incs) = id <+> brackets (commaPunct pp incs)
- ppExtends (id,MIExcept incs) = id <+> '-' <+> brackets (commaPunct pp incs)
-
- ppWith (id,ext,opens) = ppExtends (id,ext) <+> "with" <+> commaPunct ppInstSpec opens
-
-ppOptions opts =
- "flags" $$
- nest 2 (vcat [option <+> '=' <+> ppLit value <+> ';' | (option,value) <- optionsGFO opts])
-
-ppJudgement q (id, AbsCat pcont ) =
- "cat" <+> id <+>
- (case pcont of
- Just (L _ cont) -> hsep (map (ppDecl q) cont)
- Nothing -> empty) <+> ';'
-ppJudgement q (id, AbsFun ptype _ pexp poper) =
- let kind | isNothing pexp = "data"
- | poper == Just False = "oper"
- | otherwise = "fun"
- in
- (case ptype of
- Just (L _ typ) -> kind <+> id <+> ':' <+> ppTerm q 0 typ <+> ';'
- Nothing -> empty) $$
- (case pexp of
- Just [] -> empty
- Just eqs -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs]
- Nothing -> empty)
-ppJudgement q (id, ResParam pparams _) =
- "param" <+> id <+>
- (case pparams of
- Just (L _ ps) -> '=' <+> ppParams q ps
- _ -> empty) <+> ';'
-ppJudgement q (id, ResValue pvalue) =
- "-- param constructor" <+> id <+> ':' <+>
- (case pvalue of
- (L _ ty) -> ppTerm q 0 ty) <+> ';'
-ppJudgement q (id, ResOper ptype pexp) =
- "oper" <+> id <+>
- (case ptype of {Just (L _ t) -> ':' <+> ppTerm q 0 t; Nothing -> empty} $$
- case pexp of {Just (L _ e) -> '=' <+> ppTerm q 0 e; Nothing -> empty}) <+> ';'
-ppJudgement q (id, ResOverload ids defs) =
- "oper" <+> id <+> '=' <+>
- ("overload" <+> '{' $$
- nest 2 (vcat [id <+> (':' <+> ppTerm q 0 ty $$ '=' <+> ppTerm q 0 e <+> ';') | (L _ ty,L _ e) <- defs]) $$
- '}') <+> ';'
-ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) =
- (case pcat of
- Just (L _ typ) -> "lincat" <+> id <+> '=' <+> ppTerm q 0 typ <+> ';'
- Nothing -> empty) $$
- (case pdef of
- Just (L _ exp) -> "lindef" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
- Nothing -> empty) $$
- (case pref of
- Just (L _ exp) -> "linref" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
- Nothing -> empty) $$
- (case pprn of
- Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
- Nothing -> empty) $$
- (case (mpmcfg,q) of
- (Just (PMCFG prods funs),Internal)
- -> "pmcfg" <+> id <+> '=' <+> '{' $$
- nest 2 (vcat (map ppProduction prods) $$
- ' ' $$
- vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
- parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
- (Array.assocs funs))) $$
- '}'
- _ -> empty)
-ppJudgement q (id, CncFun ptype pdef pprn mpmcfg) =
- (case pdef of
- Just (L _ e) -> let (xs,e') = getAbs e
- in "lin" <+> id <+> hsep (map ppBind xs) <+> '=' <+> ppTerm q 0 e' <+> ';'
- Nothing -> empty) $$
- (case pprn of
- Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
- Nothing -> empty) $$
- (case (mpmcfg,q) of
- (Just (PMCFG prods funs),Internal)
- -> "pmcfg" <+> id <+> '=' <+> '{' $$
- nest 2 (vcat (map ppProduction prods) $$
- ' ' $$
- vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
- parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
- (Array.assocs funs))) $$
- '}'
- _ -> empty)
-ppJudgement q (id, AnyInd cann mid) =
- case q of
- Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
- _ -> empty
-
-instance Pretty Term where pp = ppTerm Unqualified 0
-
-ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e)
- in prec d 0 ('\\' <> commaPunct ppBind xs <+> "->" <+> ppTerm q 0 e')
-ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of
- ([],_) -> "table" <+> '{' $$
- nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
- '}'
- (vs,e) -> prec d 0 ("\\\\" <> commaPunct pp vs <+> "=>" <+> ppTerm q 0 e)
-ppTerm q d (T (TTyped t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
- nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
- '}'
-ppTerm q d (T (TComp t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
- nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
- '}'
-ppTerm q d (T (TWild t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
- nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
- '}'
-ppTerm q d (Prod bt x a b)= if x == identW && bt == Explicit
- then prec d 0 (ppTerm q 4 a <+> "->" <+> ppTerm q 0 b)
- else prec d 0 (parens (ppBind (bt,x) <+> ':' <+> ppTerm q 0 a) <+> "->" <+> ppTerm q 0 b)
-ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> "=>" <+> ppTerm q 0 vt)
-ppTerm q d (Let l e) = let (ls,e') = getLet e
- in prec d 0 ("let" <+> vcat (map (ppLocDef q) (l:ls)) $$ "in" <+> ppTerm q 0 e')
-ppTerm q d (Example e s)=prec d 0 ("in" <+> ppTerm q 5 e <+> str s)
-ppTerm q d (C e1 e2) =prec d 1 (hang (ppTerm q 2 e1) 2 ("++" <+> ppTerm q 1 e2))
-ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> '+' <+> ppTerm q 2 e2)
-ppTerm q d (S x y) = case x of
- T annot xs -> let e = case annot of
- TRaw -> y
- TTyped t -> Typed y t
- TComp t -> Typed y t
- TWild t -> Typed y t
- in "case" <+> ppTerm q 0 e <+>"of" <+> '{' $$
- nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
- '}'
- _ -> prec d 3 (hang (ppTerm q 3 x) 2 ("!" <+> ppTerm q 4 y))
-ppTerm q d (ExtR x y) = prec d 3 (ppTerm q 3 x <+> "**" <+> ppTerm q 4 y)
-ppTerm q d (App x y) = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y)
-ppTerm q d (V e es) = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))])
-ppTerm q d (FV es) = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))))
-ppTerm q d (AdHocOverload es) = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
-ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
-ppTerm q d (Strs es) = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
-ppTerm q d (EPatt p) = prec d 4 ('#' <+> ppPatt q 2 p)
-ppTerm q d (EPattType t)=prec d 4 ("pattern" <+> ppTerm q 0 t)
-ppTerm q d (P t l) = prec d 5 (ppTerm q 5 t <> '.' <> l)
-ppTerm q d (Cn id) = pp id
-ppTerm q d (Vr id) = pp id
-ppTerm q d (Q id) = ppQIdent q id
-ppTerm q d (QC id) = ppQIdent q id
-ppTerm q d (Sort id) = pp id
-ppTerm q d (K s) = str s
-ppTerm q d (EInt n) = pp n
-ppTerm q d (EFloat f) = pp f
-ppTerm q d (Meta i) = ppMeta i
-ppTerm q d (Empty) = pp "[]"
-ppTerm q d (R []) = pp "<>" -- to distinguish from {} empty RecType
-ppTerm q d (R xs) = braces (fsep (punctuate ';' [l <+>
- fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty},
- '=' <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))
-ppTerm q d (RecType xs)
- | q == Terse = case [cat | (l,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of
- [cat] -> pp cat
- _ -> doc
- | otherwise = doc
- where
- doc = braces (fsep (punctuate ';' [l <+> ':' <+> ppTerm q 0 t | (l,t) <- xs]))
-ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>'
-ppTerm q d (ImplArg e) = braces (ppTerm q 0 e)
-ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t)
-ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t)
-ppTerm q d (Error s) = prec d 4 ("Predef.error" <+> str s)
-
-ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e
-
-ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e
-
-instance Pretty Patt where pp = ppPatt Unqualified 0
-
-ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '|' <+> ppPatt q 1 p2)
-ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
-ppPatt q d (PMSeq (_,p1) (_,p2)) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
-ppPatt q d (PC f ps) = if null ps
- then pp f
- else prec d 1 (f <+> hsep (map (ppPatt q 3) ps))
-ppPatt q d (PP f ps) = if null ps
- then ppQIdent q f
- else prec d 1 (ppQIdent q f <+> hsep (map (ppPatt q 3) ps))
-ppPatt q d (PRep p) = prec d 1 (ppPatt q 3 p <> '*')
-ppPatt q d (PAs f p) = prec d 2 (f <> '@' <> ppPatt q 3 p)
-ppPatt q d (PNeg p) = prec d 2 ('-' <> ppPatt q 3 p)
-ppPatt q d (PChar) = pp '?'
-ppPatt q d (PChars s) = brackets (str s)
-ppPatt q d (PMacro id) = '#' <> id
-ppPatt q d (PM id) = '#' <> ppQIdent q id
-ppPatt q d PW = pp '_'
-ppPatt q d (PV id) = pp id
-ppPatt q d (PInt n) = pp n
-ppPatt q d (PFloat f) = pp f
-ppPatt q d (PString s) = str s
-ppPatt q d (PR xs) = braces (hsep (punctuate ';' [l <+> '=' <+> ppPatt q 0 e | (l,e) <- xs]))
-ppPatt q d (PImplArg p) = braces (ppPatt q 0 p)
-ppPatt q d (PTilde t) = prec d 2 ('~' <> ppTerm q 6 t)
-
-ppValue :: TermPrintQual -> Int -> Val -> Doc
-ppValue q d (VGen i x) = x <> "{-" <> i <> "-}" ---- latter part for debugging
-ppValue q d (VApp u v) = prec d 4 (ppValue q 4 u <+> ppValue q 5 v)
-ppValue q d (VCn (_,c)) = pp c
-ppValue q d (VClos env e) = case e of
- Meta _ -> ppTerm q d e <> ppEnv env
- _ -> ppTerm q d e ---- ++ prEnv env ---- for debugging
-ppValue q d (VRecType xs) = braces (hsep (punctuate ',' [l <> '=' <> ppValue q 0 v | (l,v) <- xs]))
-ppValue q d VType = pp "Type"
-
-ppConstrs :: Constraints -> [Doc]
-ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> "<>" <+> ppValue Unqualified 0 w))
-
-ppEnv :: Env -> Doc
-ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e)
-
-str s = doubleQuotes s
-
-ppDecl q (_,id,typ)
- | id == identW = ppTerm q 3 typ
- | otherwise = parens (id <+> ':' <+> ppTerm q 0 typ)
-
-ppDDecl q (_,id,typ)
- | id == identW = ppTerm q 6 typ
- | otherwise = parens (id <+> ':' <+> ppTerm q 0 typ)
-
-ppQIdent :: TermPrintQual -> QIdent -> Doc
-ppQIdent q (m,id) =
- case q of
- Terse -> pp id
- Unqualified -> pp id
- Qualified -> m <> '.' <> id
- Internal -> m <> '.' <> id
-
-
-instance Pretty Label where pp = pp . label2ident
-
-ppOpenSpec (OSimple id) = pp id
-ppOpenSpec (OQualif id n) = parens (id <+> '=' <+> n)
-
-ppInstSpec (id,n) = parens (id <+> '=' <+> n)
-
-ppLocDef q (id, (mbt, e)) =
- id <+>
- (case mbt of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty} <+> '=' <+> ppTerm q 0 e) <+> ';'
-
-ppBind (Explicit,v) = pp v
-ppBind (Implicit,v) = braces v
-
-ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
-
-ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps))
-ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
-
-ppProduction (Production fid funid args) =
- ppFId fid <+> "->" <+> ppFunId funid <>
- brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args)))
-
-ppSequences q seqsArr
- | null seqs || q /= Internal = empty
- | otherwise = "sequences" <+> '{' $$
- nest 2 (vcat (map ppSeq seqs)) $$
- '}'
- where
- seqs = Array.assocs seqsArr
-
-commaPunct f ds = (hcat (punctuate "," (map f ds)))
-
-prec d1 d2 doc
- | d1 > d2 = parens doc
- | otherwise = doc
-
-getAbs :: Term -> ([(BindType,Ident)], Term)
-getAbs (Abs bt v e) = let (xs,e') = getAbs e
- in ((bt,v):xs,e')
-getAbs e = ([],e)
-
-getCTable :: Term -> ([Ident], Term)
-getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e
- in (v:vs,e')
-getCTable (T TRaw [(PW, e)]) = let (vs,e') = getCTable e
- in (identW:vs,e')
-getCTable e = ([],e)
-
-getLet :: Term -> ([LocalDef], Term)
-getLet (Let l e) = let (ls,e') = getLet e
- in (l:ls,e')
-getLet e = ([],e)
-
+----------------------------------------------------------------------
+-- |
+-- Module : GF.Grammar.Printer
+-- Maintainer : Krasimir Angelov
+-- Stability : (stable)
+-- Portability : (portable)
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE FlexibleContexts #-}
+module GF.Grammar.Printer
+ ( -- ** Pretty printing
+ TermPrintQual(..)
+ , ppModule
+ , ppJudgement
+ , ppParams
+ , ppTerm
+ , ppPatt
+ , ppValue
+ , ppConstrs
+ , ppQIdent
+ , ppMeta
+ , getAbs
+ ) where
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
+
+import GF.Infra.Ident
+import GF.Infra.Option
+import GF.Grammar.Values
+import GF.Grammar.Grammar
+
+import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq)
+
+import GF.Text.Pretty
+import Data.Maybe (isNothing)
+import Data.List (intersperse)
+import qualified Data.Map as Map
+--import qualified Data.IntMap as IntMap
+--import qualified Data.Set as Set
+import qualified Data.Array.IArray as Array
+
+data TermPrintQual
+ = Terse | Unqualified | Qualified | Internal
+ deriving Eq
+
+instance Pretty Grammar where
+ pp = vcat . map (ppModule Qualified) . modules
+
+ppModule :: TermPrintQual -> SourceModule -> Doc
+ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
+ hdr $$
+ nest 2 (ppOptions opts $$
+ vcat (map (ppJudgement q) (Map.toList jments)) $$
+ maybe empty (ppSequences q) mseqs) $$
+ ftr
+ where
+ hdr = complModDoc <+> modTypeDoc <+> '=' <+>
+ hsep (intersperse (pp "**") $
+ filter (not . isEmpty) $ [ commaPunct ppExtends exts
+ , maybe empty ppWith with
+ , if null opens
+ then pp '{'
+ else "open" <+> commaPunct ppOpenSpec opens <+> "in" <+> '{'
+ ])
+
+ ftr = '}'
+
+ complModDoc =
+ case mstat of
+ MSComplete -> empty
+ MSIncomplete -> pp "incomplete"
+
+ modTypeDoc =
+ case mtype of
+ MTAbstract -> "abstract" <+> mn
+ MTResource -> "resource" <+> mn
+ MTConcrete abs -> "concrete" <+> mn <+> "of" <+> abs
+ MTInterface -> "interface" <+> mn
+ MTInstance ie -> "instance" <+> mn <+> "of" <+> ppExtends ie
+
+ ppExtends (id,MIAll ) = pp id
+ ppExtends (id,MIOnly incs) = id <+> brackets (commaPunct pp incs)
+ ppExtends (id,MIExcept incs) = id <+> '-' <+> brackets (commaPunct pp incs)
+
+ ppWith (id,ext,opens) = ppExtends (id,ext) <+> "with" <+> commaPunct ppInstSpec opens
+
+ppOptions opts =
+ "flags" $$
+ nest 2 (vcat [option <+> '=' <+> ppLit value <+> ';' | (option,value) <- optionsGFO opts])
+
+ppJudgement q (id, AbsCat pcont ) =
+ "cat" <+> id <+>
+ (case pcont of
+ Just (L _ cont) -> hsep (map (ppDecl q) cont)
+ Nothing -> empty) <+> ';'
+ppJudgement q (id, AbsFun ptype _ pexp poper) =
+ let kind | isNothing pexp = "data"
+ | poper == Just False = "oper"
+ | otherwise = "fun"
+ in
+ (case ptype of
+ Just (L _ typ) -> kind <+> id <+> ':' <+> ppTerm q 0 typ <+> ';'
+ Nothing -> empty) $$
+ (case pexp of
+ Just [] -> empty
+ Just eqs -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs]
+ Nothing -> empty)
+ppJudgement q (id, ResParam pparams _) =
+ "param" <+> id <+>
+ (case pparams of
+ Just (L _ ps) -> '=' <+> ppParams q ps
+ _ -> empty) <+> ';'
+ppJudgement q (id, ResValue pvalue) =
+ "-- param constructor" <+> id <+> ':' <+>
+ (case pvalue of
+ (L _ ty) -> ppTerm q 0 ty) <+> ';'
+ppJudgement q (id, ResOper ptype pexp) =
+ "oper" <+> id <+>
+ (case ptype of {Just (L _ t) -> ':' <+> ppTerm q 0 t; Nothing -> empty} $$
+ case pexp of {Just (L _ e) -> '=' <+> ppTerm q 0 e; Nothing -> empty}) <+> ';'
+ppJudgement q (id, ResOverload ids defs) =
+ "oper" <+> id <+> '=' <+>
+ ("overload" <+> '{' $$
+ nest 2 (vcat [id <+> (':' <+> ppTerm q 0 ty $$ '=' <+> ppTerm q 0 e <+> ';') | (L _ ty,L _ e) <- defs]) $$
+ '}') <+> ';'
+ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) =
+ (case pcat of
+ Just (L _ typ) -> "lincat" <+> id <+> '=' <+> ppTerm q 0 typ <+> ';'
+ Nothing -> empty) $$
+ (case pdef of
+ Just (L _ exp) -> "lindef" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
+ Nothing -> empty) $$
+ (case pref of
+ Just (L _ exp) -> "linref" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
+ Nothing -> empty) $$
+ (case pprn of
+ Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
+ Nothing -> empty) $$
+ (case (mpmcfg,q) of
+ (Just (PMCFG prods funs),Internal)
+ -> "pmcfg" <+> id <+> '=' <+> '{' $$
+ nest 2 (vcat (map ppProduction prods) $$
+ ' ' $$
+ vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
+ parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
+ (Array.assocs funs))) $$
+ '}'
+ _ -> empty)
+ppJudgement q (id, CncFun ptype pdef pprn mpmcfg) =
+ (case pdef of
+ Just (L _ e) -> let (xs,e') = getAbs e
+ in "lin" <+> id <+> hsep (map ppBind xs) <+> '=' <+> ppTerm q 0 e' <+> ';'
+ Nothing -> empty) $$
+ (case pprn of
+ Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
+ Nothing -> empty) $$
+ (case (mpmcfg,q) of
+ (Just (PMCFG prods funs),Internal)
+ -> "pmcfg" <+> id <+> '=' <+> '{' $$
+ nest 2 (vcat (map ppProduction prods) $$
+ ' ' $$
+ vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
+ parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
+ (Array.assocs funs))) $$
+ '}'
+ _ -> empty)
+ppJudgement q (id, AnyInd cann mid) =
+ case q of
+ Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
+ _ -> empty
+
+instance Pretty Term where pp = ppTerm Unqualified 0
+
+ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e)
+ in prec d 0 ('\\' <> commaPunct ppBind xs <+> "->" <+> ppTerm q 0 e')
+ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of
+ ([],_) -> "table" <+> '{' $$
+ nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+ '}'
+ (vs,e) -> prec d 0 ("\\\\" <> commaPunct pp vs <+> "=>" <+> ppTerm q 0 e)
+ppTerm q d (T (TTyped t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
+ nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+ '}'
+ppTerm q d (T (TComp t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
+ nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+ '}'
+ppTerm q d (T (TWild t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
+ nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+ '}'
+ppTerm q d (Prod bt x a b)= if x == identW && bt == Explicit
+ then prec d 0 (ppTerm q 4 a <+> "->" <+> ppTerm q 0 b)
+ else prec d 0 (parens (ppBind (bt,x) <+> ':' <+> ppTerm q 0 a) <+> "->" <+> ppTerm q 0 b)
+ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> "=>" <+> ppTerm q 0 vt)
+ppTerm q d (Let l e) = let (ls,e') = getLet e
+ in prec d 0 ("let" <+> vcat (map (ppLocDef q) (l:ls)) $$ "in" <+> ppTerm q 0 e')
+ppTerm q d (Example e s)=prec d 0 ("in" <+> ppTerm q 5 e <+> str s)
+ppTerm q d (C e1 e2) =prec d 1 (hang (ppTerm q 2 e1) 2 ("++" <+> ppTerm q 1 e2))
+ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> '+' <+> ppTerm q 2 e2)
+ppTerm q d (S x y) = case x of
+ T annot xs -> let e = case annot of
+ TRaw -> y
+ TTyped t -> Typed y t
+ TComp t -> Typed y t
+ TWild t -> Typed y t
+ in "case" <+> ppTerm q 0 e <+>"of" <+> '{' $$
+ nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+ '}'
+ _ -> prec d 3 (hang (ppTerm q 3 x) 2 ("!" <+> ppTerm q 4 y))
+ppTerm q d (ExtR x y) = prec d 3 (ppTerm q 3 x <+> "**" <+> ppTerm q 4 y)
+ppTerm q d (App x y) = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y)
+ppTerm q d (V e es) = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))])
+ppTerm q d (FV es) = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))))
+ppTerm q d (AdHocOverload es) = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
+ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
+ppTerm q d (Strs es) = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
+ppTerm q d (EPatt p) = prec d 4 ('#' <+> ppPatt q 2 p)
+ppTerm q d (EPattType t)=prec d 4 ("pattern" <+> ppTerm q 0 t)
+ppTerm q d (P t l) = prec d 5 (ppTerm q 5 t <> '.' <> l)
+ppTerm q d (Cn id) = pp id
+ppTerm q d (Vr id) = pp id
+ppTerm q d (Q id) = ppQIdent q id
+ppTerm q d (QC id) = ppQIdent q id
+ppTerm q d (Sort id) = pp id
+ppTerm q d (K s) = str s
+ppTerm q d (EInt n) = pp n
+ppTerm q d (EFloat f) = pp f
+ppTerm q d (Meta i) = ppMeta i
+ppTerm q d (Empty) = pp "[]"
+ppTerm q d (R []) = pp "<>" -- to distinguish from {} empty RecType
+ppTerm q d (R xs) = braces (fsep (punctuate ';' [l <+>
+ fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty},
+ '=' <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))
+ppTerm q d (RecType xs)
+ | q == Terse = case [cat | (l,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of
+ [cat] -> pp cat
+ _ -> doc
+ | otherwise = doc
+ where
+ doc = braces (fsep (punctuate ';' [l <+> ':' <+> ppTerm q 0 t | (l,t) <- xs]))
+ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>'
+ppTerm q d (ImplArg e) = braces (ppTerm q 0 e)
+ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t)
+ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t)
+ppTerm q d (Error s) = prec d 4 ("Predef.error" <+> str s)
+
+ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e
+
+ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e
+
+instance Pretty Patt where pp = ppPatt Unqualified 0
+
+ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '|' <+> ppPatt q 1 p2)
+ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
+ppPatt q d (PMSeq (_,p1) (_,p2)) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
+ppPatt q d (PC f ps) = if null ps
+ then pp f
+ else prec d 1 (f <+> hsep (map (ppPatt q 3) ps))
+ppPatt q d (PP f ps) = if null ps
+ then ppQIdent q f
+ else prec d 1 (ppQIdent q f <+> hsep (map (ppPatt q 3) ps))
+ppPatt q d (PRep p) = prec d 1 (ppPatt q 3 p <> '*')
+ppPatt q d (PAs f p) = prec d 2 (f <> '@' <> ppPatt q 3 p)
+ppPatt q d (PNeg p) = prec d 2 ('-' <> ppPatt q 3 p)
+ppPatt q d (PChar) = pp '?'
+ppPatt q d (PChars s) = brackets (str s)
+ppPatt q d (PMacro id) = '#' <> id
+ppPatt q d (PM id) = '#' <> ppQIdent q id
+ppPatt q d PW = pp '_'
+ppPatt q d (PV id) = pp id
+ppPatt q d (PInt n) = pp n
+ppPatt q d (PFloat f) = pp f
+ppPatt q d (PString s) = str s
+ppPatt q d (PR xs) = braces (hsep (punctuate ';' [l <+> '=' <+> ppPatt q 0 e | (l,e) <- xs]))
+ppPatt q d (PImplArg p) = braces (ppPatt q 0 p)
+ppPatt q d (PTilde t) = prec d 2 ('~' <> ppTerm q 6 t)
+
+ppValue :: TermPrintQual -> Int -> Val -> Doc
+ppValue q d (VGen i x) = x <> "{-" <> i <> "-}" ---- latter part for debugging
+ppValue q d (VApp u v) = prec d 4 (ppValue q 4 u <+> ppValue q 5 v)
+ppValue q d (VCn (_,c)) = pp c
+ppValue q d (VClos env e) = case e of
+ Meta _ -> ppTerm q d e <> ppEnv env
+ _ -> ppTerm q d e ---- ++ prEnv env ---- for debugging
+ppValue q d (VRecType xs) = braces (hsep (punctuate ',' [l <> '=' <> ppValue q 0 v | (l,v) <- xs]))
+ppValue q d VType = pp "Type"
+
+ppConstrs :: Constraints -> [Doc]
+ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> "<>" <+> ppValue Unqualified 0 w))
+
+ppEnv :: Env -> Doc
+ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e)
+
+str s = doubleQuotes s
+
+ppDecl q (_,id,typ)
+ | id == identW = ppTerm q 3 typ
+ | otherwise = parens (id <+> ':' <+> ppTerm q 0 typ)
+
+ppDDecl q (_,id,typ)
+ | id == identW = ppTerm q 6 typ
+ | otherwise = parens (id <+> ':' <+> ppTerm q 0 typ)
+
+ppQIdent :: TermPrintQual -> QIdent -> Doc
+ppQIdent q (m,id) =
+ case q of
+ Terse -> pp id
+ Unqualified -> pp id
+ Qualified -> m <> '.' <> id
+ Internal -> m <> '.' <> id
+
+
+instance Pretty Label where pp = pp . label2ident
+
+ppOpenSpec (OSimple id) = pp id
+ppOpenSpec (OQualif id n) = parens (id <+> '=' <+> n)
+
+ppInstSpec (id,n) = parens (id <+> '=' <+> n)
+
+ppLocDef q (id, (mbt, e)) =
+ id <+>
+ (case mbt of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty} <+> '=' <+> ppTerm q 0 e) <+> ';'
+
+ppBind (Explicit,v) = pp v
+ppBind (Implicit,v) = braces v
+
+ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
+
+ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps))
+ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
+
+ppProduction (Production fid funid args) =
+ ppFId fid <+> "->" <+> ppFunId funid <>
+ brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args)))
+
+ppSequences q seqsArr
+ | null seqs || q /= Internal = empty
+ | otherwise = "sequences" <+> '{' $$
+ nest 2 (vcat (map ppSeq seqs)) $$
+ '}'
+ where
+ seqs = Array.assocs seqsArr
+
+commaPunct f ds = (hcat (punctuate "," (map f ds)))
+
+prec d1 d2 doc
+ | d1 > d2 = parens doc
+ | otherwise = doc
+
+getAbs :: Term -> ([(BindType,Ident)], Term)
+getAbs (Abs bt v e) = let (xs,e') = getAbs e
+ in ((bt,v):xs,e')
+getAbs e = ([],e)
+
+getCTable :: Term -> ([Ident], Term)
+getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e
+ in (v:vs,e')
+getCTable (T TRaw [(PW, e)]) = let (vs,e') = getCTable e
+ in (identW:vs,e')
+getCTable e = ([],e)
+
+getLet :: Term -> ([LocalDef], Term)
+getLet (Let l e) = let (ls,e') = getLet e
+ in (l:ls,e')
+getLet e = ([],e)
diff --git a/src/compiler/GF/Grammar/Values.hs b/src/compiler/GF/Grammar/Values.hs
index 3cfd79ad7..c8fcb3945 100644
--- a/src/compiler/GF/Grammar/Values.hs
+++ b/src/compiler/GF/Grammar/Values.hs
@@ -5,22 +5,23 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/04/21 16:22:32 $
+-- > CVS $Date: 2005/04/21 16:22:32 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.7 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
-module GF.Grammar.Values (-- ** Values used in TC type checking
- Val(..), Env,
- -- ** Annotated tree used in editing
+module GF.Grammar.Values (
+ -- ** Values used in TC type checking
+ Val(..), Env,
+ -- ** Annotated tree used in editing
Binds, Constraints, MetaSubst,
- -- ** For TC
- valAbsInt, valAbsFloat, valAbsString, vType,
- isPredefCat,
- eType,
- ) where
+ -- ** For TC
+ valAbsInt, valAbsFloat, valAbsString, vType,
+ isPredefCat,
+ eType,
+ ) where
import GF.Infra.Ident
import GF.Grammar.Grammar
diff --git a/src/compiler/GF/Infra/CheckM.hs b/src/compiler/GF/Infra/CheckM.hs
index c0234999a..a5ff7148a 100644
--- a/src/compiler/GF/Infra/CheckM.hs
+++ b/src/compiler/GF/Infra/CheckM.hs
@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/04/21 16:22:33 $
+-- > CVS $Date: 2005/04/21 16:22:33 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.5 $
--
@@ -14,10 +14,10 @@
module GF.Infra.CheckM
(Check, CheckResult, Message, runCheck, runCheck',
- checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
- checkIn, checkInModule, checkMap, checkMapRecover,
+ checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
+ checkIn, checkInModule, checkMap, checkMapRecover,
parallelCheck, accumulateError, commitCheck,
- ) where
+ ) where
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
import GF.Data.Operations
@@ -141,10 +141,10 @@ checkMapRecover f = fmap Map.fromList . parallelCheck . map f' . Map.toList
where f' (k,v) = fmap ((,)k) (f k v)
{-
-checkMapRecover f mp = do
+checkMapRecover f mp = do
let xs = map (\ (k,v) -> (k,runCheck (f k v))) (Map.toList mp)
case [s | (_,Bad s) <- xs] of
- ss@(_:_) -> checkError (text (unlines ss))
+ ss@(_:_) -> checkError (text (unlines ss))
_ -> do
let (kx,ss) = unzip [((k,x),s) | (k, Ok (x,s)) <- xs]
if not (all null ss) then checkWarn (text (unlines ss)) else return ()
diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs
index 855ab22d1..1ea62e4b3 100644
--- a/src/compiler/GF/Interactive.hs
+++ b/src/compiler/GF/Interactive.hs
@@ -433,7 +433,7 @@ wc_type = cmd_name
x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=' || c == '"') x1
cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of
- [x] -> Just x
+ [x] -> Just x
_ -> Nothing
isIdent c = c == '_' || c == '\'' || isAlphaNum c
diff --git a/src/compiler/GF/Speech/FiniteState.hs b/src/compiler/GF/Speech/FiniteState.hs
index cb5247755..95acd35c5 100644
--- a/src/compiler/GF/Speech/FiniteState.hs
+++ b/src/compiler/GF/Speech/FiniteState.hs
@@ -5,37 +5,37 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/11/10 16:43:44 $
+-- > CVS $Date: 2005/11/10 16:43:44 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.16 $
--
-- A simple finite state network module.
-----------------------------------------------------------------------------
module GF.Speech.FiniteState (FA(..), State, NFA, DFA,
- startState, finalStates,
- states, transitions,
+ startState, finalStates,
+ states, transitions,
isInternal,
- newFA, newFA_,
- addFinalState,
- newState, newStates,
+ newFA, newFA_,
+ addFinalState,
+ newState, newStates,
newTransition, newTransitions,
insertTransitionWith, insertTransitionsWith,
- mapStates, mapTransitions,
+ mapStates, mapTransitions,
modifyTransitions,
- nonLoopTransitionsTo, nonLoopTransitionsFrom,
+ nonLoopTransitionsTo, nonLoopTransitionsFrom,
loops,
removeState,
oneFinalState,
insertNFA,
onGraph,
- moveLabelsToNodes, removeTrivialEmptyNodes,
+ moveLabelsToNodes, removeTrivialEmptyNodes,
minimize,
dfa2nfa,
unusedNames, renameStates,
- prFAGraphviz, faToGraphviz) where
+ prFAGraphviz, faToGraphviz) where
import Data.List
-import Data.Maybe
+import Data.Maybe
--import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
@@ -98,13 +98,13 @@ newTransition f t l = onGraph (newEdge (f,t,l))
newTransitions :: [(n, n, b)] -> FA n a b -> FA n a b
newTransitions es = onGraph (newEdges es)
-insertTransitionWith :: Eq n =>
+insertTransitionWith :: Eq n =>
(b -> b -> b) -> (n, n, b) -> FA n a b -> FA n a b
insertTransitionWith f t = onGraph (insertEdgeWith f t)
-insertTransitionsWith :: Eq n =>
+insertTransitionsWith :: Eq n =>
(b -> b -> b) -> [(n, n, b)] -> FA n a b -> FA n a b
-insertTransitionsWith f ts fa =
+insertTransitionsWith f ts fa =
foldl' (flip (insertTransitionWith f)) fa ts
mapStates :: (a -> c) -> FA n a b -> FA n c b
@@ -128,11 +128,11 @@ unusedNames (FA (Graph names _ _) _ _) = names
-- | Gets all incoming transitions to a given state, excluding
-- transtions from the state itself.
nonLoopTransitionsTo :: Eq n => n -> FA n a b -> [(n,b)]
-nonLoopTransitionsTo s fa =
+nonLoopTransitionsTo s fa =
[(f,l) | (f,t,l) <- transitions fa, t == s && f /= s]
nonLoopTransitionsFrom :: Eq n => n -> FA n a b -> [(n,b)]
-nonLoopTransitionsFrom s fa =
+nonLoopTransitionsFrom s fa =
[(t,l) | (f,t,l) <- transitions fa, f == s && t /= s]
loops :: Eq n => n -> FA n a b -> [b]
@@ -145,7 +145,7 @@ renameStates :: Ord x => [y] -- ^ Infinite supply of new names
renameStates supply (FA g s fs) = FA (renameNodes newName rest g) s' fs'
where (ns,rest) = splitAt (length (nodes g)) supply
newNodes = Map.fromList (zip (map fst (nodes g)) ns)
- newName n = Map.findWithDefault (error "FiniteState.newName") n newNodes
+ newName n = Map.findWithDefault (error "FiniteState.newName") n newNodes
s' = newName s
fs' = map newName fs
@@ -154,9 +154,9 @@ insertNFA :: NFA a -- ^ NFA to insert into
-> (State, State) -- ^ States to insert between
-> NFA a -- ^ NFA to insert.
-> NFA a
-insertNFA (FA g1 s1 fs1) (f,t) (FA g2 s2 fs2)
+insertNFA (FA g1 s1 fs1) (f,t) (FA g2 s2 fs2)
= FA (newEdges es g') s1 fs1
- where
+ where
es = (f,ren s2,Nothing):[(ren f2,t,Nothing) | f2 <- fs2]
(g',ren) = mergeGraphs g1 g2
@@ -182,9 +182,9 @@ oneFinalState nl el fa =
moveLabelsToNodes :: (Ord n,Eq a) => FA n () (Maybe a) -> FA n (Maybe a) ()
moveLabelsToNodes = onGraph f
where f g@(Graph c _ _) = Graph c' ns (concat ess)
- where is = [ ((n,l),inc) | (n, (l,inc,_)) <- Map.toList (nodeInfo g)]
- (c',is') = mapAccumL fixIncoming c is
- (ns,ess) = unzip (concat is')
+ where is = [ ((n,l),inc) | (n, (l,inc,_)) <- Map.toList (nodeInfo g)]
+ (c',is') = mapAccumL fixIncoming c is
+ (ns,ess) = unzip (concat is')
-- | Remove empty nodes which are not start or final, and have
@@ -196,12 +196,12 @@ removeTrivialEmptyNodes = pruneUnusable . skipSimpleEmptyNodes
-- This is not done if the pointed-to node is a final node.
skipSimpleEmptyNodes :: (Eq a, Ord n) => FA n (Maybe a) () -> FA n (Maybe a) ()
skipSimpleEmptyNodes fa = onGraph og fa
- where
+ where
og g@(Graph c ns es) = if es' == es then g else og (Graph c ns es')
where
es' = concatMap changeEdge es
info = nodeInfo g
- changeEdge e@(f,t,())
+ changeEdge e@(f,t,())
| isNothing (getNodeLabel info t)
-- && (i * o <= i + o)
&& not (isFinal fa t)
@@ -223,28 +223,28 @@ pruneUnusable fa = onGraph f fa
where
f g = if Set.null rns then g else f (removeNodes rns g)
where info = nodeInfo g
- rns = Set.fromList [ n | (n,_) <- nodes g,
+ rns = Set.fromList [ n | (n,_) <- nodes g,
isInternal fa n,
- inDegree info n == 0
+ inDegree info n == 0
|| outDegree info n == 0]
-fixIncoming :: (Ord n, Eq a) => [n]
+fixIncoming :: (Ord n, Eq a) => [n]
-> (Node n (),[Edge n (Maybe a)]) -- ^ A node and its incoming edges
-> ([n],[(Node n (Maybe a),[Edge n ()])]) -- ^ Replacement nodes with their
-- incoming edges.
fixIncoming cs c@((n,()),es) = (cs'', ((n,Nothing),es'):newContexts)
where ls = nub $ map edgeLabel es
- (cs',cs'') = splitAt (length ls) cs
- newNodes = zip cs' ls
- es' = [ (x,n,()) | x <- map fst newNodes ]
- -- separate cyclic and non-cyclic edges
- (cyc,ncyc) = partition (\ (f,_,_) -> f == n) es
- -- keep all incoming non-cyclic edges with the right label
- to (x,l) = [ (f,x,()) | (f,_,l') <- ncyc, l == l']
- -- for each cyclic edge with the right label,
- -- add an edge from each of the new nodes (including this one)
- ++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes]
- newContexts = [ (v, to v) | v <- newNodes ]
+ (cs',cs'') = splitAt (length ls) cs
+ newNodes = zip cs' ls
+ es' = [ (x,n,()) | x <- map fst newNodes ]
+ -- separate cyclic and non-cyclic edges
+ (cyc,ncyc) = partition (\ (f,_,_) -> f == n) es
+ -- keep all incoming non-cyclic edges with the right label
+ to (x,l) = [ (f,x,()) | (f,_,l') <- ncyc, l == l']
+ -- for each cyclic edge with the right label,
+ -- add an edge from each of the new nodes (including this one)
+ ++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes]
+ newContexts = [ (v, to v) | v <- newNodes ]
--alphabet :: Eq b => Graph n a (Maybe b) -> [b]
--alphabet = nub . catMaybes . map edgeLabel . edges
@@ -254,19 +254,19 @@ determinize (FA g s f) = let (ns,es) = h (Set.singleton start) Set.empty Set.emp
(ns',es') = (Set.toList ns, Set.toList es)
final = filter isDFAFinal ns'
fa = FA (Graph undefined [(n,()) | n <- ns'] es') start final
- in renameStates [0..] fa
+ in renameStates [0..] fa
where info = nodeInfo g
-- reach = nodesReachable out
- start = closure info $ Set.singleton s
+ start = closure info $ Set.singleton s
isDFAFinal n = not (Set.null (Set.fromList f `Set.intersection` n))
- h currentStates oldStates es
- | Set.null currentStates = (oldStates,es)
- | otherwise = ((h $! uniqueNewStates) $! allOldStates) $! es'
- where
- allOldStates = oldStates `Set.union` currentStates
+ h currentStates oldStates es
+ | Set.null currentStates = (oldStates,es)
+ | otherwise = ((h $! uniqueNewStates) $! allOldStates) $! es'
+ where
+ allOldStates = oldStates `Set.union` currentStates
(newStates,es') = new (Set.toList currentStates) Set.empty es
- uniqueNewStates = newStates Set.\\ allOldStates
- -- Get the sets of states reachable from the given states
+ uniqueNewStates = newStates Set.\\ allOldStates
+ -- Get the sets of states reachable from the given states
-- by consuming one symbol, and the associated edges.
new [] rs es = (rs,es)
new (n:ns) rs es = new ns rs' es'
@@ -281,7 +281,7 @@ closure info x = closure_ x x
where closure_ acc check | Set.null check = acc
| otherwise = closure_ acc' check'
where
- reach = Set.fromList [y | x <- Set.toList check,
+ reach = Set.fromList [y | x <- Set.toList check,
(_,y,Nothing) <- getOutgoing info x]
acc' = acc `Set.union` reach
check' = reach Set.\\ acc
@@ -296,8 +296,8 @@ reachable1 info ns = Map.fromListWith (++) [(c, [y]) | n <- Set.toList ns, (_,y,
reverseNFA :: NFA a -> NFA a
reverseNFA (FA g s fs) = FA g''' s' [s]
where g' = reverseGraph g
- (g'',s') = newNode () g'
- g''' = newEdges [(s',f,Nothing) | f <- fs] g''
+ (g'',s') = newNode () g'
+ g''' = newEdges [(s',f,Nothing) | f <- fs] g''
dfa2nfa :: DFA a -> NFA a
dfa2nfa = mapTransitions Just
@@ -313,13 +313,13 @@ prFAGraphviz = Dot.prGraphviz . faToGraphviz
--prFAGraphviz_ = Dot.prGraphviz . faToGraphviz . mapStates show . mapTransitions show
faToGraphviz :: (Eq n,Show n) => FA n String String -> Dot.Graph
-faToGraphviz (FA (Graph _ ns es) s f)
+faToGraphviz (FA (Graph _ ns es) s f)
= Dot.Graph Dot.Directed Nothing [] (map mkNode ns) (map mkEdge es) []
where mkNode (n,l) = Dot.Node (show n) attrs
- where attrs = [("label",l)]
- ++ if n == s then [("shape","box")] else []
- ++ if n `elem` f then [("style","bold")] else []
- mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)]
+ where attrs = [("label",l)]
+ ++ if n == s then [("shape","box")] else []
+ ++ if n `elem` f then [("style","bold")] else []
+ mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)]
--
-- * Utilities
diff --git a/src/compiler/GF/Speech/GSL.hs b/src/compiler/GF/Speech/GSL.hs
index a898a4bb5..ceaf86ae0 100644
--- a/src/compiler/GF/Speech/GSL.hs
+++ b/src/compiler/GF/Speech/GSL.hs
@@ -26,14 +26,14 @@ width = 75
gslPrinter :: Options -> PGF -> CId -> String
gslPrinter opts pgf cnc = renderStyle st $ prGSL $ makeNonLeftRecursiveSRG opts pgf cnc
- where st = style { lineLength = width }
+ where st = style { lineLength = width }
prGSL :: SRG -> Doc
prGSL srg = header $++$ mainCat $++$ foldr ($++$) empty (map prRule (srgRules srg))
where
header = ";GSL2.0" $$
- comment ("Nuance speech recognition grammar for " ++ srgName srg) $$
- comment ("Generated by GF")
+ comment ("Nuance speech recognition grammar for " ++ srgName srg) $$
+ comment ("Generated by GF")
mainCat = ".MAIN" <+> prCat (srgStartCat srg)
prRule (SRGRule cat rhs) = prCat cat <+> union (map prAlt rhs)
-- FIXME: use the probability
diff --git a/src/compiler/GF/Speech/JSGF.hs b/src/compiler/GF/Speech/JSGF.hs
index 15f5ff69d..b12fb0ace 100644
--- a/src/compiler/GF/Speech/JSGF.hs
+++ b/src/compiler/GF/Speech/JSGF.hs
@@ -31,7 +31,7 @@ width :: Int
width = 75
jsgfPrinter :: Options
- -> PGF
+ -> PGF
-> CId -> String
jsgfPrinter opts pgf cnc = renderStyle st $ prJSGF sisr $ makeNonLeftRecursiveSRG opts pgf cnc
where st = style { lineLength = width }
@@ -44,7 +44,7 @@ prJSGF sisr srg
header = "#JSGF" <+> "V1.0" <+> "UTF-8" <+> lang <> ';' $$
comment ("JSGF speech recognition grammar for " ++ srgName srg) $$
comment "Generated by GF" $$
- ("grammar " ++ srgName srg ++ ";")
+ ("grammar " ++ srgName srg ++ ";")
lang = maybe empty pp (srgLanguage srg)
mainCat = rule True "MAIN" [prCat (srgStartCat srg)]
prRule (SRGRule cat rhs) = rule (isExternalCat srg cat) cat (map prAlt rhs)
@@ -62,7 +62,7 @@ prItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> Doc
prItem sisr t = f 0
where
f _ (REUnion []) = pp "<VOID>"
- f p (REUnion xs)
+ f p (REUnion xs)
| not (null es) = brackets (f 0 (REUnion nes))
| otherwise = (if p >= 1 then parens else id) (alts (map (f 1) xs))
where (es,nes) = partition isEpsilon xs
@@ -110,4 +110,3 @@ prepunctuate p (x:xs) = x : map (p <>) xs
($++$) :: Doc -> Doc -> Doc
x $++$ y = x $$ emptyLine $$ y
-
diff --git a/src/compiler/GF/Speech/PGFToCFG.hs b/src/compiler/GF/Speech/PGFToCFG.hs
index a8ecec27d..fdd8a6c84 100644
--- a/src/compiler/GF/Speech/PGFToCFG.hs
+++ b/src/compiler/GF/Speech/PGFToCFG.hs
@@ -28,7 +28,7 @@ toBNF f pgf cnc = prCFG $ f $ pgfToCFG pgf cnc
type Profile = [Int]
-pgfToCFG :: PGF
+pgfToCFG :: PGF
-> CId -- ^ Concrete syntax name
-> CFG
pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ concatMap ruleToCFRule rules)
@@ -40,8 +40,8 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
, prod <- Set.toList set]
fcatCats :: Map FId Cat
- fcatCats = Map.fromList [(fc, showCId c ++ "_" ++ show i)
- | (c,CncCat s e lbls) <- Map.toList (cnccats cnc),
+ fcatCats = Map.fromList [(fc, showCId c ++ "_" ++ show i)
+ | (c,CncCat s e lbls) <- Map.toList (cnccats cnc),
(fc,i) <- zip (range (s,e)) [1..]]
fcatCat :: FId -> Cat
@@ -58,7 +58,7 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
topdownRules cat = f cat []
where
f cat rules = maybe rules (Set.foldr g rules) (IntMap.lookup cat (productions cnc))
-
+
g (PApply funid args) rules = (cncfuns cnc ! funid,args) : rules
g (PCoerce cat) rules = f cat rules
@@ -67,13 +67,13 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
extCats = Set.fromList $ map ruleLhs startRules
startRules :: [CFRule]
- startRules = [Rule (showCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0)
- | (c,CncCat s e lbls) <- Map.toList (cnccats cnc),
+ startRules = [Rule (showCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0)
+ | (c,CncCat s e lbls) <- Map.toList (cnccats cnc),
fc <- range (s,e), not (isPredefFId fc),
r <- [0..catLinArity fc-1]]
ruleToCFRule :: (FId,Production) -> [CFRule]
- ruleToCFRule (c,PApply funid args) =
+ ruleToCFRule (c,PApply funid args) =
[Rule (fcatToCat c l) (mkRhs row) (profilesToTerm [fixProfile row n | n <- [0..length args-1]])
| (l,seqid) <- Array.assocs rhs
, let row = sequences cnc ! seqid
@@ -106,7 +106,7 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
fixProfile row i = [k | (k,j) <- nts, j == i]
where
nts = zip [0..] [j | nt <- Array.elems row, j <- getPos nt]
-
+
getPos (SymCat j _) = [j]
getPos (SymLit j _) = [j]
getPos _ = []
diff --git a/src/compiler/GF/Speech/SRG.hs b/src/compiler/GF/Speech/SRG.hs
index 9d51e52e9..b761c45cd 100644
--- a/src/compiler/GF/Speech/SRG.hs
+++ b/src/compiler/GF/Speech/SRG.hs
@@ -2,8 +2,8 @@
-- |
-- Module : SRG
--
--- Representation of, conversion to, and utilities for
--- printing of a general Speech Recognition Grammar.
+-- Representation of, conversion to, and utilities for
+-- printing of a general Speech Recognition Grammar.
--
-- FIXME: remove \/ warn \/ fail if there are int \/ string literal
-- categories in the grammar
@@ -40,20 +40,20 @@ import qualified Data.Set as Set
--import Debug.Trace
data SRG = SRG { srgName :: String -- ^ grammar name
- , srgStartCat :: Cat -- ^ start category name
- , srgExternalCats :: Set Cat
- , srgLanguage :: Maybe String -- ^ The language for which the grammar
- -- is intended, e.g. en-UK
- , srgRules :: [SRGRule]
- }
- deriving (Eq,Show)
+ , srgStartCat :: Cat -- ^ start category name
+ , srgExternalCats :: Set Cat
+ , srgLanguage :: Maybe String -- ^ The language for which the grammar
+ -- is intended, e.g. en-UK
+ , srgRules :: [SRGRule]
+ }
+ deriving (Eq,Show)
data SRGRule = SRGRule Cat [SRGAlt]
- deriving (Eq,Show)
+ deriving (Eq,Show)
-- | maybe a probability, a rule name and an EBNF right-hand side
data SRGAlt = SRGAlt (Maybe Double) CFTerm SRGItem
- deriving (Eq,Show)
+ deriving (Eq,Show)
type SRGItem = RE SRGSymbol
@@ -65,7 +65,7 @@ type SRGNT = (Cat, Int)
ebnfPrinter :: Options -> PGF -> CId -> String
ebnfPrinter opts pgf cnc = prSRG opts $ makeSRG opts pgf cnc
--- | Create a compact filtered non-left-recursive SRG.
+-- | Create a compact filtered non-left-recursive SRG.
makeNonLeftRecursiveSRG :: Options -> PGF -> CId -> SRG
makeNonLeftRecursiveSRG opts = makeSRG opts'
where
@@ -76,11 +76,11 @@ makeSRG opts = mkSRG cfgToSRG preprocess
where
cfgToSRG cfg = [cfRulesToSRGRule rs | (_,rs) <- allRulesGrouped cfg]
preprocess = maybeTransform opts CFGMergeIdentical mergeIdentical
- . maybeTransform opts CFGNoLR removeLeftRecursion
+ . maybeTransform opts CFGNoLR removeLeftRecursion
. maybeTransform opts CFGRegular makeRegular
. maybeTransform opts CFGTopDownFilter topDownFilter
. maybeTransform opts CFGBottomUpFilter bottomUpFilter
- . maybeTransform opts CFGRemoveCycles removeCycles
+ . maybeTransform opts CFGRemoveCycles removeCycles
. maybeTransform opts CFGStartCatOnly purgeExternalCats
setDefaultCFGTransform :: Options -> CFGTransform -> Bool -> Options
@@ -95,7 +95,7 @@ stats g = "Categories: " ++ show (countCats g)
++ ", External categories: " ++ show (Set.size (cfgExternalCats g))
++ ", Rules: " ++ show (countRules g)
-}
-makeNonRecursiveSRG :: Options
+makeNonRecursiveSRG :: Options
-> PGF
-> CId -- ^ Concrete syntax name.
-> SRG
@@ -111,26 +111,26 @@ makeNonRecursiveSRG opts = mkSRG cfgToSRG id
mkSRG :: (CFG -> [SRGRule]) -> (CFG -> CFG) -> PGF -> CId -> SRG
mkSRG mkRules preprocess pgf cnc =
SRG { srgName = showCId cnc,
- srgStartCat = cfgStartCat cfg,
+ srgStartCat = cfgStartCat cfg,
srgExternalCats = cfgExternalCats cfg,
srgLanguage = languageCode pgf cnc,
- srgRules = mkRules cfg }
+ srgRules = mkRules cfg }
where cfg = renameCats (showCId cnc) $ preprocess $ pgfToCFG pgf cnc
--- | Renames all external cats C to C_cat, and all internal cats C_X (where X is any string),
+-- | Renames all external cats C to C_cat, and all internal cats C_X (where X is any string),
-- to C_N where N is an integer.
renameCats :: String -> CFG -> CFG
renameCats prefix cfg = mapCFGCats renameCat cfg
where renameCat c | isExternal c = c ++ "_cat"
| otherwise = Map.findWithDefault (badCat c) c names
- isExternal c = c `Set.member` cfgExternalCats cfg
+ isExternal c = c `Set.member` cfgExternalCats cfg
catsByPrefix = buildMultiMap [(takeWhile (/='_') cat, cat) | cat <- allCats' cfg, not (isExternal cat)]
names = Map.fromList [(c,pref++"_"++show i) | (pref,cs) <- catsByPrefix, (c,i) <- zip cs [1..]]
badCat c = error ("GF.Speech.SRG.renameCats: " ++ c ++ "\n" ++ prCFG cfg)
cfRulesToSRGRule :: [CFRule] -> SRGRule
cfRulesToSRGRule rs@(r:_) = SRGRule (ruleLhs r) rhs
- where
+ where
alts = [((n,Nothing),mkSRGSymbols 0 ss) | Rule c ss n <- rs]
rhs = [SRGAlt p n (srgItem sss) | ((n,p),sss) <- buildMultiMap alts ]
@@ -153,7 +153,7 @@ srgItem = unionRE . map mergeItems . sortGroupBy (compareBy filterCats)
-- non-optimizing version:
--srgItem = unionRE . map seqRE
--- | Merges a list of right-hand sides which all have the same
+-- | Merges a list of right-hand sides which all have the same
-- sequence of non-terminals.
mergeItems :: [[SRGSymbol]] -> SRGItem
mergeItems = minimizeRE . ungroupTokens . minimizeRE . unionRE . map seqRE . map groupTokens
@@ -174,16 +174,16 @@ ungroupTokens = joinRE . mapRE (symbol (RESymbol . NonTerminal) (REConcat . map
prSRG :: Options -> SRG -> String
prSRG opts srg = prProductions $ map prRule $ ext ++ int
- where
+ where
sisr = flag optSISR opts
(ext,int) = partition (isExternalCat srg . srgLHSCat) (srgRules srg)
prRule (SRGRule c alts) = (c,unwords (intersperse "|" (concatMap prAlt alts)))
- prAlt (SRGAlt _ t rhs) =
- -- FIXME: hack: we high-jack the --sisr flag to add
+ prAlt (SRGAlt _ t rhs) =
+ -- FIXME: hack: we high-jack the --sisr flag to add
-- a simple lambda calculus format for semantic interpretation
-- Maybe the --sisr flag should be renamed.
case sisr of
- Just _ ->
+ Just _ ->
-- copy tags to each part of a top-level union,
-- to get simpler output
case rhs of
diff --git a/src/compiler/GF/Speech/SRGS_ABNF.hs b/src/compiler/GF/Speech/SRGS_ABNF.hs
index dc5c7bbd3..3db8fe7c2 100644
--- a/src/compiler/GF/Speech/SRGS_ABNF.hs
+++ b/src/compiler/GF/Speech/SRGS_ABNF.hs
@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/11/01 20:09:04 $
+-- > CVS $Date: 2005/11/01 20:09:04 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.16 $
--
@@ -38,7 +38,7 @@ width :: Int
width = 75
srgsAbnfPrinter :: Options
- -> PGF -> CId -> String
+ -> PGF -> CId -> String
srgsAbnfPrinter opts pgf cnc = showDoc $ prABNF sisr $ makeNonLeftRecursiveSRG opts pgf cnc
where sisr = flag optSISR opts
@@ -72,7 +72,7 @@ prItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> Doc
prItem sisr t = f 0
where
f _ (REUnion []) = pp "$VOID"
- f p (REUnion xs)
+ f p (REUnion xs)
| not (null es) = brackets (f 0 (REUnion nes))
| otherwise = (if p >= 1 then parens else id) (alts (map (f 1) xs))
where (es,nes) = partition isEpsilon xs
@@ -84,13 +84,13 @@ prItem sisr t = f 0
prSymbol :: Maybe SISRFormat -> CFTerm -> SRGSymbol -> Doc
prSymbol sisr cn (NonTerminal n@(c,_)) = prCat c <+> tag sisr (catSISR cn n)
-prSymbol _ cn (Terminal t)
+prSymbol _ cn (Terminal t)
| all isPunct t = empty -- removes punctuation
| otherwise = pp t -- FIXME: quote if there is whitespace or odd chars
tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> Doc
tag Nothing _ = empty
-tag (Just fmt) t =
+tag (Just fmt) t =
case t fmt of
[] -> empty
-- grr, silly SRGS ABNF does not have an escaping mechanism
@@ -125,4 +125,3 @@ prepunctuate p (x:xs) = x : map (p <>) xs
($++$) :: Doc -> Doc -> Doc
x $++$ y = x $$ emptyLine $$ y
-
diff --git a/src/compiler/GF/Speech/SRGS_XML.hs b/src/compiler/GF/Speech/SRGS_XML.hs
index 397bfb739..17d8eec5c 100644
--- a/src/compiler/GF/Speech/SRGS_XML.hs
+++ b/src/compiler/GF/Speech/SRGS_XML.hs
@@ -34,13 +34,13 @@ prSrgsXml :: Maybe SISRFormat -> SRG -> String
prSrgsXml sisr srg = showXMLDoc (optimizeSRGS xmlGr)
where
xmlGr = grammar sisr (srgStartCat srg) (srgLanguage srg) $
- [meta "description"
+ [meta "description"
("SRGS XML speech recognition grammar for " ++ srgName srg ++ "."),
meta "generator" "Grammatical Framework"]
- ++ map ruleToXML (srgRules srg)
+ ++ map ruleToXML (srgRules srg)
ruleToXML (SRGRule cat alts) = Tag "rule" ([("id",cat)]++pub) (prRhs alts)
where pub = if isExternalCat srg cat then [("scope","public")] else []
- prRhs rhss = [oneOf (map (mkProd sisr) rhss)]
+ prRhs rhss = [oneOf (map (mkProd sisr) rhss)]
mkProd :: Maybe SISRFormat -> SRGAlt -> XML
mkProd sisr (SRGAlt mp n rhs) = Tag "item" [] (ti ++ [x] ++ tf)
@@ -50,9 +50,9 @@ mkProd sisr (SRGAlt mp n rhs) = Tag "item" [] (ti ++ [x] ++ tf)
mkItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> XML
mkItem sisr cn = f
- where
+ where
f (REUnion []) = ETag "ruleref" [("special","VOID")]
- f (REUnion xs)
+ f (REUnion xs)
| not (null es) = Tag "item" [("repeat","0-1")] [f (REUnion nes)]
| otherwise = oneOf (map f xs)
where (es,nes) = partition isEpsilon xs
@@ -62,7 +62,7 @@ mkItem sisr cn = f
f (RESymbol s) = symItem sisr cn s
symItem :: Maybe SISRFormat -> CFTerm -> Symbol SRGNT Token -> XML
-symItem sisr cn (NonTerminal n@(c,_)) =
+symItem sisr cn (NonTerminal n@(c,_)) =
Tag "item" [] $ [ETag "ruleref" [("uri","#" ++ c)]] ++ tag sisr (catSISR cn n)
symItem _ _ (Terminal t) = Tag "item" [] [Data (showToken t)]
@@ -81,12 +81,12 @@ oneOf = Tag "one-of" []
grammar :: Maybe SISRFormat
-> String -- ^ root
-> Maybe String -- ^language
- -> [XML] -> XML
-grammar sisr root ml =
+ -> [XML] -> XML
+grammar sisr root ml =
Tag "grammar" $ [("xmlns","http://www.w3.org/2001/06/grammar"),
- ("version","1.0"),
- ("mode","voice"),
- ("root",root)]
+ ("version","1.0"),
+ ("mode","voice"),
+ ("root",root)]
++ (if isJust sisr then [("tag-format","semantics/1.0")] else [])
++ maybe [] (\l -> [("xml:lang", l)]) ml
@@ -94,7 +94,7 @@ meta :: String -> String -> XML
meta n c = ETag "meta" [("name",n),("content",c)]
optimizeSRGS :: XML -> XML
-optimizeSRGS = bottomUpXML f
+optimizeSRGS = bottomUpXML f
where f (Tag "item" [] [x@(Tag "item" _ _)]) = x
f (Tag "item" [] [x@(Tag "one-of" _ _)]) = x
f (Tag "item" as [Tag "item" [] xs]) = Tag "item" as xs
diff --git a/src/compiler/GF/Text/Transliterations.hs b/src/compiler/GF/Text/Transliterations.hs
index 9b1b6e151..8dbc02823 100644
--- a/src/compiler/GF/Text/Transliterations.hs
+++ b/src/compiler/GF/Text/Transliterations.hs
@@ -17,7 +17,7 @@ import qualified Data.Map as Map
-- to add a new one: define the Unicode range and the corresponding ASCII strings,
-- which may be one or more characters long
--- conventions to be followed:
+-- conventions to be followed:
-- each character is either [letter] or [letter+nonletters]
-- when using a sparse range of unicodes, mark missing codes as "-" in transliterations
-- characters can be invisible: ignored in translation to unicode
@@ -33,7 +33,7 @@ transliterateWithFile name src isFrom =
(if isFrom then appTransFromUnicode else appTransToUnicode) (getTransliterationFile name src)
transliteration :: String -> Maybe Transliteration
-transliteration s = Map.lookup s allTransliterations
+transliteration s = Map.lookup s allTransliterations
allTransliterations = Map.fromList [
("amharic",transAmharic),
@@ -67,25 +67,25 @@ data Transliteration = Trans {
}
appTransToUnicode :: Transliteration -> String -> String
-appTransToUnicode trans =
+appTransToUnicode trans =
concat .
map (\c -> maybe c (return . toEnum) $
Map.lookup c (trans_to_unicode trans)
- ) .
- filter (flip notElem (invisible_chars trans)) .
+ ) .
+ filter (flip notElem (invisible_chars trans)) .
unchar
appTransFromUnicode :: Transliteration -> String -> String
-appTransFromUnicode trans =
+appTransFromUnicode trans =
concat .
- map (\c -> maybe [toEnum c] id $
+ map (\c -> maybe [toEnum c] id $
Map.lookup c (trans_from_unicode trans)
- ) .
+ ) .
map fromEnum
mkTransliteration :: String -> [String] -> [Int] -> Transliteration
-mkTransliteration name ts us =
+mkTransliteration name ts us =
Trans (Map.fromList (tzip ts us)) (Map.fromList (uzip us ts)) [] name
where
tzip ts us = [(t,u) | (t,u) <- zip ts us, t /= "-"]
@@ -102,7 +102,7 @@ getTransliterationFile name = uncurry (mkTransliteration name) . codes
unchar :: String -> [String]
unchar s = case s of
- c:d:cs
+ c:d:cs
| isAlpha d -> [c] : unchar (d:cs)
| isSpace d -> [c]:[d]: unchar cs
| otherwise -> let (ds,cs2) = break (\x -> isAlpha x || isSpace x) cs in
@@ -122,8 +122,8 @@ transThai = mkTransliteration "Thai" allTrans allCodes where
allCodes = [0x0e00 .. 0x0e7f]
transDevanagari :: Transliteration
-transDevanagari =
- (mkTransliteration "Devanagari"
+transDevanagari =
+ (mkTransliteration "Devanagari"
allTransUrduHindi allCodes){invisible_chars = ["a"]} where
allCodes = [0x0900 .. 0x095f] ++ [0x0966 .. 0x096f]
@@ -136,13 +136,13 @@ allTransUrduHindi = words $
"- - - - - - - - q x g. z R R' f - " ++
"N0 N1 N2 N3 N4 N5 N6 N7 N8 N9 "
-
+
transUrdu :: Transliteration
-transUrdu =
+transUrdu =
(mkTransliteration "Urdu" allTrans allCodes) where
- allCodes = [0x0622 .. 0x062f] ++ [0x0630 .. 0x063a] ++ [0x0641,0x0642] ++ [0x06A9] ++ [0x0644 .. 0x0648] ++
+ allCodes = [0x0622 .. 0x062f] ++ [0x0630 .. 0x063a] ++ [0x0641,0x0642] ++ [0x06A9] ++ [0x0644 .. 0x0648] ++
[0x0654,0x0658,0x0679,0x067e,0x0686,0x0688,0x0691,0x0698,0x06af,0x06c1,0x06c3,0x06cc,0x06ba,0x06be,0x06d2] ++
- [0x06f0 .. 0x06f9] ++ [0x061f,0x06D4]
+ [0x06f0 .. 0x06f9] ++ [0x061f,0x06D4]
allTrans = words $
"A - w^ - y^ a b - t C j H K d " ++ -- 0622 - 062f
"Z r z s X S Z- t- z- e G " ++ -- 0630 - 063a
@@ -151,22 +151,22 @@ transUrdu =
"N0 N1 N2 N3 N4 N5 N6 N7 N8 N9 " ++ "? ."
transSindhi :: Transliteration
-transSindhi =
+transSindhi =
(mkTransliteration "Sindhi" allTrans allCodes) where
allCodes = [0x062e] ++ [0x0627 .. 0x062f] ++ [0x0630 .. 0x063a] ++ [0x0641 .. 0x0648] ++
[0x067a,0x067b,0x067d,0x067e,0x067f] ++ [0x0680 .. 0x068f] ++
[0x0699,0x0918,0x06a6,0x061d,0x06a9,0x06af,0x06b3,0x06bb,0x06be,0x06f6,0x064a,0x06b1, 0x06aa, 0x06fd, 0x06fe] ++
- [0x06f0 .. 0x06f9] ++ [0x061f,0x06D4]
+ [0x06f0 .. 0x06f9] ++ [0x061f,0x06D4]
allTrans = words $
"K a b - t C j H - d " ++ -- 0626 - 062f
"Z r z s X S Z- t- z- e G " ++ -- 0630 - 063a
"f q - L m n - W " ++ -- 0641 - 0648
"T! B T p T' " ++ -- 067a,067b,067d,067e,067f
"B' - - Y' J' - c c' - - d! - d' D - D' " ++ -- 0680 - 068f
- "R - F' - k' g G' t' h' e' y c! k A M " ++ -- 0699, 0918, 06a6, 061d, 06a9,06af,06b3,06bb,06be,06f6,06cc,06b1
+ "R - F' - k' g G' t' h' e' y c! k A M " ++ -- 0699, 0918, 06a6, 061d, 06a9,06af,06b3,06bb,06be,06f6,06cc,06b1
"N0 N1 N2 N3 N4 N5 N6 N7 N8 N9 " ++ "? ."
-
+
transArabic :: Transliteration
transArabic = mkTransliteration "Arabic" allTrans allCodes where
@@ -175,8 +175,8 @@ transArabic = mkTransliteration "Arabic" allTrans allCodes where
"W r z s C S D T Z c G " ++ -- 0630 - 063a
" f q k l m n h w y. y a. u. i. a u " ++ -- 0641 - 064f
"i v2 o a: V+ V- i: a+ " ++ -- 0650 - 0657
- "A* q?" -- 0671 (used by AED)
- allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++
+ "A* q?" -- 0671 (used by AED)
+ allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++
[0x0641..0x064f] ++ [0x0650..0x0657] ++ [0x0671,0x061f]
@@ -193,16 +193,16 @@ transPersian = (mkTransliteration "Persian/Farsi" allTrans allCodes)
" V A: A? w? A- y? A b t. t t- j H K d " ++ -- 0621 - 062f
"W r z s C S D T Z c G " ++ -- 0630 - 063a
" f q - l m n h v - y. a. u. i. a u " ++ -- 0640 - 064f
- "i v2 o a: V+ V- i: a+ " ++ -- 0650 - 0657
+ "i v2 o a: V+ V- i: a+ " ++ -- 0650 - 0657
"p c^ J k g y q? Z0"
- allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++
- [0x0641..0x064f] ++ [0x0650..0x0657] ++
+ allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++
+ [0x0641..0x064f] ++ [0x0650..0x0657] ++
[0x067e,0x0686,0x0698,0x06a9,0x06af,0x06cc,0x061f,0x200c]
transNepali :: Transliteration
transNepali = mkTransliteration "Nepali" allTrans allCodes where
allTrans = words $
- "z+ z= " ++
+ "z+ z= " ++
"- V M h: - H A i: I: f F Z - - - e: " ++
"E: - - O W k K g G n: C c j J Y q " ++
"Q x X N t T d D n - p P b B m y " ++
@@ -241,7 +241,7 @@ transGreek = mkTransliteration "modern Greek" allTrans allCodes where
"i= A B G D E Z H V I K L M N X O " ++
"P R - S T Y F C Q W I- Y- a' e' h' i' " ++
"y= a b g d e z h v i k l m n x o " ++
- "p r s* s t y f c q w i- y- o' y' w' - "
+ "p r s* s t y f c q w i- y- o' y' w' - "
allCodes = [0x0380 .. 0x03cf]
transAncientGreek :: Transliteration
@@ -261,32 +261,32 @@ transAncientGreek = mkTransliteration "ancient Greek" allTrans allCodes where
"y) y( y)` y(` y)' y(' y)~ y(~ - Y( - Y(` - Y(' - Y(~ " ++
"w) w( w)` w(` w)' w(' w)~ w(~ W) W( W)` W(` W)' W(' W)~ W(~ " ++
"a` a' e` e' h` h' i` i' o` o' y` y' w` w' - - " ++
- "a|) a|( a|)` a|(` a|)' a|(' a|)~ a|(~ - - - - - - - - " ++ -- 1f80-
- "h|) h|( h|)` h|(` h|)' h|(' h|)~ h|(~ - - - - - - - - " ++ -- 1f90-
- "w|) w|( w|)` w|(` w|)' w|(' w|)~ w|(~ - - - - - - - - " ++ -- 1fa0-
+ "a|) a|( a|)` a|(` a|)' a|(' a|)~ a|(~ - - - - - - - - " ++ -- 1f80-
+ "h|) h|( h|)` h|(` h|)' h|(' h|)~ h|(~ - - - - - - - - " ++ -- 1f90-
+ "w|) w|( w|)` w|(` w|)' w|(' w|)~ w|(~ - - - - - - - - " ++ -- 1fa0-
"a. a_ a|` a| a|' - a~ a|~ - - - - - - - - " ++ -- 1fb0-
"- - h|` h| h|' - h~ h|~ - - - - - - - - " ++ -- 1fc0-
"i. i_ i=` i=' - - i~ i=~ - - - - - - - - " ++ -- 1fd0-
- "y. y_ y=` y=' r) r( y~ y=~ - - - - - - - - " ++ -- 1fe0-
+ "y. y_ y=` y=' r) r( y~ y=~ - - - - - - - - " ++ -- 1fe0-
"- - w|` w| w|' - w~ w|~ - - - - - - - - " ++ -- 1ff0-
-- HL, Private Use Area Code Points (New Athena Unicode, Cardo, ALPHABETUM, Antioch)
-- see: http://apagreekkeys.org/technicalDetails.html
-- GreekKeys Support by Donald Mastronarde
- "- - - - - - - - - e. o. R) Y) Y)` Y)' Y)~ " ++ -- e1a0-e1af
+ "- - - - - - - - - e. o. R) Y) Y)` Y)' Y)~ " ++ -- e1a0-e1af
"e~ e)~ e(~ e_ e_' e_` e_) e_( e_)` e_(` e_)' e_(' E)~ E(~ E_ E. " ++ -- e1b0-e1bf
"o~ o)~ o(~ o_ o_' o_` o_) o_( o_)` o_(` o_)' o_(' O)~ O(~ O_ O. " ++ -- e1c0-e1cf
- "a_` - a_~ a_)` a_(` a_)~ a_(~ - a.` a.) a.)` a.(' a.(` - - - " ++ -- eaf0-eaff
- "a_' - - - a_) a_( - a_)' - a_(' a.' a.( a.)' - - - " ++ -- eb00-eb0f
+ "a_` - a_~ a_)` a_(` a_)~ a_(~ - a.` a.) a.)` a.(' a.(` - - - " ++ -- eaf0-eaff
+ "a_' - - - a_) a_( - a_)' - a_(' a.' a.( a.)' - - - " ++ -- eb00-eb0f
"e_)~ e_(~ - - - - - e_~ - - - - - - - - " ++ -- eb20-eb2f
- "- - - - - - i_~ - i_` i_' - - i_) i_)' i_( i_(' " ++ -- eb30-eb3f
+ "- - - - - - i_~ - i_` i_' - - i_) i_)' i_( i_(' " ++ -- eb30-eb3f
"i.' i.) i.)' i.( i.` i.)` - i.(' i.(` - - - - - - - " ++ -- eb40-eb4f
"- - - - i_)` i_(` - i_)~ i_(~ - o_~ o_)~ o_(~ - - - " ++ -- eb50-eb5f
"y_` " ++ -- eb6f
"y_~ y_)` - - - y_(` - y_)~ y_(~ - y_' - - y_) y_( y_)' " ++ -- eb70-eb7f
"y_(' y.' y.( y.` y.) y.)' - - y.)` y.(' y.(` - - - - - " -- eb80-eb8f
- allCodes = -- [0x00B0 .. 0x00Bf]
- [0x0380 .. 0x03cf] ++ [0x1f00 .. 0x1fff]
- ++ [0xe1a0 .. 0xe1af]
+ allCodes = -- [0x00B0 .. 0x00Bf]
+ [0x0380 .. 0x03cf] ++ [0x1f00 .. 0x1fff]
+ ++ [0xe1a0 .. 0xe1af]
++ [0xe1b0 .. 0xe1bf]
++ [0xe1c0 .. 0xe1cf]
++ [0xeaf0 .. 0xeaff]
@@ -297,36 +297,34 @@ transAncientGreek = mkTransliteration "ancient Greek" allTrans allCodes where
++ [0xeb50 .. 0xeb5f] ++ [0xeb6f]
++ [0xeb70 .. 0xeb7f]
++ [0xeb80 .. 0xeb8f]
-
-transAmharic :: Transliteration
+
+transAmharic :: Transliteration
transAmharic = mkTransliteration "Amharic" allTrans allCodes where
-
-allTrans = words $
-
- " h. h- h' h( h) h h? h* l. l- l' l( l) l l? l* "++
- " H. H- H' H( H) H H? H* m. m- m' m( m) m m? m* "++
- " s. s- s' s( s) s s? s* r. r- r' r( r) r r? r* "++
- " - - - - - - - - x. x- x' x( x) x x? x* "++
- " q. q- q' q( q) q q? q* - - - - - - - - "++
- " - - - - - - - - - - - - - - - - "++
- " b. b- b' b( b) b b? b* v. v- v' v( v) v v? v* "++
- " t. t- t' t( t) t t? t* c. c- c' c( c) c c? c* "++
- " X. X- X' X( X) X X? - - - - X* - - - - "++
- " n. n- n' n( n) n n? n* N. N- N' N( N) N N? N* "++
- " a u i A E e o e* k. k- k' k( k) k k? - "++
- " - - - k* - - - - - - - - - - - - "++
- " - - - - - - - - w. w- w' w( w) w w? w* "++
- " - - - - - - - - z. z- z' z( z) z z? z* "++
- " Z. Z- Z' Z( Z) Z Z? Z* y. y- y' y( y) y y? y* "++
- " d. d- d' d( d) d d? d* - - - - - - - - "++
- " j. j- j' j( j) j j? j* g. g- g' g( g) g g? - "++
- " - - - g* - - - - - - - - - - - - "++
- " T. T- T' T( T) T T? T* C. C- C' C( C) C C? C* "++
- " P. P- P' P( P) P P? P* S. S- S' S( S) S S? S* "++
- " - - - - - - - - f. f- f' f( f) f f? f*"++
- " p. p- p' p( p) p p? p*"
-allCodes = [0x1200..0x1357]
-
+ allTrans = words $
+ " h. h- h' h( h) h h? h* l. l- l' l( l) l l? l* "++
+ " H. H- H' H( H) H H? H* m. m- m' m( m) m m? m* "++
+ " s. s- s' s( s) s s? s* r. r- r' r( r) r r? r* "++
+ " - - - - - - - - x. x- x' x( x) x x? x* "++
+ " q. q- q' q( q) q q? q* - - - - - - - - "++
+ " - - - - - - - - - - - - - - - - "++
+ " b. b- b' b( b) b b? b* v. v- v' v( v) v v? v* "++
+ " t. t- t' t( t) t t? t* c. c- c' c( c) c c? c* "++
+ " X. X- X' X( X) X X? - - - - X* - - - - "++
+ " n. n- n' n( n) n n? n* N. N- N' N( N) N N? N* "++
+ " a u i A E e o e* k. k- k' k( k) k k? - "++
+ " - - - k* - - - - - - - - - - - - "++
+ " - - - - - - - - w. w- w' w( w) w w? w* "++
+ " - - - - - - - - z. z- z' z( z) z z? z* "++
+ " Z. Z- Z' Z( Z) Z Z? Z* y. y- y' y( y) y y? y* "++
+ " d. d- d' d( d) d d? d* - - - - - - - - "++
+ " j. j- j' j( j) j j? j* g. g- g' g( g) g g? - "++
+ " - - - g* - - - - - - - - - - - - "++
+ " T. T- T' T( T) T T? T* C. C- C' C( C) C C? C* "++
+ " P. P- P' P( P) P P? P* S. S- S' S( S) S S? S* "++
+ " - - - - - - - - f. f- f' f( f) f f? f*"++
+ " p. p- p' p( p) p p? p*"
+ allCodes = [0x1200..0x1357]
+
-- by Prasad 31/5/2013
transSanskrit :: Transliteration
transSanskrit = (mkTransliteration "Sanskrit" allTrans allCodes) {invisible_chars = ["a"]} where
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 08:04:34 +0000