gf-3.6: src/compiler/GF/Compile/Compute/ConcreteStrict.hs
----------------------------------------------------------------------
-- |
-- 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 Text.PrettyPrint
----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