summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/compiler/GF/Compile/Compute/ConcreteLazy.hs531
-rw-r--r--src/compiler/GF/Compile/Compute/ConcreteStrict.hs494
-rw-r--r--src/compiler/GF/Compile/Refresh.hs153
-rw-r--r--src/compiler/GF/Compile/SubExOpt.hs56
-rw-r--r--src/compiler/GF/CompileInParallel.hs6
-rw-r--r--src/compiler/GF/CompileOne.hs10
-rw-r--r--src/compiler/GF/Data/ErrM.hs14
-rw-r--r--src/compiler/GF/Data/Operations.hs102
-rw-r--r--src/compiler/GF/Grammar/Analyse.hs2
-rw-r--r--src/compiler/GF/Grammar/Lookup.hs2
-rw-r--r--src/compiler/GF/Grammar/MMacros.hs2
-rw-r--r--src/compiler/GF/Grammar/Macros.hs2
-rw-r--r--src/compiler/GF/Infra/Ident.hs67
-rw-r--r--src/compiler/GF/Interactive.hs6
14 files changed, 89 insertions, 1358 deletions
diff --git a/src/compiler/GF/Compile/Compute/ConcreteLazy.hs b/src/compiler/GF/Compile/Compute/ConcreteLazy.hs
deleted file mode 100644
index 929e30ce1..000000000
--- a/src/compiler/GF/Compile/Compute/ConcreteLazy.hs
+++ /dev/null
@@ -1,531 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : GF.Compile.Concrete.Compute
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/11/01 15:39:12 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.19 $
---
--- Computation of source terms. Used in compilation and in @cc@ command.
------------------------------------------------------------------------------
-
-module GF.Compile.Compute.ConcreteLazy ({-computeConcrete, computeTerm,checkPredefError-}) where
-{-
-import GF.Grammar.Grammar
-import GF.Data.Operations
-import GF.Infra.Ident
---import GF.Infra.Option
-import GF.Data.Str
---import GF.Grammar.ShowTerm
-import GF.Grammar.Printer
-import GF.Grammar.Predef
-import GF.Grammar.Macros
-import GF.Grammar.Lookup
---import GF.Compile.Refresh
-import GF.Grammar.PatternMatch
-import GF.Grammar.Lockfield (isLockLabel,unlockRecord) ----
-
-import GF.Compile.Compute.AppPredefined
-
-import Data.List (nub) --intersperse
---import Control.Monad (liftM2, liftM)
-import Control.Monad.Identity
-import GF.Text.Pretty
-
-----import Debug.Trace
-
---type Comp a = Err a -- makes computations (hyper)strict
---errr = id
-
-type Comp a = Identity a -- inherit Haskell's laziness
-errr = err runtime_error return -- convert interpreter error to run-time error
-no_error = err fail return -- failure caused by interpreter/type checker bug (?)
-runtime_error = return . Error -- run-time error term
-
--- | computation of concrete syntax terms into normal form
--- used mainly for partial evaluation
-computeConcrete :: SourceGrammar -> Term -> Err Term
-computeConcrete g t = {- refreshTerm t >>= -} computeTerm g [] t
-
-computeTerm :: SourceGrammar -> Substitution -> Term -> Err Term
-computeTerm gr g = return . runIdentity . computeTermOpt gr g
-
-computeTermOpt :: SourceGrammar -> Substitution -> Term -> Comp Term
-computeTermOpt gr = comput True where
-
- -- full = True means full evaluation under Abs
- comput full g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging
- --trace ("comput "++show (map fst g)++" "++take 65 (show t)) $
- case t of
-
- Q (p,c) | p == cPredef -> return t -- qualified constant
- | otherwise -> look (p,c)
-
- Vr x -> do -- local variable
- t' <- maybe (fail (render (text "no value given to variable" <+> ppIdent x)))
- return $ lookup x g
- case t' of
- _ | t == t' -> return t
- _ -> comp g t' --- why compute again? AR 25/8/2011
-
- -- Abs x@(IA _) b -> do
- Abs _ _ _ | full -> do -- \xs -> b
- let (xs,b1) = termFormCnc t
- b' <- comp ([(x,Vr x) | (_,x) <- xs] ++ g) b1
- return $ mkAbs xs b'
- -- b' <- comp (ext x (Vr x) g) b
- -- return $ Abs x b'
- Abs _ _ _ -> return t -- hnf
-
- Let (x,(ty,a)) b -> do -- let x : ty = a in b
- a' <- comp g a
- comp (ext x a' g) b
-
-{- -- trying to prevent Let expansion with non-evaluated exps. AR 19/8/2011
- Let (x,(ty,a)) b -> do
- a' <- comp g a
- let ea' = checkNoArgVars a'
- case ea' of
- Ok v -> comp (ext x v g) b
- _ -> return $ Let (x,(ty,a')) b
--}
-
- Prod b x a t -> do -- (x : a) -> t ; b for hiding
- a' <- comp g a
- t' <- comp (ext x (Vr x) g) t
- return $ Prod b x a' t'
-
- -- beta-convert: simultaneous for as many arguments as possible
- App f a -> case appForm t of -- (f a) --> (h as)
- (h,as) | length as > 1 -> do
- h' <- hnf g h
- as' <- mapM (comp g) as
- case h' of
- Error{} -> return h'
- _ | not (null [() | FV _ <- as']) -> compApp g (mkApp h' as')
- c@(QC _) -> do
- return $ mkApp c as'
- Q (mod,f) | mod == cPredef ->
- case appPredefined (mkApp h' as') of
- Ok (t',b) -> if b then return t' else comp g t'
- Bad s -> runtime_error s
-
- Abs _ _ _ -> do
- let (xs,b) = termFormCnc h'
- let g' = (zip (map snd xs) as') ++ g
- let as2 = drop (length xs) as'
- let xs2 = drop (length as') xs
- b' <- comp g' (mkAbs xs2 b)
- if null as2 then return b' else comp g (mkApp b' as2)
-
- _ -> compApp g (mkApp h' as')
- _ -> compApp g t
-
- P t l | isLockLabel l -> return $ R [] -- t.lock_C
- ---- a workaround 18/2/2005: take this away and find the reason
- ---- why earlier compilation destroys the lock field
-
-
- P t l -> do -- t.l
- t' <- comp g t
- case t' of
- Error{} -> return t'
- FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants -- (r| r').l
- R r -> project l r --{...}.l
-
- ExtR a (R b) -> -- (a ** {...}).l
- maybe (comp g (P a l)) (comp g) (try_project l b)
-
---- { - --- this is incorrect, since b can contain the proper value
- ExtR (R a) b -> -- NOT POSSIBLE both a and b records!
- maybe (comp g (P b l)) (comp g) (try_project l a)
---- - } ---
-
- S (T i cs) e -> prawitz g i (flip P l) cs e -- ((table i branches) ! e).l
- S (V i cs) e -> prawitzV g i (flip P l) cs e -- ((table i values) ! e).l
-
- _ -> returnC $ P t' l
-
- S t v -> do -- t ! v
- t' <- compTable g t
- v' <- comp g v
- t1 <- case t' of
----- V (RecType fs) _ -> uncurrySelect g fs t' v'
----- T (TComp (RecType fs)) _ -> uncurrySelect g fs t' v'
- _ -> return $ S t' v'
- compSelect g t1
-
- -- normalize away empty tokens
- K "" -> return Empty -- []
-
- -- glue if you can
- Glue x0 y0 -> do -- x0 + y0
- x <- comp g x0
- y <- comp g y0
- case (x,y) of
- (Error{},_) -> return x
- (_,Error{}) -> return y
- (FV ks,_) -> do -- (k|k') + y
- kys <- mapM (comp g . flip Glue y) ks
- return $ variants kys
- (_,FV ks) -> do -- x + (k|k')
- xks <- mapM (comp g . Glue x) ks
- return $ variants xks
-
- (S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e -- (table cs ! e) + s
- (s, S (T i cs) e) -> prawitz g i (Glue s) cs e -- s + (table cs ! e)
- (S (V i cs) e, s) -> prawitzV g i (flip Glue s) cs e -- same with values
- (s, S (V i cs) e) -> prawitzV g i (Glue s) cs e
- (_,Empty) -> return x -- x + []
- (Empty,_) -> return y
- (K a, K b) -> return $ K (a ++ b) -- "foo" + "bar"
- (_, Alts d vs) -> do -- x + pre {...}
----- (K a, Alts (d,vs)) -> do
- let glx = Glue x
- comp g $ Alts (glx d) [(glx v,c) | (v,c) <- vs]
- (Alts _ _, ka) -> errr $ checks [do -- pre {...} + ka
- y' <- strsFromTerm ka
----- (Alts _, K a) -> checks [do
- x' <- strsFromTerm x -- this may fail when compiling opers
- return $ variants [
- foldr1 C (map K (str2strings (glueStr v u))) | v <- x', u <- y']
----- foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x']
- ,return $ Glue x y
- ]
- (C u v,_) -> comp g $ C u (Glue v y) -- (u ++ v) + y
- (_,C u v) -> comp g $ C (Glue x u) v -- x ++ (u ++ v)
-
- _ -> do
- mapM_ checkNoArgVars [x,y]
- r <- composOp (comp g) t
- returnC r
-
- Alts d aa -> do -- pre {...}
- d' <- comp g d
- aa' <- mapM (compInAlts g) aa
- returnC (Alts d' aa')
-
- -- remove empty
- C a b -> do -- a ++ b
- a0 <- comp g a
- b0 <- comp g b
- let (a',b') = strForm (C a0 b0)
- case (a',b') of
- (Error{},_) -> return a'
- (_,Error{}) -> return b'
-
- (Alts _ _, K d) -> errr $ checks [do -- pre {...} ++ "d"
- as <- strsFromTerm a' -- this may fail when compiling opers
- return $ variants [
- foldr1 C (map K (str2strings (plusStr v (str d)))) | v <- as]
- ,
- return $ C a' b'
- ]
- (Alts _ _, C (K d) e) -> errr $ checks [do -- pre {...} ++ ("d" ++ e)
- as <- strsFromTerm a' -- this may fail when compiling opers
- return $ C (variants [
- foldr1 C (map K (str2strings (plusStr v (str d)))) | v <- as]) e
- ,
- return $ C a' b'
- ]
-
- (Empty,_) -> returnC b' -- [] ++ b'
- (_,Empty) -> returnC a' -- a' ++ []
- _ -> returnC $ C a' b'
-
- -- reduce free variation as much as you can
- FV ts -> mapM (comp g) ts >>= returnC . variants -- variants {...}
-
- -- merge record extensions if you can
- ExtR r s -> do -- r ** s
- r' <- comp g r
- s' <- comp g s
- case (r',s') of
- (Error{},_) -> return r'
- (_,Error{}) -> return s'
- (R rs, R ss) -> errr $ plusRecord r' s'
- (RecType rs, RecType ss) -> errr $ plusRecType r' s'
- _ -> return $ ExtR r' s'
-
- ELin c r -> do -- lin c r
- r' <- comp g r
- unlockRecord c r'
-
- T _ _ -> compTable g t -- table { ... p => t ... }
- V _ _ -> compTable g t -- table [ ... v ... ]
-
- -- otherwise go ahead
- _ -> composOp (comp g) t >>= returnC
-
- where
- --{...}.l
- project l = maybe (fail_project l) (comp g) . try_project l
- try_project l = fmap snd . lookup l
- fail_project l = fail (render (text "no value for label" <+> ppLabel l))
-
- compApp g (App f a) = do -- (f a)
- f' <- hnf g f
- a' <- comp g a
- case (f',a') of
- (Error{},_) -> return f'
- (Abs _ x b, FV as) -> -- (\x -> b) (variants {...})
- liftM variants $ mapM (\c -> comp (ext x c g) b) as
- (_, FV as) -> liftM variants $ mapM (\c -> comp g (App f' c)) as
- (FV fs, _) -> liftM variants $ mapM (\c -> comp g (App c a')) fs
- (Abs _ x b,_) -> comp (ext x a' g) b -- (\x -> b) a -- normal beta conv.
-
- (QC _,_) -> returnC $ App f' a' -- (C a') -- constructor application
-
- (S (T i cs) e,_) -> prawitz g i (flip App a') cs e -- (table cs ! e) a'
- (S (V i cs) e,_) -> prawitzV g i (flip App a') cs e
-
- _ -> case appPredefined (App f' a') of
- Ok (t',b) -> if b then return t' else comp g t'
- Bad s -> runtime_error s
-
- hnf, comp :: Substitution -> Term -> Comp Term
- hnf = comput False
- comp = comput True
-
- look c = errr (lookupResDef gr c)
- {- -- This seems to loop in the greek example:
- look c = --trace ("look "++show c) $
- optcomp =<< errr (lookupResDef gr c)
- where
- optcomp t = if t==Q c
- then --trace "looking up undefined oper" $
- return t
- else comp [] t -- g or []?
- -}
-
- ext x a g = (x,a):g -- extend environment with new variable and its value
-
- returnC = return --- . computed
-
- variants ts = case nub ts of
- [t] -> t
- ts -> FV ts
-
- isCan v = case v of -- is canonical (and should be matched by a pattern)
- Con _ -> True
- QC _ -> True
- App f a -> isCan f && isCan a
- R rs -> all (isCan . snd . snd) rs
- _ -> False
-
- compPatternMacro p = case p of
- PM c -> case look c of
- Identity (EPatt p') -> compPatternMacro p'
- -- _ -> fail (render (text "pattern expected as value of" $$ nest 2 (ppPatt Unqualified 0 p)))
- PAs x p -> do
- p' <- compPatternMacro p
- return $ PAs x p'
- PAlt p q -> do
- p' <- compPatternMacro p
- q' <- compPatternMacro q
- return $ PAlt p' q'
- PSeq p q -> do
- p' <- compPatternMacro p
- q' <- compPatternMacro q
- return $ PSeq p' q'
- PRep p -> do
- p' <- compPatternMacro p
- return $ PRep p'
- PNeg p -> do
- p' <- compPatternMacro p
- return $ PNeg p'
- PR rs -> do
- rs' <- mapPairsM compPatternMacro rs
- return $ PR rs'
-
- _ -> return p
-
- compSelect g (S t' v') = case v' of -- t' ! v'
- FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants
-
----- S (T i cs) e -> prawitz g i (S t') cs e -- AR 8/7/2010 sometimes better
----- S (V i cs) e -> prawitzV g i (S t') cs e -- sometimes much worse
-
-
- _ -> case t' of
- Error{} -> return t'
- FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants
-
- T _ [(PW,c)] -> comp g c -- (\\_ => c) ! v'
- T _ [(PT _ PW,c)] -> comp g c -- (\\(_ : typ) => c) ! v'
-
- T _ [(PV z,c)] -> comp (ext z v' g) c -- (\\z => c) ! v'
- T _ [(PT _ (PV z),c)] -> comp (ext z v' g) c
-
- -- course-of-values table: look up by index, no pattern matching needed
-
- V ptyp ts -> do -- (table [...ts...]) ! v'
- vs <- no_error $ allParamValues gr ptyp
- case lookupR v' (zip vs [0 .. length vs - 1]) of
- Just i -> comp g $ ts !! i
- _ -> return $ S t' v' -- if v' is not canonical
- T _ cc -> do -- (table {...cc...}) ! v'
- case matchPattern cc v' of
- Ok (c,g') -> comp (g' ++ g) c
- _ | isCan v' -> fail (render (text "missing case" <+> ppTerm Unqualified 0 v' <+> text "in" <+> ppTerm Unqualified 0 t))
- _ -> return $ S t' v' -- if v' is not canonical
-
- S (T i cs) e -> prawitz g i (flip S v') cs e -- (table {...cs...} ! e) ! v'
- S (V i cs) e -> prawitzV g i (flip S v') cs e
- _ -> returnC $ S t' v'
-
- --- needed to match records with and without type information
- ---- todo: eliminate linear search in a list of records!
- lookupR v vs = case v of
- R rs -> lookup ([(x,y) | (x,(_,y)) <- rs])
- [([(x,y) | (x,(_,y)) <- rs],v) | (R rs,v) <- vs]
- _ -> lookup v vs
-
- -- case-expand tables: branches for every value of argument type
- -- if already expanded, don't expand again
- compTable g t = case t of
- T i@(TComp ty) cs -> do
- -- if there are no variables, don't even go inside
- cs' <- if (null g) then return cs else mapPairsM (comp g) cs
----- return $ V ty (map snd cs')
- return $ T i cs'
- V ty cs -> do
- ty' <- comp g ty
- -- if there are no variables, don't even go inside
- cs' <- if (null g) then return cs else mapM (comp g) cs
- return $ V ty' cs'
-
- T i cs -> do
- pty0 <- errr $ getTableType i
- ptyp <- comp g pty0
- case allParamValues gr ptyp of
- Ok vs0 -> do
- let vs = vs0 ---- [Val v ptyp i | (v,i) <- zip vs0 [0..]]
- ps0 <- mapM (compPatternMacro . fst) cs
- cs' <- mapM (compBranchOpt g) (zip ps0 (map snd cs))
- sts <- no_error $ mapM (matchPattern cs') vs
- ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts
- ps <- no_error $ mapM term2patt vs
- let ps' = ps --- PT ptyp (head ps) : tail ps
----- return $ V ptyp ts -- to save space, just course of values
- return $ T (TComp ptyp) (zip ps' ts)
- _ -> do
- ps0 <- mapM (compPatternMacro . fst) cs
-
- cs' <- mapM (compBranch g) (zip ps0 (map snd cs))
------ cs' <- return (zip ps0 (map snd cs)) --- probably right AR 22/8/2011 but can leave uninstantiated variables :-(
-
----- cs' <- mapM (compBranch g) cs
- return $ T i cs' -- happens with variable types
- _ -> comp g t
-
- compBranch g (p,v) = do -- compute a branch in a table
- let g' = contP p ++ g -- add the pattern's variables to environment
- v' <- comp g' v
- return (p,v')
-
- compBranchOpt g c@(p,v) = case contP p of
- [] -> return c
- _ -> {-err (const (return c)) return $-} compBranch g c
-
- -- collect the context of variables of a pattern
- contP p = case p of
- PV x -> [(x,Vr x)]
- PC _ ps -> concatMap contP ps
- PP _ ps -> concatMap contP ps
- PT _ p -> contP p
- PR rs -> concatMap (contP . snd) rs
-
- PAs x p -> (x,Vr x) : contP p
-
- PSeq p q -> concatMap contP [p,q]
- PAlt p q -> concatMap contP [p,q]
- PRep p -> contP p
- PNeg p -> contP p
-
- _ -> []
-
- prawitz g i f cs e = do
- cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs]
- return $ S (T i cs') e
- prawitzV g i f cs e = do
- cs' <- mapM (comp g) [(f v) | v <- cs]
- return $ S (V i cs') e
-
- compInAlts g (v,c) = do
- v' <- comp g v
- c' <- comp g c
- c2 <- case c' of
- EPatt p -> liftM Strs $ getPatts p
- _ -> return c'
- return (v',c2)
- where
- getPatts p = case p of
- PAlt a b -> liftM2 (++) (getPatts a) (getPatts b)
- PString s -> return [K s]
- PSeq a b -> do
- as <- getPatts a
- bs <- getPatts b
- return [K (s ++ t) | K s <- as, K t <- bs]
- _ -> fail (render (text "not valid pattern in pre expression" <+> ppPatt Unqualified 0 p))
-
- strForm s = case s of
- C (C a b) c -> let (a1,a2) = strForm a in (a1, ccStr a2 (ccStr b c))
- C a b -> (a,b)
- _ -> (s,Empty)
-
- ccStr a b = case (a,b) of
- (Empty,_) -> b
- (_,Empty) -> a
- _ -> C a b
-
-{- ----
- uncurrySelect g fs t v = do
- ts <- mapM (allParamValues gr . snd) fs
- vs <- mapM (comp g) [P v r | r <- map fst fs]
- return $ reorderSelect t fs ts vs
-
- reorderSelect t fs pss vs = case (t,fs,pss,vs) of
- (V _ ts, f:fs1, ps:pss1, v:vs1) ->
- S (V (snd f)
- [reorderSelect (V (RecType fs1) t) fs1 pss1 vs1 |
- t <- segments (length ts `div` length ps) ts]) v
- (T (TComp _) cs, f:fs1, ps:pss1, v:vs1) ->
- S (T (TComp (snd f))
- [(p,reorderSelect (T (TComp (RecType fs1)) c) fs1 pss1 vs1) |
- (ep,c) <- zip ps (segments (length cs `div` length ps) cs),
- let Ok p = term2patt ep]) v
- _ -> t
-
- segments i xs =
- let (x0,xs1) = splitAt i xs in x0 : takeWhile (not . null) (segments i xs1)
--}
-
-
--- | argument variables cannot be glued
-checkNoArgVars :: Term -> Comp Term
-checkNoArgVars t = case t of
- Vr x | isArgIdent x -> fail $ glueErrorMsg $ ppTerm Unqualified 0 t
- _ -> composOp checkNoArgVars t
-
-glueErrorMsg s =
- render (text "Cannot glue (+) term with run-time variable" <+> s <> char '.' $$
- text "Use Prelude.bind instead.")
-
-getArgType t = case t of
- V ty _ -> return ty
- T (TComp ty) _ -> return ty
- _ -> fail (render (text "cannot get argument type of table" $$ nest 2 (ppTerm Unqualified 0 t)))
-
-{-
--- Old
-checkPredefError sgr t = case t of
- App (Q (mod,f)) s | mod == cPredef && f == cError -> fail $ showTerm sgr TermPrintOne Unqualified s
- _ -> composOp (checkPredefError sgr) t
-
-predef_error s = App (Q (cPredef,cError)) (K s)
--}
--}
diff --git a/src/compiler/GF/Compile/Compute/ConcreteStrict.hs b/src/compiler/GF/Compile/Compute/ConcreteStrict.hs
deleted file mode 100644
index df343adec..000000000
--- a/src/compiler/GF/Compile/Compute/ConcreteStrict.hs
+++ /dev/null
@@ -1,494 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : GF.Compile.Concrete.Compute
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/11/01 15:39:12 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.19 $
---
--- Computation of source terms. Used in compilation and in @cc@ command.
------------------------------------------------------------------------------
-
-module GF.Compile.Compute.ConcreteStrict (computeConcrete, computeTerm,computeConcreteRec,checkPredefError) where
-
-import GF.Data.Operations
-import GF.Grammar.Grammar
-import GF.Infra.Ident
-import GF.Infra.Option
---import GF.Infra.Modules
-import GF.Data.Str
-import GF.Grammar.ShowTerm
-import GF.Grammar.Printer
-import GF.Grammar.Predef
-import GF.Grammar.Macros
-import GF.Grammar.Lookup
---import GF.Compile.Refresh
-import GF.Grammar.PatternMatch
-import GF.Grammar.Lockfield (isLockLabel,unlockRecord) ----
-
-import GF.Compile.Compute.AppPredefined
-
-import Data.List (nub,intersperse)
-import Control.Monad (liftM2, liftM)
-import GF.Text.Pretty
-
-----import Debug.Trace
-
--- | computation of concrete syntax terms into normal form
--- used mainly for partial evaluation
-computeConcrete :: SourceGrammar -> Term -> Err Term
-computeConcrete g t = {- refreshTerm t >>= -} computeTerm g [] t
-computeConcreteRec g t = {- refreshTerm t >>= -} computeTermOpt True g [] t
-
--- False means: no evaluation under Abs
-computeTerm :: SourceGrammar -> Substitution -> Term -> Err Term
-computeTerm = computeTermOpt False
-
--- rec=True is used if it cannot be assumed that looked-up constants
--- have already been computed (mainly with -optimize=noexpand in .gfr)
-
-computeTermOpt :: Bool -> SourceGrammar -> Substitution -> Term -> Err Term
-computeTermOpt rec gr = comput True where
-
- -- full = True means full evaluation under Abs
- comput full g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging
- case t of
-
- Q (p,c) | p == cPredef -> return t -- qualified constant
- | otherwise -> look (p,c)
-
- Vr x -> do -- local variable
- t' <- maybe (Bad (render (text "no value given to variable" <+> ppIdent x)))
- return $ lookup x g
- case t' of
- _ | t == t' -> return t
- _ -> comp g t' --- why compute again? AR 25/8/2011
-
- -- Abs x@(IA _) b -> do
- Abs _ _ _ | full -> do -- \xs -> b
- let (xs,b1) = termFormCnc t
- b' <- comp ([(x,Vr x) | (_,x) <- xs] ++ g) b1
- return $ mkAbs xs b'
- -- b' <- comp (ext x (Vr x) g) b
- -- return $ Abs x b'
- Abs _ _ _ -> return t -- hnf
-
- Let (x,(ty,a)) b -> do -- let x : ty = a in b
- a' <- comp g a
- comp (ext x a' g) b
-
-{- -- trying to prevent Let expansion with non-evaluated exps. AR 19/8/2011
- Let (x,(ty,a)) b -> do
- a' <- comp g a
- let ea' = checkNoArgVars a'
- case ea' of
- Ok v -> comp (ext x v g) b
- _ -> return $ Let (x,(ty,a')) b
--}
-
- Prod b x a t -> do -- (x : a) -> t ; b for hiding
- a' <- comp g a
- t' <- comp (ext x (Vr x) g) t
- return $ Prod b x a' t'
-
- -- beta-convert: simultaneous for as many arguments as possible
- App f a -> case appForm t of -- (f a) --> (h as)
- (h,as) | length as > 1 -> do
- h' <- hnf g h
- as' <- mapM (comp g) as
- case h' of
- _ | not (null [() | FV _ <- as']) -> compApp g (mkApp h' as')
- c@(QC _) -> do
- return $ mkApp c as'
- Q (mod,f) | mod == cPredef -> do
- (t',b) <- appPredefined (mkApp h' as')
- if b then return t' else comp g t'
-
- Abs _ _ _ -> do
- let (xs,b) = termFormCnc h'
- let g' = (zip (map snd xs) as') ++ g
- let as2 = drop (length xs) as'
- let xs2 = drop (length as') xs
- b' <- comp g' (mkAbs xs2 b)
- if null as2 then return b' else comp g (mkApp b' as2)
-
- _ -> compApp g (mkApp h' as')
- _ -> compApp g t
-
- P t l | isLockLabel l -> return $ R [] -- t.lock_C
- ---- a workaround 18/2/2005: take this away and find the reason
- ---- why earlier compilation destroys the lock field
-
-
- P t l -> do -- t.l
- t' <- comp g t
- case t' of
- FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants -- (r| r').l
- R r -> maybe (Bad (render (text "no value for label" <+> ppLabel l))) --{...}.l
- (comp g . snd) $
- lookup l $ reverse r
-
- ExtR a (R b) -> -- (a ** {...}).l
- case comp g (P (R b) l) of
- Ok v -> return v
- _ -> comp g (P a l)
-
---- { - --- this is incorrect, since b can contain the proper value
- ExtR (R a) b -> -- NOT POSSIBLE both a and b records!
- case comp g (P (R a) l) of
- Ok v -> return v
- _ -> comp g (P b l)
---- - } ---
-
- S (T i cs) e -> prawitz g i (flip P l) cs e -- ((table i branches) ! e).l
- S (V i cs) e -> prawitzV g i (flip P l) cs e -- ((table i values) ! e).l
-
- _ -> returnC $ P t' l
-
- S t v -> do -- t ! v
- t' <- compTable g t
- v' <- comp g v
- t1 <- case t' of
----- V (RecType fs) _ -> uncurrySelect g fs t' v'
----- T (TComp (RecType fs)) _ -> uncurrySelect g fs t' v'
- _ -> return $ S t' v'
- compSelect g t1
-
- -- normalize away empty tokens
- K "" -> return Empty -- []
-
- -- glue if you can
- Glue x0 y0 -> do -- x0 + y0
- x <- comp g x0
- y <- comp g y0
- case (x,y) of
- (FV ks,_) -> do -- (k|k') + y
- kys <- mapM (comp g . flip Glue y) ks
- return $ variants kys
- (_,FV ks) -> do -- x + (k|k')
- xks <- mapM (comp g . Glue x) ks
- return $ variants xks
-
- (S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e -- (table cs ! e) + s
- (s, S (T i cs) e) -> prawitz g i (Glue s) cs e -- s + (table cs ! e)
- (S (V i cs) e, s) -> prawitzV g i (flip Glue s) cs e -- same with values
- (s, S (V i cs) e) -> prawitzV g i (Glue s) cs e
- (_,Empty) -> return x -- x + []
- (Empty,_) -> return y
- (K a, K b) -> return $ K (a ++ b) -- "foo" + "bar"
- (_, Alts d vs) -> do -- x + pre {...}
----- (K a, Alts (d,vs)) -> do
- let glx = Glue x
- comp g $ Alts (glx d) [(glx v,c) | (v,c) <- vs]
- (Alts _ _, ka) -> checks [do -- pre {...} + ka
- y' <- strsFromTerm ka
----- (Alts _, K a) -> checks [do
- x' <- strsFromTerm x -- this may fail when compiling opers
- return $ variants [
- foldr1 C (map K (str2strings (glueStr v u))) | v <- x', u <- y']
----- foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x']
- ,return $ Glue x y
- ]
- (C u v,_) -> comp g $ C u (Glue v y) -- (u ++ v) + y
-
- _ -> do
- mapM_ checkNoArgVars [x,y]
- r <- composOp (comp g) t
- returnC r
-
- Alts d aa -> do -- pre {...}
- d' <- comp g d
- aa' <- mapM (compInAlts g) aa
- returnC (Alts d' aa')
-
- -- remove empty
- C a b -> do -- a ++ b
- a' <- comp g a
- b' <- comp g b
- case (a',b') of
- (Alts _ _, K d) -> checks [do -- pre {...} ++ "d"
- as <- strsFromTerm a' -- this may fail when compiling opers
- return $ variants [
- foldr1 C (map K (str2strings (plusStr v (str d)))) | v <- as]
- ,
- return $ C a' b'
- ]
- (Alts _ _, C (K d) e) -> checks [do -- pre {...} ++ ("d" ++ e)
- as <- strsFromTerm a' -- this may fail when compiling opers
- return $ C (variants [
- foldr1 C (map K (str2strings (plusStr v (str d)))) | v <- as]) e
- ,
- return $ C a' b'
- ]
- (Empty,_) -> returnC b' -- [] ++ b'
- (_,Empty) -> returnC a' -- a' ++ []
- _ -> returnC $ C a' b'
-
- -- reduce free variation as much as you can
- FV ts -> mapM (comp g) ts >>= returnC . variants -- variants {...}
-
- -- merge record extensions if you can
- ExtR r s -> do -- r ** s
- r' <- comp g r
- s' <- comp g s
- case (r',s') of
- (R rs, R ss) -> plusRecord r' s'
- (RecType rs, RecType ss) -> plusRecType r' s'
- _ -> return $ ExtR r' s'
-
- ELin c r -> do -- lin c r
- r' <- comp g r
- unlockRecord c r'
-
- T _ _ -> compTable g t -- table { ... p => t ... }
- V _ _ -> compTable g t -- table [ ... v ... ]
-
- -- otherwise go ahead
- _ -> composOp (comp g) t >>= returnC
-
- where
-
- compApp g (App f a) = do -- (f a)
- f' <- hnf g f
- a' <- comp g a
- case (f',a') of
- (Abs _ x b, FV as) -> -- (\x -> b) (variants {...})
- mapM (\c -> comp (ext x c g) b) as >>= return . variants
- (_, FV as) -> mapM (\c -> comp g (App f' c)) as >>= return . variants
- (FV fs, _) -> mapM (\c -> comp g (App c a')) fs >>= return . variants
- (Abs _ x b,_) -> comp (ext x a' g) b -- (\x -> b) a -- normal beta conv.
-
- (QC _,_) -> returnC $ App f' a' -- (C a') -- constructor application
-
- (S (T i cs) e,_) -> prawitz g i (flip App a') cs e -- (table cs ! e) a'
- (S (V i cs) e,_) -> prawitzV g i (flip App a') cs e
-
- _ -> do
- (t',b) <- appPredefined (App f' a')
- if b then return t' else comp g t'
-
- hnf = comput False
- comp = comput True
-
- look c
- | rec = lookupResDef gr c >>= comp []
- | otherwise = lookupResDef gr c
-
- ext x a g = (x,a):g -- extend environment with new variable and its value
-
- returnC = return --- . computed
-
- variants ts = case nub ts of
- [t] -> t
- ts -> FV ts
-
- isCan v = case v of -- is canonical (and should be matched by a pattern)
- Con _ -> True
- QC _ -> True
- App f a -> isCan f && isCan a
- R rs -> all (isCan . snd . snd) rs
- _ -> False
-
- compPatternMacro p = case p of
- PM c -> case look c of
- Ok (EPatt p') -> compPatternMacro p'
- _ -> Bad (render (text "pattern expected as value of" $$ nest 2 (ppPatt Unqualified 0 p)))
- PAs x p -> do
- p' <- compPatternMacro p
- return $ PAs x p'
- PAlt p q -> do
- p' <- compPatternMacro p
- q' <- compPatternMacro q
- return $ PAlt p' q'
- PSeq p q -> do
- p' <- compPatternMacro p
- q' <- compPatternMacro q
- return $ PSeq p' q'
- PRep p -> do
- p' <- compPatternMacro p
- return $ PRep p'
- PNeg p -> do
- p' <- compPatternMacro p
- return $ PNeg p'
- PR rs -> do
- rs' <- mapPairsM compPatternMacro rs
- return $ PR rs'
-
- _ -> return p
-
- compSelect g (S t' v') = case v' of -- t' ! v'
- FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants
-
----- S (T i cs) e -> prawitz g i (S t') cs e -- AR 8/7/2010 sometimes better
----- S (V i cs) e -> prawitzV g i (S t') cs e -- sometimes much worse
-
-
- _ -> case t' of
- FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants
-
- T _ [(PW,c)] -> comp g c -- (\\_ => c) ! v'
- T _ [(PT _ PW,c)] -> comp g c -- (\\(_ : typ) => c) ! v'
-
- T _ [(PV z,c)] -> comp (ext z v' g) c -- (\\z => c) ! v'
- T _ [(PT _ (PV z),c)] -> comp (ext z v' g) c
-
- -- course-of-values table: look up by index, no pattern matching needed
-
- V ptyp ts -> do -- (table [...ts...]) ! v'
- vs <- allParamValues gr ptyp
- case lookupR v' (zip vs [0 .. length vs - 1]) of
- Just i -> comp g $ ts !! i
- _ -> return $ S t' v' -- if v' is not canonical
- T _ cc -> do -- (table {...cc...}) ! v'
- case matchPattern cc v' of
- Ok (c,g') -> comp (g' ++ g) c
- _ | isCan v' -> Bad (render (text "missing case" <+> ppTerm Unqualified 0 v' <+> text "in" <+> ppTerm Unqualified 0 t))
- _ -> return $ S t' v' -- if v' is not canonical
-
- S (T i cs) e -> prawitz g i (flip S v') cs e -- (table {...cs...} ! e) ! v'
- S (V i cs) e -> prawitzV g i (flip S v') cs e
- _ -> returnC $ S t' v'
-
- --- needed to match records with and without type information
- ---- todo: eliminate linear search in a list of records!
- lookupR v vs = case v of
- R rs -> lookup ([(x,y) | (x,(_,y)) <- rs])
- [([(x,y) | (x,(_,y)) <- rs],v) | (R rs,v) <- vs]
- _ -> lookup v vs
-
- -- case-expand tables: branches for every value of argument type
- -- if already expanded, don't expand again
- compTable g t = case t of
- T i@(TComp ty) cs -> do
- -- if there are no variables, don't even go inside
- cs' <- if (null g) then return cs else mapPairsM (comp g) cs
----- return $ V ty (map snd cs')
- return $ T i cs'
- V ty cs -> do
- ty' <- comp g ty
- -- if there are no variables, don't even go inside
- cs' <- if (null g) then return cs else mapM (comp g) cs
- return $ V ty' cs'
-
- T i cs -> do
- pty0 <- getTableType i
- ptyp <- comp g pty0
- case allParamValues gr ptyp of
- Ok vs0 -> do
- let vs = vs0 ---- [Val v ptyp i | (v,i) <- zip vs0 [0..]]
- ps0 <- mapM (compPatternMacro . fst) cs
- cs' <- mapM (compBranchOpt g) (zip ps0 (map snd cs))
- sts <- mapM (matchPattern cs') vs
- ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts
- ps <- mapM term2patt vs
- let ps' = ps --- PT ptyp (head ps) : tail ps
----- return $ V ptyp ts -- to save space, just course of values
- return $ T (TComp ptyp) (zip ps' ts)
- _ -> do
- ps0 <- mapM (compPatternMacro . fst) cs
-
- cs' <- mapM (compBranch g) (zip ps0 (map snd cs))
------ cs' <- return (zip ps0 (map snd cs)) --- probably right AR 22/8/2011 but can leave uninstantiated variables :-(
-
----- cs' <- mapM (compBranch g) cs
- return $ T i cs' -- happens with variable types
- _ -> comp g t
-
- compBranch g (p,v) = do -- compute a branch in a table
- let g' = contP p ++ g -- add the pattern's variables to environment
- v' <- comp g' v
- return (p,v')
-
- compBranchOpt g c@(p,v) = case contP p of
- [] -> return c
- _ -> err (const (return c)) return $ compBranch g c
-
- -- collect the context of variables of a pattern
- contP p = case p of
- PV x -> [(x,Vr x)]
- PC _ ps -> concatMap contP ps
- PP _ ps -> concatMap contP ps
- PT _ p -> contP p
- PR rs -> concatMap (contP . snd) rs
-
- PAs x p -> (x,Vr x) : contP p
-
- PSeq p q -> concatMap contP [p,q]
- PAlt p q -> concatMap contP [p,q]
- PRep p -> contP p
- PNeg p -> contP p
-
- _ -> []
-
- prawitz g i f cs e = do
- cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs]
- return $ S (T i cs') e
- prawitzV g i f cs e = do
- cs' <- mapM (comp g) [(f v) | v <- cs]
- return $ S (V i cs') e
-
- compInAlts g (v,c) = do
- v' <- comp g v
- c' <- comp g c
- c2 <- case c' of
- EPatt p -> liftM Strs $ getPatts p
- _ -> return c'
- return (v',c2)
- where
- getPatts p = case p of
- PAlt a b -> liftM2 (++) (getPatts a) (getPatts b)
- PString s -> return [K s]
- PSeq a b -> do
- as <- getPatts a
- bs <- getPatts b
- return [K (s ++ t) | K s <- as, K t <- bs]
- _ -> fail (render (text "not valid pattern in pre expression" <+> ppPatt Unqualified 0 p))
-
-{- ----
- uncurrySelect g fs t v = do
- ts <- mapM (allParamValues gr . snd) fs
- vs <- mapM (comp g) [P v r | r <- map fst fs]
- return $ reorderSelect t fs ts vs
-
- reorderSelect t fs pss vs = case (t,fs,pss,vs) of
- (V _ ts, f:fs1, ps:pss1, v:vs1) ->
- S (V (snd f)
- [reorderSelect (V (RecType fs1) t) fs1 pss1 vs1 |
- t <- segments (length ts `div` length ps) ts]) v
- (T (TComp _) cs, f:fs1, ps:pss1, v:vs1) ->
- S (T (TComp (snd f))
- [(p,reorderSelect (T (TComp (RecType fs1)) c) fs1 pss1 vs1) |
- (ep,c) <- zip ps (segments (length cs `div` length ps) cs),
- let Ok p = term2patt ep]) v
- _ -> t
-
- segments i xs =
- let (x0,xs1) = splitAt i xs in x0 : takeWhile (not . null) (segments i xs1)
--}
-
-
--- | argument variables cannot be glued
-checkNoArgVars :: Term -> Err Term
-checkNoArgVars t = case t of
- Vr (IA _ _) -> Bad $ glueErrorMsg $ ppTerm Unqualified 0 t
- Vr (IAV _ _ _) -> Bad $ glueErrorMsg $ ppTerm Unqualified 0 t
- _ -> composOp checkNoArgVars t
-
-glueErrorMsg s =
- render (text "Cannot glue (+) term with run-time variable" <+> s <> char '.' $$
- text "Use Prelude.bind instead.")
-
-getArgType t = case t of
- V ty _ -> return ty
- T (TComp ty) _ -> return ty
- _ -> Bad (render (text "cannot get argument type of table" $$ nest 2 (ppTerm Unqualified 0 t)))
-
-
-checkPredefError :: SourceGrammar -> Term -> Err Term
-checkPredefError sgr t = case t of
- App (Q (mod,f)) s | mod == cPredef && f == cError -> Bad $ showTerm sgr TermPrintOne Unqualified s
- _ -> composOp (checkPredefError sgr) t
-
diff --git a/src/compiler/GF/Compile/Refresh.hs b/src/compiler/GF/Compile/Refresh.hs
deleted file mode 100644
index 999d8b083..000000000
--- a/src/compiler/GF/Compile/Refresh.hs
+++ /dev/null
@@ -1,153 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Refresh
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/21 16:22:27 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.6 $
---
--- (Description of the module)
------------------------------------------------------------------------------
-
-module GF.Compile.Refresh ({-refreshTermN, refreshTerm,
- refreshModule-}
- ) where
-{-
-import GF.Data.Operations
-import GF.Grammar.Grammar
-import GF.Infra.Ident
-import GF.Grammar.Macros
-import Control.Monad
-
-refreshTerm :: Term -> Err Term
-refreshTerm = refreshTermN 0
-
-refreshTermN :: Int -> Term -> Err Term
-refreshTermN i e = liftM snd $ refreshTermKN i e
-
-refreshTermKN :: Int -> Term -> Err (Int,Term)
-refreshTermKN i e = liftM (\ (t,(_,i)) -> (i,t)) $
- appSTM (refresh e) (initIdStateN i)
-
-refresh :: Term -> STM IdState Term
-refresh e = case e of
-
- Vr x -> liftM Vr (lookVar x)
- Abs b x t -> liftM2 (Abs b) (refVarPlus x) (refresh t)
-
- Prod b x a t -> do
- a' <- refresh a
- x' <- refVar x
- t' <- refresh t
- return $ Prod b x' a' t'
-
- Let (x,(mt,a)) b -> do
- a' <- refresh a
- mt' <- case mt of
- Just t -> refresh t >>= (return . Just)
- _ -> return mt
- x' <- refVar x
- b' <- refresh b
- return (Let (x',(mt',a')) b')
-
- R r -> liftM R $ refreshRecord r
-
- ExtR r s -> liftM2 ExtR (refresh r) (refresh s)
-
- T i cc -> liftM2 T (refreshTInfo i) (mapM refreshCase cc)
-
- App f a -> liftM2 App (inBlockSTM (refresh f)) (refresh a)
-
- _ -> composOp refresh e
-
-refreshCase :: (Patt,Term) -> STM IdState (Patt,Term)
-refreshCase (p,t) = liftM2 (,) (refreshPatt p) (refresh t)
-
-refreshPatt p = case p of
- PV x -> liftM PV (refVar x)
- PC c ps -> liftM (PC c) (mapM refreshPatt ps)
- PP c ps -> liftM (PP c) (mapM refreshPatt ps)
- PR r -> liftM PR (mapPairsM refreshPatt r)
- PT t p' -> liftM2 PT (refresh t) (refreshPatt p')
-
- PAs x p' -> liftM2 PAs (refVar x) (refreshPatt p')
-
- PSeq p' q' -> liftM2 PSeq (refreshPatt p') (refreshPatt q')
- PAlt p' q' -> liftM2 PAlt (refreshPatt p') (refreshPatt q')
- PRep p' -> liftM PRep (refreshPatt p')
- PNeg p' -> liftM PNeg (refreshPatt p')
-
- _ -> return p
-
-refreshRecord r = case r of
- [] -> return r
- (x,(mt,a)):b -> do
- a' <- refresh a
- mt' <- case mt of
- Just t -> refresh t >>= (return . Just)
- _ -> return mt
- b' <- refreshRecord b
- return $ (x,(mt',a')) : b'
-
-refreshTInfo i = case i of
- TTyped t -> liftM TTyped $ refresh t
- TComp t -> liftM TComp $ refresh t
- TWild t -> liftM TWild $ refresh t
- _ -> return i
-
--- for abstract syntax
-
-refreshEquation :: Equation -> Err ([Patt],Term)
-refreshEquation pst = err Bad (return . fst) (appSTM (refr pst) initIdState) where
- refr (ps,t) = liftM2 (,) (mapM refreshPatt ps) (refresh t)
-
--- for concrete and resource in grammar, before optimizing
-
---refreshGrammar :: SourceGrammar -> Err SourceGrammar
---refreshGrammar = liftM (mGrammar . snd) . foldM refreshModule (0,[]) . modules
-
-refreshModule :: (Int,SourceGrammar) -> SourceModule -> Err (Int,[SourceModule])
-refreshModule (k,sgr) mi@(i,mo)
- | isModCnc mo || isModRes mo = do
- (k',js') <- foldM refreshRes (k,[]) $ tree2list $ jments mo
- return (k', (i,mo{jments=buildTree js'}) : modules sgr)
- | otherwise = return (k, mi:modules sgr)
- where
- refreshRes (k,cs) ci@(c,info) = case info of
- ResOper ptyp (Just (L loc trm)) -> do ---- refresh ptyp
- (k',trm') <- refreshTermKN k trm
- return $ (k', (c, ResOper ptyp (Just (L loc trm'))):cs)
- ResOverload os tyts -> do
- (k',tyts') <- liftM (\ (t,(_,i)) -> (i,t)) $
- appSTM (mapPairsM (\(L loc t) -> liftM (L loc) (refresh t)) tyts) (initIdStateN k)
- return $ (k', (c, ResOverload os tyts'):cs)
- CncCat mt md mr mn mpmcfg-> do
- (k,md) <- case md of
- Just (L loc trm) -> do (k,trm) <- refreshTermKN k trm
- return (k,Just (L loc trm))
- Nothing -> return (k,Nothing)
- (k,mr) <- case mr of
- Just (L loc trm) -> do (k,trm) <- refreshTermKN k trm
- return (k,Just (L loc trm))
- Nothing -> return (k,Nothing)
- return (k, (c, CncCat mt md mr mn mpmcfg):cs)
- CncFun mt (Just (L loc trm)) mn mpmcfg -> do ---- refresh pn
- (k',trm') <- refreshTermKN k trm
- return $ (k', (c, CncFun mt (Just (L loc trm')) mn mpmcfg):cs)
- _ -> return (k, ci:cs)
-
-
--- running monad and returning to initial state
-
-inBlockSTM :: STM s a -> STM s a
-inBlockSTM mo = do
- s <- readSTM
- v <- mo
- writeSTM s
- return v
-
-
--} \ No newline at end of file
diff --git a/src/compiler/GF/Compile/SubExOpt.hs b/src/compiler/GF/Compile/SubExOpt.hs
index 4c056f479..56e41d55c 100644
--- a/src/compiler/GF/Compile/SubExOpt.hs
+++ b/src/compiler/GF/Compile/SubExOpt.hs
@@ -24,29 +24,29 @@
module GF.Compile.SubExOpt (subexpModule,unsubexpModule) where
import GF.Grammar.Grammar
-import GF.Grammar.Lookup
+import GF.Grammar.Lookup(lookupResDef)
import GF.Infra.Ident
import qualified GF.Grammar.Macros as C
-import GF.Data.Operations
+import GF.Data.ErrM(fromErr)
-import Control.Monad
+import Control.Monad.State.Strict(State,evalState,get,put)
import Data.Map (Map)
import qualified Data.Map as Map
-subexpModule :: SourceModule -> SourceModule
-subexpModule (n,mo) = errVal (n,mo) $ do
- let ljs = tree2list (jments mo)
- (tree,_) <- appSTM (getSubtermsMod n ljs) (Map.empty,0)
- js2 <- liftM buildTree $ addSubexpConsts n tree $ ljs
- return (n,mo{jments=js2})
+--subexpModule :: SourceModule -> SourceModule
+subexpModule (n,mo) =
+ let ljs = Map.toList (jments mo)
+ tree = evalState (getSubtermsMod n ljs) (Map.empty,0)
+ js2 = Map.fromList $ addSubexpConsts n tree $ ljs
+ in (n,mo{jments=js2})
-unsubexpModule :: SourceModule -> SourceModule
+--unsubexpModule :: SourceModule -> SourceModule
unsubexpModule sm@(i,mo)
| hasSub ljs = (i,mo{jments=rebuild (map unparInfo ljs)})
| otherwise = sm
where
- ljs = tree2list (jments mo)
+ ljs = Map.toList (jments mo)
-- perform this iff the module has opers
hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs]
@@ -57,33 +57,33 @@ unsubexpModule sm@(i,mo)
_ -> [(c,info)]
unparTerm t = case t of
Q (m,c) | isOperIdent c -> --- name convention of subexp opers
- errVal t $ liftM unparTerm $ lookupResDef gr (m,c)
+ fromErr t $ fmap unparTerm $ lookupResDef gr (m,c)
_ -> C.composSafeOp unparTerm t
gr = mGrammar [sm]
- rebuild = buildTree . concat
+ rebuild = Map.fromList . concat
-- implementation
type TermList = Map Term (Int,Int) -- number of occs, id
-type TermM a = STM (TermList,Int) a
+type TermM a = State (TermList,Int) a
addSubexpConsts ::
- Ident -> Map Term (Int,Int) -> [(Ident,Info)] -> Err [(Ident,Info)]
+ Ident -> Map Term (Int,Int) -> [(Ident,Info)] -> [(Ident,Info)]
addSubexpConsts mo tree lins = do
let opers = [oper id trm | (trm,(_,id)) <- list]
- mapM mkOne $ opers ++ lins
+ map mkOne $ opers ++ lins
where
mkOne (f,def) = case def of
- CncFun xs (Just (L loc trm)) pn pf -> do
- trm' <- recomp f trm
- return (f,CncFun xs (Just (L loc trm')) pn pf)
- ResOper ty (Just (L loc trm)) -> do
- trm' <- recomp f trm
- return (f,ResOper ty (Just (L loc trm')))
- _ -> return (f,def)
+ CncFun xs (Just (L loc trm)) pn pf ->
+ let trm' = recomp f trm
+ in (f,CncFun xs (Just (L loc trm')) pn pf)
+ ResOper ty (Just (L loc trm)) ->
+ let trm' = recomp f trm
+ in (f,ResOper ty (Just (L loc trm')))
+ _ -> (f,def)
recomp f t = case Map.lookup t tree of
- Just (_,id) | operIdent id /= f -> return $ Q (mo, operIdent id)
- _ -> C.composOp (recomp f) t
+ Just (_,id) | operIdent id /= f -> Q (mo, operIdent id)
+ _ -> C.composSafeOp (recomp f) t
list = Map.toList tree
@@ -93,7 +93,7 @@ addSubexpConsts mo tree lins = do
getSubtermsMod :: Ident -> [(Ident,Info)] -> TermM (Map Term (Int,Int))
getSubtermsMod mo js = do
mapM (getInfo (collectSubterms mo)) js
- (tree0,_) <- readSTM
+ (tree0,_) <- get
return $ Map.filter (\ (nu,_) -> nu > 1) tree0
where
getInfo get fi@(f,i) = case i of
@@ -123,12 +123,12 @@ collectSubterms mo t = case t of
where
collect = collectSubterms mo
add t = do
- (ts,i) <- readSTM
+ (ts,i) <- get
let
((count,id),next) = case Map.lookup t ts of
Just (nu,id) -> ((nu+1,id), i)
_ -> ((1, i ), i+1)
- writeSTM (Map.insert t (count,id) ts, next)
+ put (Map.insert t (count,id) ts, next)
return t --- only because of composOp
operIdent :: Int -> Ident
diff --git a/src/compiler/GF/CompileInParallel.hs b/src/compiler/GF/CompileInParallel.hs
index e9047b4e7..b0a69019e 100644
--- a/src/compiler/GF/CompileInParallel.hs
+++ b/src/compiler/GF/CompileInParallel.hs
@@ -66,7 +66,7 @@ batchCompile1 lib_dir (opts,filepaths) =
let rel = relativeTo lib_dir cwd
prelude_dir = lib_dir</>"prelude"
gfoDir = flag optGFODir opts
- maybe (return ()) (D.createDirectoryIfMissing True) gfoDir
+ maybe done (D.createDirectoryIfMissing True) gfoDir
{-
liftIO $ writeFile (maybe "" id gfoDir</>"paths")
(unlines . map (unwords . map rel) . nub $ map snd filepaths)
@@ -213,14 +213,14 @@ instance (Functor m,Monad m) => Applicative (CollectOutput m) where
(<*>) = ap
instance Monad m => Monad (CollectOutput m) where
- return x = CO (return (return (),x))
+ return x = CO (return (done,x))
CO m >>= f = CO $ do (o1,x) <- m
let CO m2 = f x
(o2,y) <- m2
return (o1>>o2,y)
instance MonadIO m => MonadIO (CollectOutput m) where
liftIO io = CO $ do x <- liftIO io
- return (return (),x)
+ return (done,x)
instance Output m => Output (CollectOutput m) where
ePutStr s = CO (return (ePutStr s,()))
diff --git a/src/compiler/GF/CompileOne.hs b/src/compiler/GF/CompileOne.hs
index 8c68f013a..17ef93935 100644
--- a/src/compiler/GF/CompileOne.hs
+++ b/src/compiler/GF/CompileOne.hs
@@ -21,7 +21,7 @@ import GF.Grammar.Binary(decodeModule,encodeModule)
import GF.Infra.Option
import GF.Infra.UseIO(FullPath,IOE,isGFO,gf2gfo,MonadIO(..),Output(..),putPointE)
import GF.Infra.CheckM(runCheck')
-import GF.Data.Operations(ErrorMonad,liftErr,(+++))
+import GF.Data.Operations(ErrorMonad,liftErr,(+++),done)
import GF.System.Directory(doesFileExist,getCurrentDirectory,renameFile)
import qualified Data.Map as Map
@@ -62,7 +62,7 @@ reuseGFO opts srcgr file =
if flag optTagsOnly opts
then writeTags opts srcgr (gf2gftags opts file) sm1
- else return ()
+ else done
return (Just file,sm)
@@ -132,7 +132,7 @@ compileSourceModule opts cwd mb_gfFile gr =
idump opts pass (dump out)
return (ret out)
- maybeM f = maybe (return ()) f
+ maybeM f = maybe done f
--writeGFO :: Options -> FilePath -> SourceModule -> IOE ()
@@ -151,12 +151,12 @@ writeGFO opts file mo =
--intermOut :: Options -> Dump -> Doc -> IOE ()
intermOut opts d doc
| dump opts d = ePutStrLn (render ("\n\n--#" <+> show d $$ doc))
- | otherwise = return ()
+ | otherwise = done
idump opts pass = intermOut opts (Dump pass) . ppModule Internal
warnOut opts warnings
- | null warnings = return ()
+ | null warnings = done
| otherwise = do ePutStr "\ESC[34m";ePutStr ws;ePutStrLn "\ESC[m"
where
ws = if flag optVerbosity opts == Normal
diff --git a/src/compiler/GF/Data/ErrM.hs b/src/compiler/GF/Data/ErrM.hs
index d687a70a5..033c1efac 100644
--- a/src/compiler/GF/Data/ErrM.hs
+++ b/src/compiler/GF/Data/ErrM.hs
@@ -12,15 +12,25 @@
-- hack for BNFC generated files. AR 21/9/2003
-----------------------------------------------------------------------------
-module GF.Data.ErrM (Err(..)) where
+module GF.Data.ErrM where
import Control.Monad (MonadPlus(..),ap)
import Control.Applicative
--- | like @Maybe@ type with error msgs
+-- | Like 'Maybe' type with error msgs
data Err a = Ok a | Bad String
deriving (Read, Show, Eq)
+-- | Analogue of 'maybe'
+err :: (String -> b) -> (a -> b) -> Err a -> b
+err d f e = case e of
+ Ok a -> f a
+ Bad s -> d s
+
+-- | Analogue of 'fromMaybe'
+fromErr :: a -> Err a -> a
+fromErr a = err (const a) id
+
instance Monad Err where
return = Ok
fail = Bad
diff --git a/src/compiler/GF/Data/Operations.hs b/src/compiler/GF/Data/Operations.hs
index 69b089623..6d93fec92 100644
--- a/src/compiler/GF/Data/Operations.hs
+++ b/src/compiler/GF/Data/Operations.hs
@@ -18,20 +18,20 @@ module GF.Data.Operations (-- ** Misc functions
ifNull,
-- ** The Error monad
- Err(..), err, maybeErr, testErr, errVal, errIn,
+ Err(..), err, maybeErr, testErr, fromErr, errIn,
lookupErr,
+
+ --- ** Monadic operations on lists and pairs
mapPairListM, mapPairsM, pairM,
- singleton, --mapsErr, mapsErrTree,
-- ** Checking
checkUnique, unifyMaybeBy, unifyMaybe,
-- ** Binary search trees; now with FiniteMap
- BinTree, emptyBinTree, isInBinTree, justLookupTree,
+ BinTree, emptyBinTree, isInBinTree, --justLookupTree,
lookupTree, --lookupTreeMany,
lookupTreeManyAll, updateTree,
buildTree, filterBinTree,
- --sorted2tree,
mapTree, --mapMTree,
tree2list,
@@ -43,7 +43,7 @@ module GF.Data.Operations (-- ** Misc functions
numberedParagraphs, prConjList, prIfEmpty, wrapLines,
-- ** Extra
- combinations,
+ combinations, done, readIntArg, --singleton,
-- ** Topological sorting with test of cyclicity
topoTest, topoTest2,
@@ -52,13 +52,13 @@ module GF.Data.Operations (-- ** Misc functions
iterFix,
-- ** Chop into separator-separated parts
- chunks, readIntArg,
-
+ chunks,
+{-
-- ** State monad with error; from Agda 6\/11\/2001
- STM(..), appSTM, stm, stmr, readSTM, updateSTM, writeSTM, done,
-
+ STM(..), appSTM, stm, stmr, readSTM, updateSTM, writeSTM,
+-}
-- ** Error monad class
- ErrorMonad(..), checkAgain, checks, allChecks, doUntil,
+ ErrorMonad(..), checks, allChecks, doUntil, --checkAgain,
liftErr
) where
@@ -67,8 +67,8 @@ import Data.Char (isSpace, toUpper, isSpace, isDigit)
import Data.List (nub, partition, (\\))
import qualified Data.Map as Map
import Data.Map (Map)
-import Control.Applicative(Applicative(..))
-import Control.Monad (liftM,liftM2,ap)
+--import Control.Applicative(Applicative(..))
+import Control.Monad (liftM,liftM2) --,ap
import GF.Data.ErrM
import GF.Data.Relation
@@ -83,21 +83,12 @@ ifNull b f xs = if null xs then b else f xs
-- the Error monad
--- | analogue of @maybe@
-err :: (String -> b) -> (a -> b) -> Err a -> b
-err d f e = case e of
- Ok a -> f a
- Bad s -> d s
-
--- | add msg s to @Maybe@ failures
+-- | Add msg s to 'Maybe' failures
maybeErr :: ErrorMonad m => String -> Maybe a -> m a
maybeErr s = maybe (raise s) return
testErr :: ErrorMonad m => Bool -> String -> m ()
-testErr cond msg = if cond then return () else raise msg
-
-errVal :: a -> Err a -> a
-errVal a = err (const a) id
+testErr cond msg = if cond then done else raise msg
errIn :: ErrorMonad m => String -> m a -> m a
errIn msg m = handle m (\s -> raise (s ++++ "OCCURRED IN" ++++ msg))
@@ -111,12 +102,9 @@ mapPairListM f xys = mapM (\ p@(x,_) -> liftM ((,) x) (f p)) xys
mapPairsM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)]
mapPairsM f xys = mapM (\ (x,y) -> liftM ((,) x) (f y)) xys
-pairM :: Monad a => (b -> a c) -> (b,b) -> a (c,c)
+pairM :: Monad m => (b -> m c) -> (b,b) -> m (c,c)
pairM op (t1,t2) = liftM2 (,) (op t1) (op t2)
-singleton :: a -> [a]
-singleton = (:[])
-
-- checking
checkUnique :: (Show a, Eq a) => [a] -> [String]
@@ -144,21 +132,14 @@ emptyBinTree = Map.empty
isInBinTree :: (Ord a) => a -> BinTree a b -> Bool
isInBinTree = Map.member
-
-justLookupTree :: (Monad m,Ord a) => a -> BinTree a b -> m b
-justLookupTree = lookupTree (const [])
-
-lookupTree :: (Monad m,Ord a) => (a -> String) -> a -> BinTree a b -> m b
-lookupTree pr x tree = case Map.lookup x tree of
- Just y -> return y
- _ -> fail ("no occurrence of element" +++ pr x)
{-
-lookupTreeMany :: Ord a => (a -> String) -> [BinTree a b] -> a -> Err b
-lookupTreeMany pr (t:ts) x = case lookupTree pr x t of
- Ok v -> return v
- _ -> lookupTreeMany pr ts x
-lookupTreeMany pr [] x = Bad $ "failed to find" +++ pr x
+justLookupTree :: (ErrorMonad m,Ord a) => a -> BinTree a b -> m b
+justLookupTree = lookupTree (const [])
-}
+lookupTree :: (ErrorMonad m,Ord a) => (a -> String) -> a -> BinTree a b -> m b
+lookupTree pr x = maybeErr no . Map.lookup x
+ where no = "no occurrence of element" +++ pr x
+
lookupTreeManyAll :: Ord a => (a -> String) -> [BinTree a b] -> a -> [b]
lookupTreeManyAll pr (t:ts) x = case lookupTree pr x t of
Ok v -> v : lookupTreeManyAll pr ts x
@@ -170,16 +151,10 @@ updateTree (a,b) = Map.insert a b
buildTree :: (Ord a) => [(a,b)] -> BinTree a b
buildTree = Map.fromList
-{-
-sorted2tree :: Ord a => [(a,b)] -> BinTree a b
-sorted2tree = Map.fromAscList
--}
+
mapTree :: ((a,b) -> c) -> BinTree a b -> BinTree a c
mapTree f = Map.mapWithKey (\k v -> f (k,v))
-{-
-mapMTree :: (Ord a,Monad m) => ((a,b) -> m c) -> BinTree a b -> m (BinTree a c)
-mapMTree f t = liftM Map.fromList $ sequence [liftM ((,) k) (f (k,x)) | (k,x) <- Map.toList t]
--}
+
filterBinTree :: Ord a => (a -> b -> Bool) -> BinTree a b -> BinTree a b
filterBinTree = Map.filterWithKey
@@ -269,13 +244,19 @@ wrapLines n s@(c:cs) =
--- optWrapLines = if argFlag "wraplines" True then wrapLines 0 else id
--- | 'combinations' is the same as @sequence@!!!
+-- | 'combinations' is the same as 'sequence'!!!
-- peb 30\/5-04
combinations :: [[a]] -> [[a]]
combinations t = case t of
[] -> [[]]
aa:uu -> [a:u | a <- aa, u <- combinations uu]
+{-
+-- | 'singleton' is the same as 'return'!!!
+singleton :: a -> [a]
+singleton = (:[])
+-}
+
-- | topological sorting with test of cyclicity
topoTest :: Ord a => [(a,[a])] -> Either [a] [[a]]
topoTest = topologicalSort . mkRel'
@@ -315,7 +296,7 @@ chunks sep ws = case span (/= sep) ws of
readIntArg :: String -> Int
readIntArg n = if (not (null n) && all isDigit n) then read n else 0
-
+{-
-- state monad with error; from Agda 6/11/2001
newtype STM s a = STM (s -> Err (a,s))
@@ -350,7 +331,7 @@ updateSTM f = stmr (\s -> ((),f s))
writeSTM :: s -> STM s ()
writeSTM s = stmr (const ((),s))
-
+-}
done :: Monad m => m ()
done = return ()
@@ -366,28 +347,13 @@ instance ErrorMonad Err where
handle (Bad i) f = f i
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` (\e -> let STM g' = (g e) in
g' s))
-{-
--- error recovery with multiple reporting AR 30/5/2008
-mapsErr :: (a -> Err b) -> [a] -> Err [b]
-
-mapsErr f = seqs . map f where
- seqs es = case es of
- Ok v : ms -> case seqs ms of
- Ok vs -> return (v : vs)
- b -> b
- Bad s : ms -> case seqs ms of
- Ok vs -> Bad s
- Bad ss -> Bad (s +++++ ss)
- [] -> return []
-
-mapsErrTree :: (Ord a) => ((a,b) -> Err (a,c)) -> BinTree a b -> Err (BinTree a c)
-mapsErrTree f t = mapsErr f (tree2list t) >>= return . sorted2tree
+
-}
-- | if the first check fails try another one
diff --git a/src/compiler/GF/Grammar/Analyse.hs b/src/compiler/GF/Grammar/Analyse.hs
index 023b76ad3..adab6fcf5 100644
--- a/src/compiler/GF/Grammar/Analyse.hs
+++ b/src/compiler/GF/Grammar/Analyse.hs
@@ -46,7 +46,7 @@ constantDeps :: SourceGrammar -> QIdent -> Err [QIdent]
constantDeps sgr f = return $ nub $ iterFix more start where
start = constants f
more = concatMap constants
- constants c = (c :) $ errVal [] $ do
+ constants c = (c :) $ fromErr [] $ do
ts <- termsOfConstant sgr c
return $ concatMap constantsInTerm ts
diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs
index da75267de..e5ead0f13 100644
--- a/src/compiler/GF/Grammar/Lookup.hs
+++ b/src/compiler/GF/Grammar/Lookup.hs
@@ -123,7 +123,7 @@ lookupOrigInfo gr (m,c) = do
i -> return (m,i)
allOrigInfos :: SourceGrammar -> Ident -> [(QIdent,Info)]
-allOrigInfos gr m = errVal [] $ do
+allOrigInfos gr m = fromErr [] $ do
mo <- lookupModule gr m
return [((m,c),i) | (c,_) <- tree2list (jments mo), Ok (m,i) <- [lookupOrigInfo gr (m,c)]]
diff --git a/src/compiler/GF/Grammar/MMacros.hs b/src/compiler/GF/Grammar/MMacros.hs
index 66d8a857f..30271a2d5 100644
--- a/src/compiler/GF/Grammar/MMacros.hs
+++ b/src/compiler/GF/Grammar/MMacros.hs
@@ -151,7 +151,7 @@ substTerm ss g c = case c of
_ -> c
metaSubstExp :: MetaSubst -> [(MetaId,Exp)]
-metaSubstExp msubst = [(m, errVal (meta2exp m) (val2expSafe v)) | (m,v) <- msubst]
+metaSubstExp msubst = [(m, fromErr (meta2exp m) (val2expSafe v)) | (m,v) <- msubst]
-- ** belong here rather than to computation
diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs
index f5ddb7ae0..66ef50ce9 100644
--- a/src/compiler/GF/Grammar/Macros.hs
+++ b/src/compiler/GF/Grammar/Macros.hs
@@ -91,7 +91,7 @@ isRecursiveType t =
in any (== c) cc
isHigherOrderType :: Type -> Bool
-isHigherOrderType t = errVal True $ do -- pessimistic choice
+isHigherOrderType t = fromErr True $ do -- pessimistic choice
co <- contextOfType t
return $ not $ null [x | (_,x,Prod _ _ _ _) <- co]
diff --git a/src/compiler/GF/Infra/Ident.hs b/src/compiler/GF/Infra/Ident.hs
index 3c5402985..71e86fb37 100644
--- a/src/compiler/GF/Infra/Ident.hs
+++ b/src/compiler/GF/Infra/Ident.hs
@@ -138,70 +138,3 @@ wild = Id (pack "_")
varIndex :: Ident -> Int
varIndex (IV _ n) = n
varIndex _ = -1 --- other than IV should not count
-
-{-
--- * Refreshing identifiers
-
-type IdState = ([(Ident,Ident)],Int)
-
-initIdStateN :: Int -> IdState
-initIdStateN i = ([],i)
-
-initIdState :: IdState
-initIdState = initIdStateN 0
-
-lookVar :: Ident -> STM IdState Ident
-lookVar a@(IA _ _) = return a
-lookVar x = do
- (sys,_) <- readSTM
- stm (\s -> maybe (Bad ("cannot find" +++ show x +++ prParenth (show sys)))
- return $
- lookup x sys >>= (\y -> return (y,s)))
-
-refVar :: Ident -> STM IdState Ident
-----refVar IW = return IW --- no update of wildcard
-refVar x = do
- (_,m) <- readSTM
- let x' = IV (ident2raw x) m
- updateSTM (\(sys,mx) -> ((x, x'):sys, mx + 1))
- return x'
-
-refVarPlus :: Ident -> STM IdState Ident
-----refVarPlus IW = refVar (identC "h")
-refVarPlus x = refVar x
--}
-
-{-
-------------------------------
--- to test
-
-refreshExp :: Exp -> Err Exp
-refreshExp e = err Bad (return . fst) (appSTM (refresh e) initState)
-
-refresh :: Exp -> STM State Exp
-refresh e = case e of
- Atom x -> lookVar x >>= return . Atom
- App f a -> liftM2 App (refresh f) (refresh a)
- Abs x b -> liftM2 Abs (refVar x) (refresh b)
- Fun xs a b -> do
- a' <- refresh a
- xs' <- mapM refVar xs
- b' <- refresh b
- return $ Fun xs' a' b'
-
-data Exp =
- Atom Ident
- | App Exp Exp
- | Abs Ident Exp
- | Fun [Ident] Exp Exp
- deriving Show
-
-exp1 = Abs (IC "y") (Atom (IC "y"))
-exp2 = Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "y")))
-exp3 = Abs (IC "y") (Abs (IC "z") (App (Atom (IC "y")) (Atom (IC "z"))))
-exp4 = Abs (IC "y") (Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "z"))))
-exp5 = Abs (IC "y") (Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "y"))))
-exp6 = Abs (IC "y") (Fun [IC "x", IC "y"] (Atom (IC "y")) (Atom (IC "y")))
-exp7 = Abs (IL "8") (Atom (IC "y"))
-
--}
diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs
index 18bee2e49..2af5b092b 100644
--- a/src/compiler/GF/Interactive.hs
+++ b/src/compiler/GF/Interactive.hs
@@ -8,7 +8,7 @@ import GF.Command.Interpreter(CommandEnv(..),commands,mkCommandEnv,emptyCommandE
import GF.Command.Commands(flags,options)
import GF.Command.Abstract
import GF.Command.Parse(readCommandLine,pCommand)
-import GF.Data.Operations (Err(..),chunks,err,raise)
+import GF.Data.Operations (Err(..),chunks,err,raise,done)
import GF.Grammar hiding (Ident,isPrefixOf)
import GF.Grammar.Analyse
import GF.Grammar.Parser (runP, pExp)
@@ -83,7 +83,7 @@ mainServerGFI opts files =
-- | Read end execute commands until it is time to quit
loop :: Options -> GFEnv -> IO ()
-loop opts gfenv = maybe (return ()) (loop opts) =<< readAndExecute1 opts gfenv
+loop opts gfenv = maybe done (loop opts) =<< readAndExecute1 opts gfenv
-- | Read and execute one command, returning Just an updated environment for
-- | the next command, or Nothing when it is time to quit
@@ -363,7 +363,7 @@ importInEnv gfenv opts files
pgf1 <- importGrammar pgf0 opts' files
if (verbAtLeast opts Normal)
then putStrLnFlush $ unwords $ "\nLanguages:" : map showCId (languages pgf1)
- else return ()
+ else done
return $ gfenv { commandenv = mkCommandEnv pgf1 }
tryGetLine = do
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 08:18:25 +0000