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, + -- ** The Error monad + Err(..), err, maybeErr, testErr, fromErr, errIn, + lookupErr, - -- ** Error monad class - ErrorMonad(..), checks, --doUntil, allChecks, checkAgain, - liftErr, - - -- ** Checking - checkUnique, unifyMaybeBy, unifyMaybe, + -- ** Error monad class + ErrorMonad(..), checks, --doUntil, allChecks, checkAgain, + liftErr, - -- ** Monadic operations on lists and pairs - mapPairsM, pairM, - - -- ** Printing - indent, (+++), (++-), (++++), (+++-), (+++++), - prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly, - prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes, - numberedParagraphs, prConjList, prIfEmpty, wrapLines, + -- ** Checking + checkUnique, unifyMaybeBy, unifyMaybe, - -- ** Topological sorting - topoTest, topoTest2, + -- ** Monadic operations on lists and pairs + mapPairsM, pairM, - -- ** Misc - readIntArg, - iterFix, chunks, - - ) where + -- ** Printing + indent, (+++), (++-), (++++), (+++-), (+++++), + prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly, + prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes, + numberedParagraphs, prConjList, prIfEmpty, wrapLines, + + -- ** Topological sorting + topoTest, topoTest2, + + -- ** Misc + readIntArg, + iterFix, chunks, + + ) where import Data.Char (isSpace, toUpper, isSpace, isDigit) import Data.List (nub, partition, (\\)) @@ -107,7 +107,7 @@ indent i s = replicate i ' ' ++ s (+++), (++-), (++++), (+++-), (+++++) :: String -> String -> String a +++ b = a ++ " " ++ b -a ++- "" = a +a ++- "" = a a ++- b = a +++ b a ++++ b = a ++ "\n" ++ b @@ -145,20 +145,20 @@ prCurly s = "{" ++ s ++ "}" prBracket s = "[" ++ s ++ "]" prArgList, prSemicList, prCurlyList :: [String] -> String -prArgList = prParenth . prTList "," +prArgList = prParenth . prTList "," prSemicList = prTList " ; " prCurlyList = prCurly . prSemicList restoreEscapes :: String -> String -restoreEscapes s = - case s of +restoreEscapes s = + case s of [] -> [] '"' : t -> '\\' : '"' : restoreEscapes t '\\': t -> '\\' : '\\' : restoreEscapes t c : t -> c : restoreEscapes t numberedParagraphs :: [[String]] -> [String] -numberedParagraphs t = case t of +numberedParagraphs t = case t of [] -> [] p:[] -> p _ -> concat [(show n ++ ".") : s | (n,s) <- zip [1..] t] @@ -204,12 +204,12 @@ topoTest2 g0 = maybe (Right cycles) Left (tsort g) ([],[]) -> Just [] ([],_) -> Nothing (ns,rest) -> (leaves:) `fmap` tsort [(n,es \\ leaves) | (n,es)<-rest] - where leaves = map fst ns + where leaves = map fst ns -- | Fix point iterator (for computing e.g. transitive closures or reachability) iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a] -iterFix more start = iter start start +iterFix more start = iter start start where iter old new = if (null new') then old @@ -241,7 +241,7 @@ liftErr e = err raise return e {- instance ErrorMonad (STM s) where raise msg = STM (\s -> raise msg) - handle (STM f) g = STM (\s -> (f s) + handle (STM f) g = STM (\s -> (f s) `handle` (\e -> let STM g' = (g e) in g' s)) 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 "" - 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 diff --git a/src/runtime/haskell-bind/pgf2.cabal b/src/runtime/haskell-bind/pgf2.cabal index eb1e3c708..1d5f61991 100644 --- a/src/runtime/haskell-bind/pgf2.cabal +++ b/src/runtime/haskell-bind/pgf2.cabal @@ -26,7 +26,7 @@ library PGF2.Expr, PGF2.Type build-depends: - base >= 4.9.1 && <4.15, + base >= 4.9.1 && < 4.15, containers >= 0.5.7 && < 0.7, pretty >= 1.1.3 && < 1.2 default-language: Haskell2010 diff --git a/src/runtime/haskell/pgf.cabal b/src/runtime/haskell/pgf.cabal index 56c1ca04a..ab54be441 100644 --- a/src/runtime/haskell/pgf.cabal +++ b/src/runtime/haskell/pgf.cabal @@ -14,7 +14,7 @@ tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.10.4 library default-language: Haskell2010 build-depends: - base >= 4.9.1 && <4.15, + base >= 4.9.1 && < 4.15, array >= 0.5.1 && < 0.6, containers >= 0.5.7 && < 0.7, bytestring >= 0.10.8 && < 0.11,