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

Remove some dead code

Browse Source 
* The following modules are no longer used and have been removed completely:

	GF.Compile.Compute.ConcreteLazy
	GF.Compile.Compute.ConcreteStrict
	GF.Compile.Refresh

* The STM monad has been commented out. It was only used in
  GF.Compile.SubExpOpt, where could be replaced with a plain State monad,
  since no error handling was needed. One of the functions was hardwired to
  the Err monad, but did in fact not use error handling, so it was turned
  into a pure function.

* The function errVal has been renamed to fromErr (since it is analogous to
  fromMaybe).

* Replaced 'fail' with 'raise' and 'return ()' with 'done' in a few places.

* Some additional old code that was already commented out has been removed.
This commit is contained in:
hallgren
2014-10-20 15:05:43 +00:00
parent bb1f0f3368
commit 55aebadd5a
14 changed files with 88 additions and 1357 deletions
Download Patch File Download Diff File Expand all files Collapse all files

531
src/compiler/GF/Compile/Compute/ConcreteLazy.hs
View File

@@ -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)
-}
-}

494
src/compiler/GF/Compile/Compute/ConcreteStrict.hs
View File

@@ -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

153
src/compiler/GF/Compile/Refresh.hs
View File

@@ -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
-}

56
src/compiler/GF/Compile/SubExOpt.hs
View File

@@ -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

6
src/compiler/GF/CompileInParallel.hs
View File

@@ -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,()))

10
src/compiler/GF/CompileOne.hs
View File

@@ -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

14
src/compiler/GF/Data/ErrM.hs
View File

@@ -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

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

@@ -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

2
src/compiler/GF/Grammar/Analyse.hs
View File

@@ -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

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

@@ -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)]]

2
src/compiler/GF/Grammar/MMacros.hs
View File

@@ -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

2
src/compiler/GF/Grammar/Macros.hs
View File

@@ -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]

67
src/compiler/GF/Infra/Ident.hs
View File

@@ -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"))
-}

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

@@ -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