summaryrefslogtreecommitdiff
path: root/src/GF/Compile
diff options
context:
space:
mode:
authorkrasimir <krasimir@chalmers.se>2009-12-13 18:50:29 +0000
committerkrasimir <krasimir@chalmers.se>2009-12-13 18:50:29 +0000
commitf85232947e74ee7ef8c7b0ad2338212e7e68f1be (patch)
tree667b886a5e3a4b026a63d4e3597f32497d824761 /src/GF/Compile
parentd88a865faff59c98fc91556ff8700b10ee5f2df8 (diff)
reorganize the directories under src, and rescue the JavaScript interpreter from deprecated
Diffstat (limited to 'src/GF/Compile')
-rw-r--r--src/GF/Compile/Abstract/Compute.hs138
-rw-r--r--src/GF/Compile/Abstract/TC.hs294
-rw-r--r--src/GF/Compile/Abstract/TypeCheck.hs83
-rw-r--r--src/GF/Compile/CheckGrammar.hs284
-rw-r--r--src/GF/Compile/Coding.hs55
-rw-r--r--src/GF/Compile/Concrete/AppPredefined.hs158
-rw-r--r--src/GF/Compile/Concrete/Compute.hs456
-rw-r--r--src/GF/Compile/Concrete/TypeCheck.hs690
-rw-r--r--src/GF/Compile/Export.hs64
-rw-r--r--src/GF/Compile/GFCCtoHaskell.hs230
-rw-r--r--src/GF/Compile/GFCCtoJS.hs138
-rw-r--r--src/GF/Compile/GFCCtoProlog.hs279
-rw-r--r--src/GF/Compile/GenerateFCFG.hs568
-rw-r--r--src/GF/Compile/GeneratePMCFG.hs510
-rw-r--r--src/GF/Compile/GeneratePMCFGOld.hs374
-rw-r--r--src/GF/Compile/GetGrammar.hs52
-rw-r--r--src/GF/Compile/GrammarToGFCC.hs587
-rw-r--r--src/GF/Compile/ModDeps.hs145
-rw-r--r--src/GF/Compile/Optimize.hs228
-rw-r--r--src/GF/Compile/OptimizeGFCC.hs121
-rw-r--r--src/GF/Compile/PGFPretty.hs93
-rw-r--r--src/GF/Compile/ReadFiles.hs220
-rw-r--r--src/GF/Compile/Refresh.hs133
-rw-r--r--src/GF/Compile/Rename.hs313
-rw-r--r--src/GF/Compile/SubExOpt.hs142
-rw-r--r--src/GF/Compile/Update.hs226
26 files changed, 0 insertions, 6581 deletions
diff --git a/src/GF/Compile/Abstract/Compute.hs b/src/GF/Compile/Abstract/Compute.hs
deleted file mode 100644
index d5c9a163c..000000000
--- a/src/GF/Compile/Abstract/Compute.hs
+++ /dev/null
@@ -1,138 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : GF.Compile.Abstract.Compute
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/10/02 20:50:19 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.8 $
---
--- computation in abstract syntax w.r.t. explicit definitions.
---
--- old GF computation; to be updated
------------------------------------------------------------------------------
-
-module GF.Compile.Abstract.Compute (LookDef,
- compute,
- computeAbsTerm,
- computeAbsTermIn,
- beta
- ) where
-
-import GF.Data.Operations
-
-import GF.Grammar
-import GF.Grammar.Lookup
-
-import Debug.Trace
-import Data.List(intersperse)
-import Control.Monad (liftM, liftM2)
-import Text.PrettyPrint
-
--- for debugging
-tracd m t = t
--- tracd = trace
-
-compute :: SourceGrammar -> Exp -> Err Exp
-compute = computeAbsTerm
-
-computeAbsTerm :: SourceGrammar -> Exp -> Err Exp
-computeAbsTerm gr = computeAbsTermIn (lookupAbsDef gr) []
-
--- | a hack to make compute work on source grammar as well
-type LookDef = Ident -> Ident -> Err (Maybe Int,Maybe [Equation])
-
-computeAbsTermIn :: LookDef -> [Ident] -> Exp -> Err Exp
-computeAbsTermIn lookd xs e = errIn (render (text "computing" <+> ppTerm Unqualified 0 e)) $ compt xs e where
- compt vv t = case t of
--- Prod x a b -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b)
--- Abs x b -> liftM (Abs x) (compt (x:vv) b)
- _ -> do
- let t' = beta vv t
- (yy,f,aa) <- termForm t'
- let vv' = map snd yy ++ vv
- aa' <- mapM (compt vv') aa
- case look f of
- Just eqs -> tracd (text "\nmatching" <+> ppTerm Unqualified 0 f) $
- case findMatch eqs aa' of
- Ok (d,g) -> do
- --- let (xs,ts) = unzip g
- --- ts' <- alphaFreshAll vv' ts
- let g' = g --- zip xs ts'
- d' <- compt vv' $ substTerm vv' g' d
- tracd (text "by Egs:" <+> ppTerm Unqualified 0 d') $ return $ mkAbs yy $ d'
- _ -> tracd (text "no match" <+> ppTerm Unqualified 0 t') $
- do
- let v = mkApp f aa'
- return $ mkAbs yy $ v
- _ -> do
- let t2 = mkAbs yy $ mkApp f aa'
- tracd (text "not defined" <+> ppTerm Unqualified 0 t2) $ return t2
-
- look t = case t of
- (Q m f) -> case lookd m f of
- Ok (_,md) -> md
- _ -> Nothing
- _ -> Nothing
-
-beta :: [Ident] -> Exp -> Exp
-beta vv c = case c of
- Let (x,(_,a)) b -> beta vv $ substTerm vv [(x,beta vv a)] (beta (x:vv) b)
- App f a ->
- let (a',f') = (beta vv a, beta vv f) in
- case f' of
- Abs _ x b -> beta vv $ substTerm vv [(x,a')] (beta (x:vv) b)
- _ -> (if a'==a && f'==f then id else beta vv) $ App f' a'
- Prod b x a t -> Prod b x (beta vv a) (beta (x:vv) t)
- Abs b x t -> Abs b x (beta (x:vv) t)
- _ -> c
-
--- special version of pattern matching, to deal with comp under lambda
-
-findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution)
-findMatch cases terms = case cases of
- [] -> Bad $ render (text "no applicable case for" <+> hcat (punctuate comma (map (ppTerm Unqualified 0) terms)))
- (patts,_):_ | length patts /= length terms ->
- Bad (render (text "wrong number of args for patterns :" <+>
- hsep (map (ppPatt Unqualified 0) patts) <+> text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms)))
- (patts,val):cc -> case mapM tryMatch (zip patts terms) of
- Ok substs -> return (tracd (text "value" <+> ppTerm Unqualified 0 val) val, concat substs)
- _ -> findMatch cc terms
-
-tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
-tryMatch (p,t) = do
- t' <- termForm t
- trym p t'
- where
-
- trym p t' = err (\s -> tracd s (Bad s)) (\t -> tracd (prtm p t) (return t)) $ ----
- case (p,t') of
- (PW, _) | notMeta t -> return [] -- optimization with wildcard
- (PV x, _) | notMeta t -> return [(x,t)]
- (PString s, ([],K i,[])) | s==i -> return []
- (PInt s, ([],EInt i,[])) | s==i -> return []
- (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
- (PP q p pp, ([], QC r f, tt)) |
- p `eqStrIdent` f && length pp == length tt -> do
- matches <- mapM tryMatch (zip pp tt)
- return (concat matches)
- (PP q p pp, ([], Q r f, tt)) |
- p `eqStrIdent` f && length pp == length tt -> do
- matches <- mapM tryMatch (zip pp tt)
- return (concat matches)
- (PT _ p',_) -> trym p' t'
- (PAs x p',_) -> do
- subst <- trym p' t'
- return $ (x,t) : subst
- _ -> Bad (render (text "no match in pattern" <+> ppPatt Unqualified 0 p <+> text "for" <+> ppTerm Unqualified 0 t))
-
- notMeta e = case e of
- Meta _ -> False
- App f a -> notMeta f && notMeta a
- Abs _ _ b -> notMeta b
- _ -> True
-
- prtm p g =
- ppPatt Unqualified 0 p <+> colon $$ hsep (punctuate semi [ppIdent x <+> char '=' <+> ppTerm Unqualified 0 y | (x,y) <- g])
diff --git a/src/GF/Compile/Abstract/TC.hs b/src/GF/Compile/Abstract/TC.hs
deleted file mode 100644
index 163301838..000000000
--- a/src/GF/Compile/Abstract/TC.hs
+++ /dev/null
@@ -1,294 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : TC
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/10/02 20:50:19 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.11 $
---
--- Thierry Coquand's type checking algorithm that creates a trace
------------------------------------------------------------------------------
-
-module GF.Compile.Abstract.TC (AExp(..),
- Theory,
- checkExp,
- inferExp,
- checkBranch,
- eqVal,
- whnf
- ) where
-
-import GF.Data.Operations
-import GF.Grammar
-import GF.Grammar.Predef
-
-import Control.Monad
-import Data.List (sortBy)
-import Data.Maybe
-import Text.PrettyPrint
-
-data AExp =
- AVr Ident Val
- | ACn QIdent Val
- | AType
- | AInt Integer
- | AFloat Double
- | AStr String
- | AMeta MetaId Val
- | AApp AExp AExp Val
- | AAbs Ident Val AExp
- | AProd Ident AExp AExp
- | AEqs [([Exp],AExp)] --- not used
- | ARecType [ALabelling]
- | AR [AAssign]
- | AP AExp Label Val
- | AData Val
- deriving (Eq,Show)
-
-type ALabelling = (Label, AExp)
-type AAssign = (Label, (Val, AExp))
-
-type Theory = QIdent -> Err Val
-
-lookupConst :: Theory -> QIdent -> Err Val
-lookupConst th f = th f
-
-lookupVar :: Env -> Ident -> Err Val
-lookupVar g x = maybe (Bad (render (text "unknown variable" <+> ppIdent x))) return $ lookup x ((IW,uVal):g)
--- wild card IW: no error produced, ?0 instead.
-
-type TCEnv = (Int,Env,Env)
-
-emptyTCEnv :: TCEnv
-emptyTCEnv = (0,[],[])
-
-whnf :: Val -> Err Val
-whnf v = ---- errIn ("whnf" +++ prt v) $ ---- debug
- case v of
- VApp u w -> do
- u' <- whnf u
- w' <- whnf w
- app u' w'
- VClos env e -> eval env e
- _ -> return v
-
-app :: Val -> Val -> Err Val
-app u v = case u of
- VClos env (Abs _ x e) -> eval ((x,v):env) e
- _ -> return $ VApp u v
-
-eval :: Env -> Exp -> Err Val
-eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
- case e of
- Vr x -> lookupVar env x
- Q m c -> return $ VCn (m,c)
- QC m c -> return $ VCn (m,c) ---- == Q ?
- Sort c -> return $ VType --- the only sort is Type
- App f a -> join $ liftM2 app (eval env f) (eval env a)
- RecType xs -> do xs <- mapM (\(l,e) -> eval env e >>= \e -> return (l,e)) xs
- return (VRecType xs)
- _ -> return $ VClos env e
-
-eqVal :: Int -> Val -> Val -> Err [(Val,Val)]
-eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $
- do
- w1 <- whnf u1
- w2 <- whnf u2
- let v = VGen k
- case (w1,w2) of
- (VApp f1 a1, VApp f2 a2) -> liftM2 (++) (eqVal k f1 f2) (eqVal k a1 a2)
- (VClos env1 (Abs _ x1 e1), VClos env2 (Abs _ x2 e2)) ->
- eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2)
- (VClos env1 (Prod _ x1 a1 e1), VClos env2 (Prod _ x2 a2 e2)) ->
- liftM2 (++)
- (eqVal k (VClos env1 a1) (VClos env2 a2))
- (eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2))
- (VGen i _, VGen j _) -> return [(w1,w2) | i /= j]
- (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j]
- --- thus ignore qualifications; valid because inheritance cannot
- --- be qualified. Simplifies annotation. AR 17/3/2005
- _ -> return [(w1,w2) | w1 /= w2]
--- invariant: constraints are in whnf
-
-checkType :: Theory -> TCEnv -> Exp -> Err (AExp,[(Val,Val)])
-checkType th tenv e = checkExp th tenv e vType
-
-checkExp :: Theory -> TCEnv -> Exp -> Val -> Err (AExp, [(Val,Val)])
-checkExp th tenv@(k,rho,gamma) e ty = do
- typ <- whnf ty
- let v = VGen k
- case e of
- Meta m -> return $ (AMeta m typ,[])
-
- Abs _ x t -> case typ of
- VClos env (Prod _ y a b) -> do
- a' <- whnf $ VClos env a ---
- (t',cs) <- checkExp th
- (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
- return (AAbs x a' t', cs)
- _ -> Bad (render (text "function type expected for" <+> ppTerm Unqualified 0 e <+> text "instead of" <+> ppValue Unqualified 0 typ))
-
- Prod _ x a b -> do
- testErr (typ == vType) "expected Type"
- (a',csa) <- checkType th tenv a
- (b',csb) <- checkType th (k+1, (x,v x):rho, (x,VClos rho a):gamma) b
- return (AProd x a' b', csa ++ csb)
-
- R xs ->
- case typ of
- VRecType ys -> do case [l | (l,_) <- ys, isNothing (lookup l xs)] of
- [] -> return ()
- ls -> fail (render (text "no value given for label:" <+> fsep (punctuate comma (map ppLabel ls))))
- r <- mapM (checkAssign th tenv ys) xs
- let (xs,css) = unzip r
- return (AR xs, concat css)
- _ -> Bad (render (text "record type expected for" <+> ppTerm Unqualified 0 e <+> text "instead of" <+> ppValue Unqualified 0 typ))
-
- P r l -> do (r',cs) <- checkExp th tenv r (VRecType [(l,typ)])
- return (AP r' l typ,cs)
-
- _ -> checkInferExp th tenv e typ
-
-checkInferExp :: Theory -> TCEnv -> Exp -> Val -> Err (AExp, [(Val,Val)])
-checkInferExp th tenv@(k,_,_) e typ = do
- (e',w,cs1) <- inferExp th tenv e
- cs2 <- eqVal k w typ
- return (e',cs1 ++ cs2)
-
-inferExp :: Theory -> TCEnv -> Exp -> Err (AExp, Val, [(Val,Val)])
-inferExp th tenv@(k,rho,gamma) e = case e of
- Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x
- Q m c | m == cPredefAbs && isPredefCat c
- -> return (ACn (m,c) vType, vType, [])
- | otherwise -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c)
- QC m c -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c) ----
- EInt i -> return (AInt i, valAbsInt, [])
- EFloat i -> return (AFloat i, valAbsFloat, [])
- K i -> return (AStr i, valAbsString, [])
- Sort _ -> return (AType, vType, [])
- RecType xs -> do r <- mapM (checkLabelling th tenv) xs
- let (xs,css) = unzip r
- return (ARecType xs, vType, concat css)
- App f t -> do
- (f',w,csf) <- inferExp th tenv f
- typ <- whnf w
- case typ of
- VClos env (Prod _ x a b) -> do
- (a',csa) <- checkExp th tenv t (VClos env a)
- b' <- whnf $ VClos ((x,VClos rho t):env) b
- return $ (AApp f' a' b', b', csf ++ csa)
- _ -> Bad (render (text "Prod expected for function" <+> ppTerm Unqualified 0 f <+> text "instead of" <+> ppValue Unqualified 0 typ))
- _ -> Bad (render (text "cannot infer type of expression" <+> ppTerm Unqualified 0 e))
-
-checkLabelling :: Theory -> TCEnv -> Labelling -> Err (ALabelling, [(Val,Val)])
-checkLabelling th tenv (lbl,typ) = do
- (atyp,cs) <- checkType th tenv typ
- return ((lbl,atyp),cs)
-
-checkAssign :: Theory -> TCEnv -> [(Label,Val)] -> Assign -> Err (AAssign, [(Val,Val)])
-checkAssign th tenv@(k,rho,gamma) typs (lbl,(Just typ,exp)) = do
- (atyp,cs1) <- checkType th tenv typ
- val <- eval rho typ
- cs2 <- case lookup lbl typs of
- Nothing -> return []
- Just val0 -> eqVal k val val0
- (aexp,cs3) <- checkExp th tenv exp val
- return ((lbl,(val,aexp)),cs1++cs2++cs3)
-checkAssign th tenv@(k,rho,gamma) typs (lbl,(Nothing,exp)) = do
- case lookup lbl typs of
- Nothing -> do (aexp,val,cs) <- inferExp th tenv exp
- return ((lbl,(val,aexp)),cs)
- Just val -> do (aexp,cs) <- checkExp th tenv exp val
- return ((lbl,(val,aexp)),cs)
-
-checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Exp],AExp),[(Val,Val)])
-checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
- chB tenv' ps' ty
- where
-
- (ps',_,rho2,k') = ps2ts k ps
- tenv' = (k, rho2++rho, gamma) ---- k' ?
- (k,rho,gamma) = tenv
-
- chB tenv@(k,rho,gamma) ps ty = case ps of
- p:ps2 -> do
- typ <- whnf ty
- case typ of
- VClos env (Prod _ y a b) -> do
- a' <- whnf $ VClos env a
- (p', sigma, binds, cs1) <- checkP tenv p y a'
- let tenv' = (length binds, sigma ++ rho, binds ++ gamma)
- ((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b)
- return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
- _ -> Bad (render (text "Product expected for definiens" <+> ppTerm Unqualified 0 t <+> text "instead of" <+> ppValue Unqualified 0 typ))
- [] -> do
- (e,cs) <- checkExp th tenv t ty
- return (([],e),cs)
- checkP env@(k,rho,gamma) t x a = do
- (delta,cs) <- checkPatt th env t a
- let sigma = [(x, VGen i x) | ((x,_),i) <- zip delta [k..]]
- return (VClos sigma t, sigma, delta, cs)
-
- ps2ts k = foldr p2t ([],0,[],k)
- p2t p (ps,i,g,k) = case p of
- PW -> (Meta i : ps, i+1,g,k)
- PV x -> (Vr x : ps, i, upd x k g,k+1)
- PString s -> (K s : ps, i, g, k)
- PInt n -> (EInt n : ps, i, g, k)
- PFloat n -> (EFloat n : ps, i, g, k)
- PP m c xs -> (mkApp (Q m c) xss : ps, j, g',k')
- where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
- _ -> error $ render (text "undefined p2t case" <+> ppPatt Unqualified 0 p <+> text "in checkBranch")
-
- upd x k g = (x, VGen k x) : g --- hack to recognize pattern variables
-
-
-checkPatt :: Theory -> TCEnv -> Exp -> Val -> Err (Binds,[(Val,Val)])
-checkPatt th tenv exp val = do
- (aexp,_,cs) <- checkExpP tenv exp val
- let binds = extrBinds aexp
- return (binds,cs)
- where
- extrBinds aexp = case aexp of
- AVr i v -> [(i,v)]
- AApp f a _ -> extrBinds f ++ extrBinds a
- _ -> [] -- no other cases are possible
-
---- ad hoc, to find types of variables
- checkExpP tenv@(k,rho,gamma) exp val = case exp of
- Meta m -> return $ (AMeta m val, val, [])
- Vr x -> return $ (AVr x val, val, [])
- EInt i -> return (AInt i, valAbsInt, [])
- EFloat i -> return (AFloat i, valAbsFloat, [])
- K s -> return (AStr s, valAbsString, [])
-
- Q m c -> do
- typ <- lookupConst th (m,c)
- return $ (ACn (m,c) typ, typ, [])
- QC m c -> do
- typ <- lookupConst th (m,c)
- return $ (ACn (m,c) typ, typ, []) ----
- App f t -> do
- (f',w,csf) <- checkExpP tenv f val
- typ <- whnf w
- case typ of
- VClos env (Prod _ x a b) -> do
- (a',_,csa) <- checkExpP tenv t (VClos env a)
- b' <- whnf $ VClos ((x,VClos rho t):env) b
- return $ (AApp f' a' b', b', csf ++ csa)
- _ -> Bad (render (text "Prod expected for function" <+> ppTerm Unqualified 0 f <+> text "instead of" <+> ppValue Unqualified 0 typ))
- _ -> Bad (render (text "cannot typecheck pattern" <+> ppTerm Unqualified 0 exp))
-
--- auxiliaries
-
-noConstr :: Err Val -> Err (Val,[(Val,Val)])
-noConstr er = er >>= (\v -> return (v,[]))
-
-mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)])
-mkAnnot a ti = do
- (v,cs) <- ti
- return (a v, v, cs)
-
diff --git a/src/GF/Compile/Abstract/TypeCheck.hs b/src/GF/Compile/Abstract/TypeCheck.hs
deleted file mode 100644
index 2632c54dd..000000000
--- a/src/GF/Compile/Abstract/TypeCheck.hs
+++ /dev/null
@@ -1,83 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : TypeCheck
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/09/15 16:22:02 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.16 $
---
--- (Description of the module)
------------------------------------------------------------------------------
-
-module GF.Compile.Abstract.TypeCheck (-- * top-level type checking functions; TC should not be called directly.
- checkContext,
- checkTyp,
- checkDef,
- checkConstrs,
- ) where
-
-import GF.Data.Operations
-
-import GF.Infra.CheckM
-import GF.Grammar
-import GF.Grammar.Lookup
-import GF.Grammar.Unify
-import GF.Compile.Refresh
-import GF.Compile.Abstract.Compute
-import GF.Compile.Abstract.TC
-
-import Text.PrettyPrint
-import Control.Monad (foldM, liftM, liftM2)
-
--- | invariant way of creating TCEnv from context
-initTCEnv gamma =
- (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma)
-
--- interface to TC type checker
-
-type2val :: Type -> Val
-type2val = VClos []
-
-cont2exp :: Context -> Exp
-cont2exp c = mkProd c eType [] -- to check a context
-
-cont2val :: Context -> Val
-cont2val = type2val . cont2exp
-
--- some top-level batch-mode checkers for the compiler
-
-justTypeCheck :: SourceGrammar -> Exp -> Val -> Err Constraints
-justTypeCheck gr e v = do
- (_,constrs0) <- checkExp (grammar2theory gr) (initTCEnv []) e v
- (constrs1,_) <- unifyVal constrs0
- return $ filter notJustMeta constrs1
-
-notJustMeta (c,k) = case (c,k) of
- (VClos g1 (Meta m1), VClos g2 (Meta m2)) -> False
- _ -> True
-
-grammar2theory :: SourceGrammar -> Theory
-grammar2theory gr (m,f) = case lookupFunType gr m f of
- Ok t -> return $ type2val t
- Bad s -> case lookupCatContext gr m f of
- Ok cont -> return $ cont2val cont
- _ -> Bad s
-
-checkContext :: SourceGrammar -> Context -> [Message]
-checkContext st = checkTyp st . cont2exp
-
-checkTyp :: SourceGrammar -> Type -> [Message]
-checkTyp gr typ = err (\x -> [text x]) ppConstrs $ justTypeCheck gr typ vType
-
-checkDef :: SourceGrammar -> Fun -> Type -> [Equation] -> [Message]
-checkDef gr (m,fun) typ eqs = err (\x -> [text x]) ppConstrs $ do
- bcs <- mapM (\b -> checkBranch (grammar2theory gr) (initTCEnv []) b (type2val typ)) eqs
- let (bs,css) = unzip bcs
- (constrs,_) <- unifyVal (concat css)
- return $ filter notJustMeta constrs
-
-checkConstrs :: SourceGrammar -> Cat -> [Ident] -> [String]
-checkConstrs gr cat _ = [] ---- check constructors!
diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs
deleted file mode 100644
index f4765eb26..000000000
--- a/src/GF/Compile/CheckGrammar.hs
+++ /dev/null
@@ -1,284 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : CheckGrammar
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/11/11 23:24:33 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.31 $
---
--- AR 4\/12\/1999 -- 1\/4\/2000 -- 8\/9\/2001 -- 15\/5\/2002 -- 27\/11\/2002 -- 18\/6\/2003
---
--- type checking also does the following modifications:
---
--- - types of operations and local constants are inferred and put in place
---
--- - both these types and linearization types are computed
---
--- - tables are type-annotated
------------------------------------------------------------------------------
-
-module GF.Compile.CheckGrammar(checkModule) where
-
-import GF.Infra.Ident
-import GF.Infra.Modules
-
-import GF.Compile.Abstract.TypeCheck
-import GF.Compile.Concrete.TypeCheck
-
-import GF.Grammar
-import GF.Grammar.Lexer
-import GF.Grammar.Lookup
-import GF.Grammar.Predef
-import GF.Grammar.PatternMatch
-
-import GF.Data.Operations
-import GF.Infra.CheckM
-
-import Data.List
-import qualified Data.Set as Set
-import Control.Monad
-import Text.PrettyPrint
-
--- | checking is performed in the dependency order of modules
-checkModule :: [SourceModule] -> SourceModule -> Check SourceModule
-checkModule ms m@(name,mo) = checkIn (text "checking module" <+> ppIdent name) $ do
- checkRestrictedInheritance ms m
- m <- case mtype mo of
- MTConcrete a -> do let gr = MGrammar (m:ms)
- abs <- checkErr $ lookupModule gr a
- checkCompleteGrammar gr (a,abs) m
- _ -> return m
- infos <- checkErr $ topoSortJments m
- foldM updateCheckInfo m infos
- where
- updateCheckInfo (name,mo) (i,info) = do
- info <- checkInfo ms (name,mo) i info
- return (name,updateModule mo i info)
-
--- check if restricted inheritance modules are still coherent
--- i.e. that the defs of remaining names don't depend on omitted names
-checkRestrictedInheritance :: [SourceModule] -> SourceModule -> Check ()
-checkRestrictedInheritance mos (name,mo) = do
- let irs = [ii | ii@(_,mi) <- extend mo, mi /= MIAll] -- names with restr. inh.
- let mrs = [((i,m),mi) | (i,m) <- mos, Just mi <- [lookup i irs]]
- -- the restr. modules themself, with restr. infos
- mapM_ checkRem mrs
- where
- checkRem ((i,m),mi) = do
- let (incl,excl) = partition (isInherited mi) (map fst (tree2list (jments m)))
- let incld c = Set.member c (Set.fromList incl)
- let illegal c = Set.member c (Set.fromList excl)
- let illegals = [(f,is) |
- (f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)]
- case illegals of
- [] -> return ()
- cs -> checkError (text "In inherited module" <+> ppIdent i <> text ", dependence of excluded constants:" $$
- nest 2 (vcat [ppIdent f <+> text "on" <+> fsep (map ppIdent is) | (f,is) <- cs]))
- allDeps = concatMap (allDependencies (const True) . jments . snd) mos
-
-checkCompleteGrammar :: SourceGrammar -> SourceModule -> SourceModule -> Check SourceModule
-checkCompleteGrammar gr (am,abs) (cm,cnc) = do
- let jsa = jments abs
- let jsc = jments cnc
-
- -- check that all concrete constants are in abstract; build types for all lin
- jsc <- foldM checkCnc emptyBinTree (tree2list jsc)
-
- -- check that all abstract constants are in concrete; build default lin and lincats
- jsc <- foldM checkAbs jsc (tree2list jsa)
-
- return (cm,replaceJudgements cnc jsc)
- where
- checkAbs js i@(c,info) =
- case info of
- AbsFun (Just ty) _ _ -> do let mb_def = do
- let (cxt,(_,i),_) = typeForm ty
- info <- lookupIdent i js
- info <- case info of
- (AnyInd _ m) -> do (m,info) <- lookupOrigInfo gr m i
- return info
- _ -> return info
- case info of
- CncCat (Just (RecType [])) _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt)
- _ -> Bad "no def lin"
-
- case lookupIdent c js of
- Ok (AnyInd _ _) -> return js
- Ok (CncFun ty (Just def) pn) ->
- return $ updateTree (c,CncFun ty (Just def) pn) js
- Ok (CncFun ty Nothing pn) ->
- case mb_def of
- Ok def -> return $ updateTree (c,CncFun ty (Just def) pn) js
- Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c
- return js
- _ -> do
- case mb_def of
- Ok def -> do (cont,val) <- linTypeOfType gr cm ty
- let linty = (snd (valCat ty),cont,val)
- return $ updateTree (c,CncFun (Just linty) (Just def) Nothing) js
- Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c
- return js
- AbsCat (Just _) _ -> case lookupIdent c js of
- Ok (AnyInd _ _) -> return js
- Ok (CncCat (Just _) _ _) -> return js
- Ok (CncCat _ mt mp) -> do
- checkWarn $
- text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}"
- return $ updateTree (c,CncCat (Just defLinType) mt mp) js
- _ -> do
- checkWarn $
- text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}"
- return $ updateTree (c,CncCat (Just defLinType) Nothing Nothing) js
- _ -> return js
-
- checkCnc js i@(c,info) =
- case info of
- CncFun _ d pn -> case lookupOrigInfo gr am c of
- Ok (_,AbsFun (Just ty) _ _) ->
- do (cont,val) <- linTypeOfType gr cm ty
- let linty = (snd (valCat ty),cont,val)
- return $ updateTree (c,CncFun (Just linty) d pn) js
- _ -> do checkWarn $ text "function" <+> ppIdent c <+> text "is not in abstract"
- return js
- CncCat _ _ _ -> case lookupOrigInfo gr am c of
- Ok _ -> return $ updateTree i js
- _ -> do checkWarn $ text "category" <+> ppIdent c <+> text "is not in abstract"
- return js
- _ -> return $ updateTree i js
-
-
--- | General Principle: only Just-values are checked.
--- A May-value has always been checked in its origin module.
-checkInfo :: [SourceModule] -> SourceModule -> Ident -> Info -> Check Info
-checkInfo ms (m,mo) c info = do
- checkReservedId c
- case info of
- AbsCat (Just cont) _ -> mkCheck "category" $
- checkContext gr cont
-
- AbsFun (Just typ0) ma md -> do
- typ <- compAbsTyp [] typ0 -- to calculate let definitions
- mkCheck "type of function" $
- checkTyp gr typ
- case md of
- Just eqs -> mkCheck "definition of function" $
- checkDef gr (m,c) typ eqs
- Nothing -> return info
- return (AbsFun (Just typ) ma md)
-
- CncFun linty@(Just (cat,cont,val)) (Just trm) mpr -> chIn "linearization of" $ do
- (trm',_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val) -- erases arg vars
- mpr <- checkPrintname gr mpr
- return (CncFun linty (Just trm') mpr)
-
- CncCat (Just typ) mdef mpr -> chIn "linearization type of" $ do
- (typ,_) <- checkLType gr [] typ typeType
- typ <- computeLType gr [] typ
- mdef <- case mdef of
- Just def -> do
- (def,_) <- checkLType gr [] def (mkFunType [typeStr] typ)
- return $ Just def
- _ -> return mdef
- mpr <- checkPrintname gr mpr
- return (CncCat (Just typ) mdef mpr)
-
- ResOper pty pde -> chIn "operation" $ do
- (pty', pde') <- case (pty,pde) of
- (Just ty, Just de) -> do
- ty' <- checkLType gr [] ty typeType >>= computeLType gr [] . fst
- (de',_) <- checkLType gr [] de ty'
- return (Just ty', Just de')
- (_ , Just de) -> do
- (de',ty') <- inferLType gr [] de
- return (Just ty', Just de')
- (_ , Nothing) -> do
- checkError (text "No definition given to the operation")
- return (ResOper pty' pde')
-
- ResOverload os tysts -> chIn "overloading" $ do
- tysts' <- mapM (uncurry $ flip (checkLType gr [])) tysts -- return explicit ones
- tysts0 <- checkErr $ lookupOverload gr m c -- check against inherited ones too
- tysts1 <- mapM (uncurry $ flip (checkLType gr []))
- [(mkFunType args val,tr) | (args,(val,tr)) <- tysts0]
- --- this can only be a partial guarantee, since matching
- --- with value type is only possible if expected type is given
- checkUniq $
- sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
- return (ResOverload os [(y,x) | (x,y) <- tysts'])
-
- ResParam (Just pcs) _ -> chIn "parameter type" $ do
- ts <- checkErr $ liftM concat $ mapM mkPar pcs
- return (ResParam (Just pcs) (Just ts))
-
- _ -> return info
- where
- gr = MGrammar ((m,mo) : ms)
- chIn cat = checkIn (text "Happened in" <+> text cat <+> ppIdent c <+> ppPosition mo c <> colon)
-
- mkPar (f,co) = do
- vs <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
- return $ map (mkApp (QC m f)) vs
-
- checkUniq xss = case xss of
- x:y:xs
- | x == y -> checkError $ text "ambiguous for type" <+>
- ppType (mkFunType (tail x) (head x))
- | otherwise -> checkUniq $ y:xs
- _ -> return ()
-
- mkCheck cat ss = case ss of
- [] -> return info
- _ -> checkError (vcat ss $$ text "in" <+> text cat <+> ppIdent c <+> ppPosition mo c)
-
- compAbsTyp g t = case t of
- Vr x -> maybe (checkError (text "no value given to variable" <+> ppIdent x)) return $ lookup x g
- Let (x,(_,a)) b -> do
- a' <- compAbsTyp g a
- compAbsTyp ((x, a'):g) b
- Prod b x a t -> do
- a' <- compAbsTyp g a
- t' <- compAbsTyp ((x,Vr x):g) t
- return $ Prod b x a' t'
- Abs _ _ _ -> return t
- _ -> composOp (compAbsTyp g) t
-
-
-checkPrintname :: SourceGrammar -> Maybe Term -> Check (Maybe Term)
-checkPrintname gr (Just t) = do (t,_) <- checkLType gr [] t typeStr
- return (Just t)
-checkPrintname gr Nothing = return Nothing
-
--- | for grammars obtained otherwise than by parsing ---- update!!
-checkReservedId :: Ident -> Check ()
-checkReservedId x
- | isReservedWord (ident2bs x) = checkWarn (text "reserved word used as identifier:" <+> ppIdent x)
- | otherwise = return ()
-
--- auxiliaries
-
--- | linearization types and defaults
-linTypeOfType :: SourceGrammar -> Ident -> Type -> Check (Context,Type)
-linTypeOfType cnc m typ = do
- let (cont,cat) = typeSkeleton typ
- val <- lookLin cat
- args <- mapM mkLinArg (zip [0..] cont)
- return (args, val)
- where
- mkLinArg (i,(n,mc@(m,cat))) = do
- val <- lookLin mc
- let vars = mkRecType varLabel $ replicate n typeStr
- symb = argIdent n cat i
- rec <- if n==0 then return val else
- checkErr $ errIn (render (text "extending" $$
- nest 2 (ppTerm Unqualified 0 vars) $$
- text "with" $$
- nest 2 (ppTerm Unqualified 0 val))) $
- plusRecType vars val
- return (Explicit,symb,rec)
- lookLin (_,c) = checks [ --- rather: update with defLinType ?
- checkErr (lookupLincat cnc m c) >>= computeLType cnc []
- ,return defLinType
- ]
diff --git a/src/GF/Compile/Coding.hs b/src/GF/Compile/Coding.hs
deleted file mode 100644
index 49538bd35..000000000
--- a/src/GF/Compile/Coding.hs
+++ /dev/null
@@ -1,55 +0,0 @@
-module GF.Compile.Coding where
-
-import GF.Grammar.Grammar
-import GF.Grammar.Macros
-import GF.Text.Coding
-import GF.Infra.Modules
-import GF.Infra.Option
-import GF.Data.Operations
-
-import Data.Char
-
-encodeStringsInModule :: SourceModule -> SourceModule
-encodeStringsInModule = codeSourceModule (encodeUnicode UTF_8)
-
-decodeStringsInModule :: SourceModule -> SourceModule
-decodeStringsInModule mo = codeSourceModule (decodeUnicode (flag optEncoding (flagsModule mo))) mo
-
-codeSourceModule :: (String -> String) -> SourceModule -> SourceModule
-codeSourceModule co (id,mo) = (id,replaceJudgements mo (mapTree codj (jments mo)))
- where
- codj (c,info) = case info of
- ResOper pty pt -> ResOper (fmap (codeTerm co) pty) (fmap (codeTerm co) pt)
- ResOverload es tyts -> ResOverload es [(codeTerm co ty,codeTerm co t) | (ty,t) <- tyts]
- CncCat pty pt mpr -> CncCat pty (fmap (codeTerm co) pt) (fmap (codeTerm co) mpr)
- CncFun mty pt mpr -> CncFun mty (fmap (codeTerm co) pt) (fmap (codeTerm co) mpr)
- _ -> info
-
-codeTerm :: (String -> String) -> Term -> Term
-codeTerm co t = case t of
- K s -> K (co s)
- T ty cs -> T ty [(codp p,codeTerm co v) | (p,v) <- cs]
- EPatt p -> EPatt (codp p)
- _ -> composSafeOp (codeTerm co) t
- where
- codp p = case p of --- really: composOpPatt
- PR rs -> PR [(l,codp p) | (l,p) <- rs]
- PString s -> PString (co s)
- PChars s -> PChars (co s)
- PT x p -> PT x (codp p)
- PAs x p -> PAs x (codp p)
- PNeg p -> PNeg (codp p)
- PRep p -> PRep (codp p)
- PSeq p q -> PSeq (codp p) (codp q)
- PAlt p q -> PAlt (codp p) (codp q)
- _ -> p
-
--- | Run an encoding function on all string literals within the given string.
-codeStringLiterals :: (String -> String) -> String -> String
-codeStringLiterals _ [] = []
-codeStringLiterals co ('"':cs) = '"' : inStringLiteral cs
- where inStringLiteral [] = error "codeStringLiterals: unterminated string literal"
- inStringLiteral ('"':ds) = '"' : codeStringLiterals co ds
- inStringLiteral ('\\':d:ds) = '\\' : co [d] ++ inStringLiteral ds
- inStringLiteral (d:ds) = co [d] ++ inStringLiteral ds
-codeStringLiterals co (c:cs) = c : codeStringLiterals co cs
diff --git a/src/GF/Compile/Concrete/AppPredefined.hs b/src/GF/Compile/Concrete/AppPredefined.hs
deleted file mode 100644
index c05127191..000000000
--- a/src/GF/Compile/Concrete/AppPredefined.hs
+++ /dev/null
@@ -1,158 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : AppPredefined
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/10/06 14:21:34 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.13 $
---
--- Predefined function type signatures and definitions.
------------------------------------------------------------------------------
-
-module GF.Compile.Concrete.AppPredefined (isInPredefined, typPredefined, appPredefined
- ) where
-
-import GF.Infra.Ident
-import GF.Data.Operations
-import GF.Grammar.Predef
-import GF.Grammar.Grammar
-import GF.Grammar.Macros
-import GF.Grammar.Printer
-import qualified Data.ByteString.Char8 as BS
-import Text.PrettyPrint
-
--- predefined function type signatures and definitions. AR 12/3/2003.
-
-isInPredefined :: Ident -> Bool
-isInPredefined = err (const True) (const False) . typPredefined
-
-typPredefined :: Ident -> Err Type
-typPredefined f
- | f == cInt = return typePType
- | f == cFloat = return typePType
- | f == cErrorType = return typeType
- | f == cInts = return $ mkFunType [typeInt] typePType
- | f == cPBool = return typePType
- | f == cError = return $ mkFunType [typeStr] typeError -- non-can. of empty set
- | f == cPFalse = return $ typePBool
- | f == cPTrue = return $ typePBool
- | f == cDp = return $ mkFunType [typeInt,typeTok] typeTok
- | f == cDrop = return $ mkFunType [typeInt,typeTok] typeTok
- | f == cEqInt = return $ mkFunType [typeInt,typeInt] typePBool
- | f == cLessInt = return $ mkFunType [typeInt,typeInt] typePBool
- | f == cEqStr = return $ mkFunType [typeTok,typeTok] typePBool
- | f == cLength = return $ mkFunType [typeTok] typeInt
- | f == cOccur = return $ mkFunType [typeTok,typeTok] typePBool
- | f == cOccurs = return $ mkFunType [typeTok,typeTok] typePBool
- | f == cPlus = return $ mkFunType [typeInt,typeInt] (typeInt)
----- "read" -> (P : Type) -> Tok -> P
- | f == cShow = return $ mkProd -- (P : PType) -> P -> Tok
- [(Explicit,varP,typePType),(Explicit,identW,Vr varP)] typeStr []
- | f == cToStr = return $ mkProd -- (L : Type) -> L -> Str
- [(Explicit,varL,typeType),(Explicit,identW,Vr varL)] typeStr []
- | f == cMapStr = return $ mkProd -- (L : Type) -> (Str -> Str) -> L -> L
- [(Explicit,varL,typeType),(Explicit,identW,mkFunType [typeStr] typeStr),(Explicit,identW,Vr varL)] (Vr varL) []
- | f == cTake = return $ mkFunType [typeInt,typeTok] typeTok
- | f == cTk = return $ mkFunType [typeInt,typeTok] typeTok
- | otherwise = Bad (render (text "unknown in Predef:" <+> ppIdent f))
-
-varL :: Ident
-varL = identC (BS.pack "L")
-
-varP :: Ident
-varP = identC (BS.pack "P")
-
-appPredefined :: Term -> Err (Term,Bool)
-appPredefined t = case t of
- App f x0 -> do
- (x,_) <- appPredefined x0
- case f of
- -- one-place functions
- Q mod f | mod == cPredef ->
- case x of
- (K s) | f == cLength -> retb $ EInt $ toInteger $ length s
- _ -> retb t
-
- -- two-place functions
- App (Q mod f) z0 | mod == cPredef -> do
- (z,_) <- appPredefined z0
- case (norm z, norm x) of
- (EInt i, K s) | f == cDrop -> retb $ K (drop (fi i) s)
- (EInt i, K s) | f == cTake -> retb $ K (take (fi i) s)
- (EInt i, K s) | f == cTk -> retb $ K (take (max 0 (length s - fi i)) s)
- (EInt i, K s) | f == cDp -> retb $ K (drop (max 0 (length s - fi i)) s)
- (K s, K t) | f == cEqStr -> retb $ if s == t then predefTrue else predefFalse
- (K s, K t) | f == cOccur -> retb $ if substring s t then predefTrue else predefFalse
- (K s, K t) | f == cOccurs -> retb $ if any (flip elem t) s then predefTrue else predefFalse
- (EInt i, EInt j) | f == cEqInt -> retb $ if i==j then predefTrue else predefFalse
- (EInt i, EInt j) | f == cLessInt -> retb $ if i<j then predefTrue else predefFalse
- (EInt i, EInt j) | f == cPlus -> retb $ EInt $ i+j
- (_, t) | f == cShow -> retb $ foldr C Empty $ map K $ words $ render (ppTerm Unqualified 0 t)
- (_, K s) | f == cRead -> retb $ Cn (identC (BS.pack s)) --- because of K, only works for atomic tags
- (_, t) | f == cToStr -> trm2str t >>= retb
- _ -> retb t ---- prtBad "cannot compute predefined" t
-
- -- three-place functions
- App (App (Q mod f) z0) y0 | mod == cPredef -> do
- (y,_) <- appPredefined y0
- (z,_) <- appPredefined z0
- case (z, y, x) of
- (ty,op,t) | f == cMapStr -> retf $ mapStr ty op t
- _ -> retb t ---- prtBad "cannot compute predefined" t
-
- _ -> retb t ---- prtBad "cannot compute predefined" t
- _ -> retb t
- ---- should really check the absence of arg variables
- where
- retb t = return (retc t,True) -- no further computing needed
- retf t = return (retc t,False) -- must be computed further
- retc t = case t of
- K [] -> t
- K s -> foldr1 C (map K (words s))
- _ -> t
- norm t = case t of
- Empty -> K []
- C u v -> case (norm u,norm v) of
- (K x,K y) -> K (x +++ y)
- _ -> t
- _ -> t
- fi = fromInteger
-
--- read makes variables into constants
-
-predefTrue = QC cPredef cPTrue
-predefFalse = QC cPredef cPFalse
-
-substring :: String -> String -> Bool
-substring s t = case (s,t) of
- (c:cs, d:ds) -> (c == d && substring cs ds) || substring s ds
- ([],_) -> True
- _ -> False
-
-trm2str :: Term -> Err Term
-trm2str t = case t of
- R ((_,(_,s)):_) -> trm2str s
- T _ ((_,s):_) -> trm2str s
- V _ (s:_) -> trm2str s
- C _ _ -> return $ t
- K _ -> return $ t
- S c _ -> trm2str c
- Empty -> return $ t
- _ -> Bad (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t))
-
--- simultaneous recursion on type and term: type arg is essential!
--- But simplify the task by assuming records are type-annotated
--- (this has been done in type checking)
-mapStr :: Type -> Term -> Term -> Term
-mapStr ty f t = case (ty,t) of
- _ | elem ty [typeStr,typeTok] -> App f t
- (_, R ts) -> R [(l,mapField v) | (l,v) <- ts]
- (Table a b,T ti cs) -> T ti [(p,mapStr b f v) | (p,v) <- cs]
- _ -> t
- where
- mapField (mty,te) = case mty of
- Just ty -> (mty,mapStr ty f te)
- _ -> (mty,te)
diff --git a/src/GF/Compile/Concrete/Compute.hs b/src/GF/Compile/Concrete/Compute.hs
deleted file mode 100644
index 9c016116b..000000000
--- a/src/GF/Compile/Concrete/Compute.hs
+++ /dev/null
@@ -1,456 +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.Concrete.Compute (computeConcrete, computeTerm,computeConcreteRec) 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.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.Concrete.AppPredefined
-
-import Data.List (nub,intersperse)
-import Control.Monad (liftM2, liftM)
-import Text.PrettyPrint
-
--- | 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
-
-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
-
- comput full g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging
- case t of
-
- Q p c | p == cPredef -> return t
- | otherwise -> look p c
-
- Vr x -> do
- 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'
-
- -- Abs x@(IA _) b -> do
- Abs _ _ _ | full -> do
- 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,(_,a)) b -> do
- a' <- comp g a
- comp (ext x a' g) b
-
- Prod b x a t -> do
- a' <- comp g a
- t' <- comp (ext x (Vr x) g) t
- return $ Prod b x a' t'
-
- -- beta-convert
- App f a -> case appForm t of
- (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 []
- ---- a workaround 18/2/2005: take this away and find the reason
- ---- why earlier compilation destroys the lock field
-
-
- P t l -> do
- t' <- comp g t
- case t' of
- FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants
- R r -> maybe (Bad (render (text "no value for label" <+> ppLabel l))) (comp g . snd) $
- lookup l $ reverse r
-
- ExtR a (R b) ->
- 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
- S (V i cs) e -> prawitzV g i (flip P l) cs e
-
- _ -> returnC $ P t' l
-
- S t v -> do
- 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
- x <- comp g x0
- y <- comp g y0
- case (x,y) of
- (FV ks,_) -> do
- kys <- mapM (comp g . flip Glue y) ks
- return $ variants kys
- (_,FV ks) -> do
- xks <- mapM (comp g . Glue x) ks
- return $ variants xks
-
- (S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e
- (s, S (T i cs) e) -> prawitz g i (Glue s) cs e
- (S (V i cs) e, s) -> prawitzV g i (flip Glue s) cs e
- (s, S (V i cs) e) -> prawitzV g i (Glue s) cs e
- (_,Empty) -> return x
- (Empty,_) -> return y
- (K a, K b) -> return $ K (a ++ b)
- (_, Alts (d,vs)) -> do
----- (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
- 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)
-
- _ -> do
- mapM_ checkNoArgVars [x,y]
- r <- composOp (comp g) t
- returnC r
-
- Alts (d,aa) -> do
- d' <- comp g d
- aa' <- mapM (compInAlts g) aa
- returnC (Alts (d',aa'))
-
- -- remove empty
- C a b -> do
- a' <- comp g a
- b' <- comp g b
- case (a',b') of
- (Alts _, K a) -> checks [do
- as <- strsFromTerm a' -- this may fail when compiling opers
- return $ variants [
- foldr1 C (map K (str2strings (plusStr v (str a)))) | v <- as]
- ,
- return $ C a' b'
- ]
- (Empty,_) -> returnC b'
- (_,Empty) -> returnC a'
- _ -> returnC $ C a' b'
-
- -- reduce free variation as much as you can
- FV ts -> mapM (comp g) ts >>= returnC . variants
-
- -- merge record extensions if you can
- ExtR r s -> do
- 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
- r' <- comp g r
- unlockRecord c r'
-
- T _ _ -> compTable g t
- V _ _ -> compTable g t
-
- -- otherwise go ahead
- _ -> composOp (comp g) t >>= returnC
-
- where
-
- compApp g (App f a) = do
- f' <- hnf g f
- a' <- comp g a
- case (f',a') of
- (Abs _ x b, FV as) ->
- 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
-
- (QC _ _,_) -> returnC $ App f' a'
-
- (S (T i cs) e,_) -> prawitz g i (flip App a') cs e
- (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 p c
- | rec = lookupResDef gr p c >>= comp []
- | otherwise = lookupResDef gr p c
-
- ext x a g = (x,a):g
-
- returnC = return --- . computed
-
- variants ts = case nub ts of
- [t] -> t
- ts -> FV ts
-
- isCan v = case v of
- 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 m c -> case look m 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
- FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants
- _ -> case t' of
- FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants
-
- T _ [(PW,c)] -> comp g c --- an optimization
- T _ [(PT _ PW,c)] -> comp g c
-
- T _ [(PV z,c)] -> comp (ext z v' g) c --- another optimization
- 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
- 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
- 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
- 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
- -- 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' <- mapM (compBranch g) cs
- return $ T i cs' -- happens with variable types
- _ -> comp g t
-
- compBranch g (p,v) = do
- let g' = contP p ++ g
- 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
-
- 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)))
diff --git a/src/GF/Compile/Concrete/TypeCheck.hs b/src/GF/Compile/Concrete/TypeCheck.hs
deleted file mode 100644
index 670f36625..000000000
--- a/src/GF/Compile/Concrete/TypeCheck.hs
+++ /dev/null
@@ -1,690 +0,0 @@
-{-# LANGUAGE PatternGuards #-}
-module GF.Compile.Concrete.TypeCheck( checkLType, inferLType, computeLType, ppType ) where
-
-import GF.Infra.CheckM
-import GF.Infra.Modules
-import GF.Data.Operations
-
-import GF.Grammar
-import GF.Grammar.Lookup
-import GF.Grammar.Predef
-import GF.Grammar.PatternMatch
-import GF.Grammar.Lockfield (isLockLabel, lockRecType, unlockRecord)
-import GF.Compile.Concrete.AppPredefined
-
-import Data.List
-import Control.Monad
-import Text.PrettyPrint
-
-computeLType :: SourceGrammar -> Context -> Type -> Check Type
-computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
- where
- comp g ty = case ty of
- _ | Just _ <- isTypeInts ty -> return ty ---- shouldn't be needed
- | isPredefConstant ty -> return ty ---- shouldn't be needed
-
- Q m ident -> checkIn (text "module" <+> ppIdent m) $ do
- ty' <- checkErr (lookupResDef gr m ident)
- if ty' == ty then return ty else comp g ty' --- is this necessary to test?
-
- Vr ident -> checkLookup ident g -- never needed to compute!
-
- App f a -> do
- f' <- comp g f
- a' <- comp g a
- case f' of
- Abs b x t -> comp ((b,x,a'):g) t
- _ -> return $ App f' a'
-
- Prod bt x a b -> do
- a' <- comp g a
- b' <- comp ((bt,x,Vr x) : g) b
- return $ Prod bt x a' b'
-
- Abs bt x b -> do
- b' <- comp ((bt,x,Vr x):g) b
- return $ Abs bt x b'
-
- ExtR r s -> do
- r' <- comp g r
- s' <- comp g s
- case (r',s') of
- (RecType rs, RecType ss) -> checkErr (plusRecType r' s') >>= comp g
- _ -> return $ ExtR r' s'
-
- RecType fs -> do
- let fs' = sortRec fs
- liftM RecType $ mapPairsM (comp g) fs'
-
- ELincat c t -> do
- t' <- comp g t
- checkErr $ lockRecType c t' ---- locking to be removed AR 20/6/2009
-
- _ | ty == typeTok -> return typeStr
- _ | isPredefConstant ty -> return ty
-
- _ -> composOp (comp g) ty
-
--- the underlying algorithms
-
-inferLType :: SourceGrammar -> Context -> Term -> Check (Term, Type)
-inferLType gr g trm = case trm of
-
- Q m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident)
-
- Q m ident -> checks [
- termWith trm $ checkErr (lookupResType gr m ident) >>= computeLType gr g
- ,
- checkErr (lookupResDef gr m ident) >>= inferLType gr g
- ,
- checkError (text "cannot infer type of constant" <+> ppTerm Unqualified 0 trm)
- ]
-
- QC m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident)
-
- QC m ident -> checks [
- termWith trm $ checkErr (lookupResType gr m ident) >>= computeLType gr g
- ,
- checkErr (lookupResDef gr m ident) >>= inferLType gr g
- ,
- checkError (text "cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm)
- ]
-
- Vr ident -> termWith trm $ checkLookup ident g
-
- Typed e t -> do
- t' <- computeLType gr g t
- checkLType gr g e t'
- return (e,t')
-
- App f a -> do
- over <- getOverload gr g Nothing trm
- case over of
- Just trty -> return trty
- _ -> do
- (f',fty) <- inferLType gr g f
- fty' <- computeLType gr g fty
- case fty' of
- Prod bt z arg val -> do
- a' <- justCheck g a arg
- ty <- if isWildIdent z
- then return val
- else substituteLType [(bt,z,a')] val
- return (App f' a',ty)
- _ -> checkError (text "A function type is expected for" <+> ppTerm Unqualified 0 f <+> text "instead of type" <+> ppType fty)
-
- S f x -> do
- (f', fty) <- inferLType gr g f
- case fty of
- Table arg val -> do
- x'<- justCheck g x arg
- return (S f' x', val)
- _ -> checkError (text "table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm))
-
- P t i -> do
- (t',ty) <- inferLType gr g t --- ??
- ty' <- computeLType gr g ty
- let tr2 = P t' i
- termWith tr2 $ case ty' of
- RecType ts -> case lookup i ts of
- Nothing -> checkError (text "unknown label" <+> ppLabel i <+> text "in" $$ nest 2 (ppTerm Unqualified 0 ty'))
- Just x -> return x
- _ -> checkError (text "record type expected for:" <+> ppTerm Unqualified 0 t $$
- text " instead of the inferred:" <+> ppTerm Unqualified 0 ty')
-
- R r -> do
- let (ls,fs) = unzip r
- fsts <- mapM inferM fs
- let ts = [ty | (Just ty,_) <- fsts]
- checkCond (text "cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 trm)) (length ts == length fsts)
- return $ (R (zip ls fsts), RecType (zip ls ts))
-
- T (TTyped arg) pts -> do
- (_,val) <- checks $ map (inferCase (Just arg)) pts
- checkLType gr g trm (Table arg val)
- T (TComp arg) pts -> do
- (_,val) <- checks $ map (inferCase (Just arg)) pts
- checkLType gr g trm (Table arg val)
- T ti pts -> do -- tries to guess: good in oper type inference
- let pts' = [pt | pt@(p,_) <- pts, isConstPatt p]
- case pts' of
- [] -> checkError (text "cannot infer table type of" <+> ppTerm Unqualified 0 trm)
----- PInt k : _ -> return $ Ints $ max [i | PInt i <- pts']
- _ -> do
- (arg,val) <- checks $ map (inferCase Nothing) pts'
- checkLType gr g trm (Table arg val)
- V arg pts -> do
- (_,val) <- checks $ map (inferLType gr g) pts
- return (trm, Table arg val)
-
- K s -> do
- if elem ' ' s
- then do
- let ss = foldr C Empty (map K (words s))
- ----- removed irritating warning AR 24/5/2008
- ----- checkWarn ("token \"" ++ s ++
- ----- "\" converted to token list" ++ prt ss)
- return (ss, typeStr)
- else return (trm, typeStr)
-
- EInt i -> return (trm, typeInt)
-
- EFloat i -> return (trm, typeFloat)
-
- Empty -> return (trm, typeStr)
-
- C s1 s2 ->
- check2 (flip (justCheck g) typeStr) C s1 s2 typeStr
-
- Glue s1 s2 ->
- check2 (flip (justCheck g) typeStr) Glue s1 s2 typeStr ---- typeTok
-
----- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007
- Strs (Cn c : ts) | c == cConflict -> do
- checkWarn (text "unresolved constant, could be any of" <+> hcat (map (ppTerm Unqualified 0) ts))
- inferLType gr g (head ts)
-
- Strs ts -> do
- ts' <- mapM (\t -> justCheck g t typeStr) ts
- return (Strs ts', typeStrs)
-
- Alts (t,aa) -> do
- t' <- justCheck g t typeStr
- aa' <- flip mapM aa (\ (c,v) -> do
- c' <- justCheck g c typeStr
- v' <- checks $ map (justCheck g v) [typeStrs, EPattType typeStr]
- return (c',v'))
- return (Alts (t',aa'), typeStr)
-
- RecType r -> do
- let (ls,ts) = unzip r
- ts' <- mapM (flip (justCheck g) typeType) ts
- return (RecType (zip ls ts'), typeType)
-
- ExtR r s -> do
- (r',rT) <- inferLType gr g r
- rT' <- computeLType gr g rT
- (s',sT) <- inferLType gr g s
- sT' <- computeLType gr g sT
-
- let trm' = ExtR r' s'
- ---- trm' <- checkErr $ plusRecord r' s'
- case (rT', sT') of
- (RecType rs, RecType ss) -> do
- rt <- checkErr $ plusRecType rT' sT'
- checkLType gr g trm' rt ---- return (trm', rt)
- _ | rT' == typeType && sT' == typeType -> return (trm', typeType)
- _ -> checkError (text "records or record types expected in" <+> ppTerm Unqualified 0 trm)
-
- Sort _ ->
- termWith trm $ return typeType
-
- Prod bt x a b -> do
- a' <- justCheck g a typeType
- b' <- justCheck ((bt,x,a'):g) b typeType
- return (Prod bt x a' b', typeType)
-
- Table p t -> do
- p' <- justCheck g p typeType --- check p partype!
- t' <- justCheck g t typeType
- return $ (Table p' t', typeType)
-
- FV vs -> do
- (_,ty) <- checks $ map (inferLType gr g) vs
---- checkIfComplexVariantType trm ty
- checkLType gr g trm ty
-
- EPattType ty -> do
- ty' <- justCheck g ty typeType
- return (EPattType ty',typeType)
- EPatt p -> do
- ty <- inferPatt p
- return (trm, EPattType ty)
-
- ELin c trm -> do
- (trm',ty) <- inferLType gr g trm
- ty' <- checkErr $ lockRecType c ty ---- lookup c; remove lock AR 20/6/2009
- return $ (ELin c trm', ty')
-
- _ -> checkError (text "cannot infer lintype of" <+> ppTerm Unqualified 0 trm)
-
- where
- isPredef m = elem m [cPredef,cPredefAbs]
-
- justCheck g ty te = checkLType gr g ty te >>= return . fst
-
- -- for record fields, which may be typed
- inferM (mty, t) = do
- (t', ty') <- case mty of
- Just ty -> checkLType gr g ty t
- _ -> inferLType gr g t
- return (Just ty',t')
-
- inferCase mty (patt,term) = do
- arg <- maybe (inferPatt patt) return mty
- cont <- pattContext gr g arg patt
- (_,val) <- inferLType gr (reverse cont ++ g) term
- return (arg,val)
- isConstPatt p = case p of
- PC _ ps -> True --- all isConstPatt ps
- PP _ _ ps -> True --- all isConstPatt ps
- PR ps -> all (isConstPatt . snd) ps
- PT _ p -> isConstPatt p
- PString _ -> True
- PInt _ -> True
- PFloat _ -> True
- PChar -> True
- PChars _ -> True
- PSeq p q -> isConstPatt p && isConstPatt q
- PAlt p q -> isConstPatt p && isConstPatt q
- PRep p -> isConstPatt p
- PNeg p -> isConstPatt p
- PAs _ p -> isConstPatt p
- _ -> False
-
- inferPatt p = case p of
- PP q c ps | q /= cPredef -> checkErr $ liftM valTypeCnc (lookupResType gr q c)
- PAs _ p -> inferPatt p
- PNeg p -> inferPatt p
- PAlt p q -> checks [inferPatt p, inferPatt q]
- PSeq _ _ -> return $ typeStr
- PRep _ -> return $ typeStr
- PChar -> return $ typeStr
- PChars _ -> return $ typeStr
- _ -> inferLType gr g (patt2term p) >>= return . snd
-
-
--- type inference: Nothing, type checking: Just t
--- the latter permits matching with value type
-getOverload :: SourceGrammar -> Context -> Maybe Type -> Term -> Check (Maybe (Term,Type))
-getOverload gr g mt ot = case appForm ot of
- (f@(Q m c), ts) -> case lookupOverload gr m c of
- Ok typs -> do
- ttys <- mapM (inferLType gr g) ts
- v <- matchOverload f typs ttys
- return $ Just v
- _ -> return Nothing
- _ -> return Nothing
- where
- matchOverload f typs ttys = do
- let (tts,tys) = unzip ttys
- let vfs = lookupOverloadInstance tys typs
- let matches = [vf | vf@((v,_),_) <- vfs, matchVal mt v]
-
- case ([vf | (vf,True) <- matches],[vf | (vf,False) <- matches]) of
- ([(val,fun)],_) -> return (mkApp fun tts, val)
- ([],[(val,fun)]) -> do
- checkWarn (text "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot)
- return (mkApp fun tts, val)
- ([],[]) -> do
- let showTypes ty = hsep (map ppType ty)
- checkError $ text "no overload instance of" <+> ppTerm Unqualified 0 f $$
- text "for" $$
- nest 2 (showTypes tys) $$
- text "among" $$
- nest 2 (vcat [showTypes ty | (ty,_) <- typs]) $$
- maybe empty (\x -> text "with value type" <+> ppType x) mt
-
- (vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of
- ([(val,fun)],_) -> do
- return (mkApp fun tts, val)
- ([],[(val,fun)]) -> do
- checkWarn (text "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot)
- return (mkApp fun tts, val)
-
------ unsafely exclude irritating warning AR 24/5/2008
------ checkWarn $ "overloading of" +++ prt f +++
------ "resolved by excluding partial applications:" ++++
------ unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)]
-
-
- _ -> checkError $ text "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+>
- text "for" <+> hsep (map ppType tys) $$
- text "with alternatives" $$
- nest 2 (vcat [ppType ty | (ty,_) <- if null vfs1 then vfs2 else vfs2])
-
- matchVal mt v = elem mt [Nothing,Just v,Just (unlocked v)]
-
- unlocked v = case v of
- RecType fs -> RecType $ filter (not . isLockLabel . fst) fs
- _ -> v
- ---- TODO: accept subtypes
- ---- TODO: use a trie
- lookupOverloadInstance tys typs =
- [((mkFunType rest val, t),isExact) |
- let lt = length tys,
- (ty,(val,t)) <- typs, length ty >= lt,
- let (pre,rest) = splitAt lt ty,
- let isExact = pre == tys,
- isExact || map unlocked pre == map unlocked tys
- ]
-
- noProds vfs = [(v,f) | (v,f) <- vfs, noProd v]
-
- noProd ty = case ty of
- Prod _ _ _ _ -> False
- _ -> True
-
-checkLType :: SourceGrammar -> Context -> Term -> Type -> Check (Term, Type)
-checkLType gr g trm typ0 = do
-
- typ <- computeLType gr g typ0
-
- case trm of
-
- Abs bt x c -> do
- case typ of
- Prod bt' z a b -> do
- (c',b') <- if isWildIdent z
- then checkLType gr ((bt,x,a):g) c b
- else do b' <- checkIn (text "abs") $ substituteLType [(bt',z,Vr x)] b
- checkLType gr ((bt,x,a):g) c b'
- return $ (Abs bt x c', Prod bt' x a b')
- _ -> checkError $ text "function type expected instead of" <+> ppType typ
-
- App f a -> do
- over <- getOverload gr g (Just typ) trm
- case over of
- Just trty -> return trty
- _ -> do
- (trm',ty') <- inferLType gr g trm
- termWith trm' $ checkEqLType gr g typ ty' trm'
-
- Q _ _ -> do
- over <- getOverload gr g (Just typ) trm
- case over of
- Just trty -> return trty
- _ -> do
- (trm',ty') <- inferLType gr g trm
- termWith trm' $ checkEqLType gr g typ ty' trm'
-
- T _ [] ->
- checkError (text "found empty table in type" <+> ppTerm Unqualified 0 typ)
- T _ cs -> case typ of
- Table arg val -> do
- case allParamValues gr arg of
- Ok vs -> do
- let ps0 = map fst cs
- ps <- checkErr $ testOvershadow ps0 vs
- if null ps
- then return ()
- else checkWarn (text "patterns never reached:" $$
- nest 2 (vcat (map (ppPatt Unqualified 0) ps)))
- _ -> return () -- happens with variable types
- cs' <- mapM (checkCase arg val) cs
- return (T (TTyped arg) cs', typ)
- _ -> checkError $ text "table type expected for table instead of" $$ nest 2 (ppType typ)
-
- R r -> case typ of --- why needed? because inference may be too difficult
- RecType rr -> do
- let (ls,_) = unzip rr -- labels of expected type
- fsts <- mapM (checkM r) rr -- check that they are found in the record
- return $ (R fsts, typ) -- normalize record
-
- _ -> checkError (text "record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ))
-
- ExtR r s -> case typ of
- _ | typ == typeType -> do
- trm' <- computeLType gr g trm
- case trm' of
- RecType _ -> termWith trm $ return typeType
- ExtR (Vr _) (RecType _) -> termWith trm $ return typeType
- -- ext t = t ** ...
- _ -> checkError (text "invalid record type extension" <+> nest 2 (ppTerm Unqualified 0 trm))
- RecType rr -> do
- (r',ty,s') <- checks [
- do (r',ty) <- inferLType gr g r
- return (r',ty,s)
- ,
- do (s',ty) <- inferLType gr g s
- return (s',ty,r)
- ]
- case ty of
- RecType rr1 -> do
- let (rr0,rr2) = recParts rr rr1
- r2 <- justCheck g r' rr0
- s2 <- justCheck g s' rr2
- return $ (ExtR r2 s2, typ)
- _ -> checkError (text "record type expected in extension of" <+> ppTerm Unqualified 0 r $$
- text "but found" <+> ppTerm Unqualified 0 ty)
-
- ExtR ty ex -> do
- r' <- justCheck g r ty
- s' <- justCheck g s ex
- return $ (ExtR r' s', typ) --- is this all?
-
- _ -> checkError (text "record extension not meaningful for" <+> ppTerm Unqualified 0 typ)
-
- FV vs -> do
- ttys <- mapM (flip (checkLType gr g) typ) vs
---- checkIfComplexVariantType trm typ
- return (FV (map fst ttys), typ) --- typ' ?
-
- S tab arg -> checks [ do
- (tab',ty) <- inferLType gr g tab
- ty' <- computeLType gr g ty
- case ty' of
- Table p t -> do
- (arg',val) <- checkLType gr g arg p
- checkEqLType gr g typ t trm
- return (S tab' arg', t)
- _ -> checkError (text "table type expected for applied table instead of" <+> ppType ty')
- , do
- (arg',ty) <- inferLType gr g arg
- ty' <- computeLType gr g ty
- (tab',_) <- checkLType gr g tab (Table ty' typ)
- return (S tab' arg', typ)
- ]
- Let (x,(mty,def)) body -> case mty of
- Just ty -> do
- (def',ty') <- checkLType gr g def ty
- body' <- justCheck ((Explicit,x,ty'):g) body typ
- return (Let (x,(Just ty',def')) body', typ)
- _ -> do
- (def',ty) <- inferLType gr g def -- tries to infer type of local constant
- checkLType gr g (Let (x,(Just ty,def')) body) typ
-
- ELin c tr -> do
- tr1 <- checkErr $ unlockRecord c tr
- checkLType gr g tr1 typ
-
- _ -> do
- (trm',ty') <- inferLType gr g trm
- termWith trm' $ checkEqLType gr g typ ty' trm'
- where
- justCheck g ty te = checkLType gr g ty te >>= return . fst
-
- recParts rr t = (RecType rr1,RecType rr2) where
- (rr1,rr2) = partition (flip elem (map fst t) . fst) rr
-
- checkM rms (l,ty) = case lookup l rms of
- Just (Just ty0,t) -> do
- checkEqLType gr g ty ty0 t
- (t',ty') <- checkLType gr g t ty
- return (l,(Just ty',t'))
- Just (_,t) -> do
- (t',ty') <- checkLType gr g t ty
- return (l,(Just ty',t'))
- _ -> checkError $
- if isLockLabel l
- then let cat = drop 5 (showIdent (label2ident l))
- in ppTerm Unqualified 0 (R rms) <+> text "is not in the lincat of" <+> text cat <>
- text "; try wrapping it with lin" <+> text cat
- else text "cannot find value for label" <+> ppLabel l <+> text "in" <+> ppTerm Unqualified 0 (R rms)
-
- checkCase arg val (p,t) = do
- cont <- pattContext gr g arg p
- t' <- justCheck (reverse cont ++ g) t val
- return (p,t')
-
-pattContext :: SourceGrammar -> Context -> Type -> Patt -> Check Context
-pattContext env g typ p = case p of
- PV x -> return [(Explicit,x,typ)]
- PP q c ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006
- t <- checkErr $ lookupResType env q c
- let (cont,v) = typeFormCnc t
- checkCond (text "wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p)
- (length cont == length ps)
- checkEqLType env g typ v (patt2term p)
- mapM (\((_,_,ty),p) -> pattContext env g ty p) (zip cont ps) >>= return . concat
- PR r -> do
- typ' <- computeLType env g typ
- case typ' of
- RecType t -> do
- let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]]
- ----- checkWarn $ prt p ++++ show pts ----- debug
- mapM (uncurry (pattContext env g)) pts >>= return . concat
- _ -> checkError (text "record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ')
- PT t p' -> do
- checkEqLType env g typ t (patt2term p')
- pattContext env g typ p'
-
- PAs x p -> do
- g' <- pattContext env g typ p
- return ((Explicit,x,typ):g')
-
- PAlt p' q -> do
- g1 <- pattContext env g typ p'
- g2 <- pattContext env g typ q
- let pts = nub ([x | pt@(_,x,_) <- g1, notElem pt g2] ++ [x | pt@(_,x,_) <- g2, notElem pt g1])
- checkCond
- (text "incompatible bindings of" <+>
- fsep (map ppIdent pts) <+>
- text "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts)
- return g1 -- must be g1 == g2
- PSeq p q -> do
- g1 <- pattContext env g typ p
- g2 <- pattContext env g typ q
- return $ g1 ++ g2
- PRep p' -> noBind typeStr p'
- PNeg p' -> noBind typ p'
-
- _ -> return [] ---- check types!
- where
- noBind typ p' = do
- co <- pattContext env g typ p'
- if not (null co)
- then checkWarn (text "no variable bound inside pattern" <+> ppPatt Unqualified 0 p)
- >> return []
- else return []
-
-checkEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check Type
-checkEqLType gr g t u trm = do
- (b,t',u',s) <- checkIfEqLType gr g t u trm
- case b of
- True -> return t'
- False -> checkError $ text s <+> text "type of" <+> ppTerm Unqualified 0 trm $$
- text "expected:" <+> ppType t $$
- text "inferred:" <+> ppType u
-
-checkIfEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check (Bool,Type,Type,String)
-checkIfEqLType gr g t u trm = do
- t' <- computeLType gr g t
- u' <- computeLType gr g u
- case t' == u' || alpha [] t' u' of
- True -> return (True,t',u',[])
- -- forgive missing lock fields by only generating a warning.
- --- better: use a flag to forgive? (AR 31/1/2006)
- _ -> case missingLock [] t' u' of
- Ok lo -> do
- checkWarn $ text "missing lock field" <+> fsep (map ppLabel lo)
- return (True,t',u',[])
- Bad s -> return (False,t',u',s)
-
- where
-
- -- t is a subtype of u
- --- quick hack version of TC.eqVal
- alpha g t u = case (t,u) of
-
- -- error (the empty type!) is subtype of any other type
- (_,u) | u == typeError -> True
-
- -- contravariance
- (Prod _ x a b, Prod _ y c d) -> alpha g c a && alpha ((x,y):g) b d
-
- -- record subtyping
- (RecType rs, RecType ts) -> all (\ (l,a) ->
- any (\ (k,b) -> alpha g a b && l == k) ts) rs
- (ExtR r s, ExtR r' s') -> alpha g r r' && alpha g s s'
- (ExtR r s, t) -> alpha g r t || alpha g s t
-
- -- the following say that Ints n is a subset of Int and of Ints m >= n
- (t,u) | Just m <- isTypeInts t, Just n <- isTypeInts t -> m >= n
- | Just _ <- isTypeInts t, u == typeInt -> True ---- check size!
- | t == typeInt, Just _ <- isTypeInts u -> True ---- why this ???? AR 11/12/2005
-
- ---- this should be made in Rename
- (Q m a, Q n b) | a == b -> elem m (allExtendsPlus gr n)
- || elem n (allExtendsPlus gr m)
- || m == n --- for Predef
- (QC m a, QC n b) | a == b -> elem m (allExtendsPlus gr n)
- || elem n (allExtendsPlus gr m)
- (QC m a, Q n b) | a == b -> elem m (allExtendsPlus gr n)
- || elem n (allExtendsPlus gr m)
- (Q m a, QC n b) | a == b -> elem m (allExtendsPlus gr n)
- || elem n (allExtendsPlus gr m)
-
- (Table a b, Table c d) -> alpha g a c && alpha g b d
- (Vr x, Vr y) -> x == y || elem (x,y) g || elem (y,x) g
- _ -> t == u
- --- the following should be one-way coercions only. AR 4/1/2001
- || elem t sTypes && elem u sTypes
- || (t == typeType && u == typePType)
- || (u == typeType && t == typePType)
-
- missingLock g t u = case (t,u) of
- (RecType rs, RecType ts) ->
- let
- ls = [l | (l,a) <- rs,
- not (any (\ (k,b) -> alpha g a b && l == k) ts)]
- (locks,others) = partition isLockLabel ls
- in case others of
- _:_ -> Bad $ render (text "missing record fields:" <+> fsep (punctuate comma (map ppLabel others)))
- _ -> return locks
- -- contravariance
- (Prod _ x a b, Prod _ y c d) -> do
- ls1 <- missingLock g c a
- ls2 <- missingLock g b d
- return $ ls1 ++ ls2
-
- _ -> Bad ""
-
- sTypes = [typeStr, typeTok, typeString]
-
--- auxiliaries
-
--- | light-weight substitution for dep. types
-substituteLType :: Context -> Type -> Check Type
-substituteLType g t = case t of
- Vr x -> return $ maybe t id $ lookup x [(x,t) | (_,x,t) <- g]
- _ -> composOp (substituteLType g) t
-
-termWith :: Term -> Check Type -> Check (Term, Type)
-termWith t ct = do
- ty <- ct
- return (t,ty)
-
--- | compositional check\/infer of binary operations
-check2 :: (Term -> Check Term) -> (Term -> Term -> Term) ->
- Term -> Term -> Type -> Check (Term,Type)
-check2 chk con a b t = do
- a' <- chk a
- b' <- chk b
- return (con a' b', t)
-
--- printing a type with a lock field lock_C as C
-ppType :: Type -> Doc
-ppType ty =
- case ty of
- RecType fs -> case filter isLockLabel $ map fst fs of
- [lock] -> text (drop 5 (showIdent (label2ident lock)))
- _ -> ppTerm Unqualified 0 ty
- Prod _ x a b -> ppType a <+> text "->" <+> ppType b
- _ -> ppTerm Unqualified 0 ty
-
-checkLookup :: Ident -> Context -> Check Type
-checkLookup x g =
- case [ty | (b,y,ty) <- g, x == y] of
- [] -> checkError (text "unknown variable" <+> ppIdent x)
- (ty:_) -> return ty
diff --git a/src/GF/Compile/Export.hs b/src/GF/Compile/Export.hs
deleted file mode 100644
index d03eb947e..000000000
--- a/src/GF/Compile/Export.hs
+++ /dev/null
@@ -1,64 +0,0 @@
-module GF.Compile.Export where
-
-import PGF.CId
-import PGF.Data (PGF(..))
-import GF.Compile.GFCCtoHaskell
-import GF.Compile.GFCCtoProlog
-import GF.Compile.GFCCtoJS
-import GF.Compile.PGFPretty
-import GF.Infra.Option
-import GF.Speech.CFG
-import GF.Speech.PGFToCFG
-import GF.Speech.SRGS_ABNF
-import GF.Speech.SRGS_XML
-import GF.Speech.JSGF
-import GF.Speech.GSL
-import GF.Speech.SRG
-import GF.Speech.VoiceXML
-import GF.Speech.SLF
-import GF.Speech.PrRegExp
-
-import Data.Maybe
-import System.FilePath
-
--- top-level access to code generation
-
-exportPGF :: Options
- -> OutputFormat
- -> PGF
- -> [(FilePath,String)] -- ^ List of recommended file names and contents.
-exportPGF opts fmt pgf =
- case fmt of
- FmtPGFPretty -> multi "txt" prPGFPretty
- FmtPMCFGPretty -> single "pmcfg" prPMCFGPretty
- FmtJavaScript -> multi "js" pgf2js
- FmtHaskell -> multi "hs" (grammar2haskell opts name)
- FmtProlog -> multi "pl" grammar2prolog
- FmtProlog_Abs -> multi "pl" grammar2prolog_abs
- FmtBNF -> single "bnf" bnfPrinter
- FmtEBNF -> single "ebnf" (ebnfPrinter opts)
- FmtSRGS_XML -> single "grxml" (srgsXmlPrinter opts)
- FmtSRGS_XML_NonRec -> single "grxml" (srgsXmlNonRecursivePrinter opts)
- FmtSRGS_ABNF -> single "gram" (srgsAbnfPrinter opts)
- FmtSRGS_ABNF_NonRec -> single "gram" (srgsAbnfNonRecursivePrinter opts)
- FmtJSGF -> single "jsgf" (jsgfPrinter opts)
- FmtGSL -> single "gsl" (gslPrinter opts)
- FmtVoiceXML -> single "vxml" grammar2vxml
- FmtSLF -> single "slf" slfPrinter
- FmtRegExp -> single "rexp" regexpPrinter
- FmtFA -> single "dot" slfGraphvizPrinter
- where
- name = fromMaybe (showCId (absname pgf)) (flag optName opts)
-
- multi :: String -> (PGF -> String) -> [(FilePath,String)]
- multi ext pr = [(name <.> ext, pr pgf)]
-
- single :: String -> (PGF -> CId -> String) -> [(FilePath,String)]
- single ext pr = [(showCId cnc <.> ext, pr pgf cnc) | cnc <- cncnames pgf]
-
--- | Get the name of the concrete syntax to generate output from.
--- FIXME: there should be an option to change this.
-outputConcr :: PGF -> CId
-outputConcr pgf = case cncnames pgf of
- [] -> error "No concrete syntax."
- cnc:_ -> cnc
diff --git a/src/GF/Compile/GFCCtoHaskell.hs b/src/GF/Compile/GFCCtoHaskell.hs
deleted file mode 100644
index d44d6705c..000000000
--- a/src/GF/Compile/GFCCtoHaskell.hs
+++ /dev/null
@@ -1,230 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : GFCCtoHaskell
--- Maintainer : Aarne Ranta
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/06/17 12:39:07 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.8 $
---
--- to write a GF abstract grammar into a Haskell module with translations from
--- data objects into GF trees. Example: GSyntax for Agda.
--- AR 11/11/1999 -- 7/12/2000 -- 18/5/2004
------------------------------------------------------------------------------
-
-module GF.Compile.GFCCtoHaskell (grammar2haskell) where
-
-import PGF.CId
-import PGF.Data
-import PGF.Macros
-
-import GF.Data.Operations
-import GF.Infra.Option
-import GF.Text.UTF8
-
-import Data.List --(isPrefixOf, find, intersperse)
-import qualified Data.Map as Map
-
-type Prefix = String -> String
-
--- | the main function
-grammar2haskell :: Options
- -> String -- ^ Module name.
- -> PGF
- -> String
-grammar2haskell opts name gr = encodeUTF8 $ foldr (++++) [] $
- pragmas ++ haskPreamble name ++ [types, gfinstances gId lexical gr']
- where gr' = hSkeleton gr
- gadt = haskellOption opts HaskellGADT
- lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat
- gId | haskellOption opts HaskellNoPrefix = id
- | otherwise = ("G"++)
- pragmas | gadt = ["{-# OPTIONS_GHC -fglasgow-exts #-}"]
- | otherwise = []
- types | gadt = datatypesGADT gId lexical gr'
- | otherwise = datatypes gId lexical gr'
-
-haskPreamble name =
- [
- "module " ++ name ++ " where",
- "",
- "import PGF",
- "----------------------------------------------------",
- "-- automatic translation from GF to Haskell",
- "----------------------------------------------------",
- "",
- "class Gf a where",
- " gf :: a -> Tree",
- " fg :: Tree -> a",
- "",
- predefInst "GString" "String" "unStr" "mkStr",
- "",
- predefInst "GInt" "Integer" "unInt" "mkInt",
- "",
- predefInst "GFloat" "Double" "unDouble" "mkDouble",
- "",
- "----------------------------------------------------",
- "-- below this line machine-generated",
- "----------------------------------------------------",
- ""
- ]
-
-predefInst gtyp typ destr consr =
- "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show" +++++
- "instance Gf" +++ gtyp +++ "where" ++++
- " gf (" ++ gtyp +++ "x) =" +++ consr +++ "x" ++++
- " fg t =" ++++
- " case "++destr++" t of" ++++
- " Just x -> " +++ gtyp +++ "x" ++++
- " Nothing -> error (\"no" +++ gtyp +++ "\" ++ show t)"
-
-type OIdent = String
-
-type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
-
-datatypes :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
-datatypes gId lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId lexical)) . snd
-
-gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
-gfinstances gId lexical (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance gId lexical m)) g
-
-
-hDatatype :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String
-hDatatype _ _ ("Cn",_) = "" ---
-hDatatype _ _ (cat,[]) = ""
-hDatatype gId _ (cat,rules) | isListCat (cat,rules) =
- "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]"
- +++ "deriving Show"
-hDatatype gId lexical (cat,rules) =
- "data" +++ gId cat +++ "=" ++
- (if length rules == 1 then "" else "\n ") +++
- foldr1 (\x y -> x ++ "\n |" +++ y) constructors ++++
- " deriving Show"
- where
- constructors = [gId f +++ foldr (+++) "" (map (gId) xx) | (f,xx) <- nonLexicalRules (lexical cat) rules]
- ++ if lexical cat then [lexicalConstructor cat +++ "String"] else []
-
-nonLexicalRules :: Bool -> [(OIdent, [OIdent])] -> [(OIdent, [OIdent])]
-nonLexicalRules False rules = rules
-nonLexicalRules True rules = [r | r@(f,t) <- rules, not (null t)]
-
-lexicalConstructor :: OIdent -> String
-lexicalConstructor cat = "Lex" ++ cat
-
--- GADT version of data types
-datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
-datatypesGADT gId lexical (_,skel) =
- unlines (concatMap (hCatTypeGADT gId) skel)
- +++++
- "data Tree :: * -> * where" ++++ unlines (concatMap (map (" "++) . hDatatypeGADT gId lexical) skel)
-
-hCatTypeGADT :: Prefix -> (OIdent, [(OIdent, [OIdent])]) -> [String]
-hCatTypeGADT gId (cat,rules)
- = ["type"+++gId cat+++"="+++"Tree"+++gId cat++"_",
- "data"+++gId cat++"_"]
-
-hDatatypeGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
-hDatatypeGADT gId lexical (cat, rules)
- | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t]
- | otherwise =
- [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t
- | (f,args) <- nonLexicalRules (lexical cat) rules ]
- ++ if lexical cat then [lexicalConstructor cat +++ ":: String ->"+++ t] else []
- where t = "Tree" +++ gId cat ++ "_"
-
-gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String
-gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs
-
-----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
-hInstance _ _ m (cat,[]) = ""
-hInstance gId lexical m (cat,rules)
- | isListCat (cat,rules) =
- "instance Gf" +++ gId cat +++ "where" ++++
- " gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])"
- +++ "=" +++ mkRHS ("Base"++ec) baseVars ++++
- " gf (" ++ gId cat +++ "(x:xs)) = "
- ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")]
--- no show for GADTs
--- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)"
- | otherwise =
- "instance Gf" +++ gId cat +++ "where\n" ++
- unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules]
- ++ if lexical cat then [" gf (" ++ lexicalConstructor cat +++ "x) = mkApp (mkCId x) []"] else [])
- where
- ec = elemCat cat
- baseVars = mkVars (baseSize (cat,rules))
- mkInst f xx = let xx' = mkVars (length xx) in " gf " ++
- (if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
- "=" +++ mkRHS f xx'
- mkVars n = ["x" ++ show i | i <- [1..n]]
- mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++
- "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
-
-
-----fInstance m ("Cn",_) = "" ---
-fInstance _ _ m (cat,[]) = ""
-fInstance gId lexical m (cat,rules) =
- " fg t =" ++++
- " case unApp t of" ++++
- unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++
- (if lexical cat then " (i,[]) -> " ++ lexicalConstructor cat +++ "(prCId i)" else "") ++++
- " _ -> error (\"no" +++ cat ++ " \" ++ show t)"
- where
- mkInst f xx =
- " Just (i," ++
- "[" ++ prTList "," xx' ++ "])" +++
- "| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx'
- where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
- mkRHS f vars
- | isListCat (cat,rules) =
- if "Base" `isPrefixOf` f then
- gId cat +++ "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
- else
- let (i,t) = (init vars,last vars)
- in "let" +++ gId cat +++ "xs = fg " ++ t +++ "in" +++
- gId cat +++ prParenth (prTList ":" (["fg"+++v | v <- i] ++ ["xs"]))
- | otherwise =
- gId f +++
- prTList " " [prParenth ("fg" +++ x) | x <- vars]
-
-
---type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
-hSkeleton :: PGF -> (String,HSkeleton)
-hSkeleton gr =
- (showCId (absname gr),
- [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) |
- fs@((_, (_,c)):_) <- fns]
- )
- where
- fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
- valtyps (_, (_,x)) (_, (_,y)) = compare x y
- valtypg (_, (_,x)) (_, (_,y)) = x == y
- jty (f,(ty,_,_)) = (f,catSkeleton ty)
-
-updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton
-updateSkeleton cat skel rule =
- case skel of
- (cat0,rules):rr | cat0 == cat -> (cat0, rule:rules) : rr
- (cat0,rules):rr -> (cat0, rules) : updateSkeleton cat rr rule
-
-isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool
-isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2
- && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
- where c = elemCat cat
- fs = map fst rules
-
--- | Gets the element category of a list category.
-elemCat :: OIdent -> OIdent
-elemCat = drop 4
-
-isBaseFun :: OIdent -> Bool
-isBaseFun f = "Base" `isPrefixOf` f
-
-isConsFun :: OIdent -> Bool
-isConsFun f = "Cons" `isPrefixOf` f
-
-baseSize :: (OIdent, [(OIdent, [OIdent])]) -> Int
-baseSize (_,rules) = length bs
- where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules
diff --git a/src/GF/Compile/GFCCtoJS.hs b/src/GF/Compile/GFCCtoJS.hs
deleted file mode 100644
index 312701e3b..000000000
--- a/src/GF/Compile/GFCCtoJS.hs
+++ /dev/null
@@ -1,138 +0,0 @@
-module GF.Compile.GFCCtoJS (pgf2js) where
-
-import PGF.CId
-import PGF.Data hiding (mkStr)
-import qualified PGF.Macros as M
-import qualified GF.JavaScript.AbsJS as JS
-import qualified GF.JavaScript.PrintJS as JS
-
-import GF.Text.UTF8
-import GF.Data.ErrM
-import GF.Infra.Option
-
-import Control.Monad (mplus)
-import Data.Array.Unboxed (UArray)
-import qualified Data.Array.IArray as Array
-import Data.Maybe (fromMaybe)
-import Data.Map (Map)
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-import qualified Data.IntMap as IntMap
-
-pgf2js :: PGF -> String
-pgf2js pgf =
- encodeUTF8 $ JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]]
- where
- n = showCId $ absname pgf
- as = abstract pgf
- cs = Map.assocs (concretes pgf)
- start = showCId $ M.lookStartCat pgf
- grammar = new "GFGrammar" [js_abstract, js_concrete]
- js_abstract = abstract2js start as
- js_concrete = JS.EObj $ map (concrete2js start n) cs
-
-abstract2js :: String -> Abstr -> JS.Expr
-abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))]
-
-absdef2js :: (CId,(Type,Int,[Equation])) -> JS.Property
-absdef2js (f,(typ,_,_)) =
- let (args,cat) = M.catSkeleton typ in
- JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)])
-
-concrete2js :: String -> String -> (CId,Concr) -> JS.Property
-concrete2js start n (c, cnc) =
- JS.Prop l (new "GFConcrete" ([flags,(JS.EObj $ ((map (cncdef2js n (showCId c)) ds) ++ litslins))] ++
- maybe [] (parser2js start) (parser cnc)))
- where
- flags = mapToJSObj JS.EStr $ cflags cnc
- l = JS.IdentPropName (JS.Ident (showCId c))
- ds = concatMap Map.assocs [lins cnc, opers cnc, lindefs cnc]
- litslins = [JS.Prop (JS.StringPropName "Int") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
- JS.Prop (JS.StringPropName "Float") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
- JS.Prop (JS.StringPropName "String") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]])]
-
-
-cncdef2js :: String -> String -> (CId,Term) -> JS.Property
-cncdef2js n l (f, t) = JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (JS.EFun [children] [JS.SReturn (term2js n l t)])
-
-term2js :: String -> String -> Term -> JS.Expr
-term2js n l t = f t
- where
- f t =
- case t of
- R xs -> new "Arr" (map f xs)
- P x y -> JS.ECall (JS.EMember (f x) (JS.Ident "sel")) [f y]
- S xs -> mkSeq (map f xs)
- K t -> tokn2js t
- V i -> JS.EIndex (JS.EVar children) (JS.EInt i)
- C i -> new "Int" [JS.EInt i]
- F f -> JS.ECall (JS.EMember (JS.EIndex (JS.EMember (JS.EVar $ JS.Ident n) (JS.Ident "concretes")) (JS.EStr l)) (JS.Ident "rule")) [JS.EStr (showCId f), JS.EVar children]
- FV xs -> new "Variants" (map f xs)
- W str x -> new "Suffix" [JS.EStr str, f x]
- TM _ -> new "Meta" []
-
-tokn2js :: Tokn -> JS.Expr
-tokn2js (KS s) = mkStr s
-tokn2js (KP ss vs) = mkSeq (map mkStr ss) -- FIXME
-
-mkStr :: String -> JS.Expr
-mkStr s = new "Str" [JS.EStr s]
-
-mkSeq :: [JS.Expr] -> JS.Expr
-mkSeq [x] = x
-mkSeq xs = new "Seq" xs
-
-argIdent :: Integer -> JS.Ident
-argIdent n = JS.Ident ("x" ++ show n)
-
-children :: JS.Ident
-children = JS.Ident "cs"
-
--- Parser
-parser2js :: String -> ParserInfo -> [JS.Expr]
-parser2js start p = [new "Parser" [JS.EStr start,
- JS.EArray $ [frule2js p cat prod | (cat,set) <- IntMap.toList (productions p), prod <- Set.toList set],
- JS.EObj $ map cats (Map.assocs (startCats p))]]
- where
- cats (c,is) = JS.Prop (JS.IdentPropName (JS.Ident (showCId c))) (JS.EArray (map JS.EInt is))
-
-frule2js :: ParserInfo -> FCat -> Production -> JS.Expr
-frule2js p res (FApply funid args) = new "Rule" [JS.EInt res, name2js (f,ps), JS.EArray (map JS.EInt args), lins2js p lins]
- where
- FFun f ps lins = functions p Array.! funid
-frule2js p res (FCoerce arg) = new "Rule" [JS.EInt res, daughter 0, JS.EArray [JS.EInt arg], JS.EArray [JS.EArray [sym2js (FSymCat 0 i)] | i <- [0..catLinArity arg-1]]]
- where
- catLinArity :: FCat -> Int
- catLinArity c = maximum (1:[Array.rangeSize (Array.bounds rhs) | (FFun _ _ rhs, _) <- topdownRules c])
-
- topdownRules cat = f cat []
- where
- f cat rules = maybe rules (Set.fold g rules) (IntMap.lookup cat (productions p))
-
- g (FApply funid args) rules = (functions p Array.! funid,args) : rules
- g (FCoerce cat) rules = f cat rules
-
-
-name2js :: (CId,[Profile]) -> JS.Expr
-name2js (f,ps) = new "FunApp" $ [JS.EStr $ showCId f, JS.EArray (map fromProfile ps)]
- where
- fromProfile :: Profile -> JS.Expr
- fromProfile [] = new "MetaVar" []
- fromProfile [x] = daughter x
- fromProfile args = new "Unify" [JS.EArray (map daughter args)]
-
-daughter i = new "Arg" [JS.EInt i]
-
-lins2js :: ParserInfo -> UArray FIndex SeqId -> JS.Expr
-lins2js p ls = JS.EArray [JS.EArray [sym2js s | s <- Array.elems (sequences p Array.! seqid)] | seqid <- Array.elems ls]
-
-sym2js :: FSymbol -> JS.Expr
-sym2js (FSymCat n l) = new "ArgProj" [JS.EInt n, JS.EInt l]
-sym2js (FSymLit n l) = new "ArgProj" [JS.EInt n, JS.EInt l]
-sym2js (FSymKS [t]) = new "Terminal" [JS.EStr t]
-
-new :: String -> [JS.Expr] -> JS.Expr
-new f xs = JS.ENew (JS.Ident f) xs
-
-mapToJSObj :: (a -> JS.Expr) -> Map CId a -> JS.Expr
-mapToJSObj f m = JS.EObj [ JS.Prop (JS.IdentPropName (JS.Ident (showCId k))) (f v) | (k,v) <- Map.toList m ]
diff --git a/src/GF/Compile/GFCCtoProlog.hs b/src/GF/Compile/GFCCtoProlog.hs
deleted file mode 100644
index 702d4afe5..000000000
--- a/src/GF/Compile/GFCCtoProlog.hs
+++ /dev/null
@@ -1,279 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : GFCCtoProlog
--- Maintainer : Peter Ljunglöf
--- Stability : (stable)
--- Portability : (portable)
---
--- to write a GF grammar into a Prolog module
------------------------------------------------------------------------------
-
-module GF.Compile.GFCCtoProlog (grammar2prolog, grammar2prolog_abs) where
-
-import PGF.CId
-import PGF.Data
-import PGF.Macros
-
-import GF.Data.Operations
-import GF.Text.UTF8
-
-import qualified Data.Map as Map
-import Data.Char (isAlphaNum, isAsciiLower, isAsciiUpper, ord)
-import Data.List (isPrefixOf,mapAccumL)
-
-grammar2prolog, grammar2prolog_abs :: PGF -> String
--- Most prologs have problems with UTF8 encodings, so we skip that:
-grammar2prolog = {- encodeUTF8 . -} foldr (++++) [] . pgf2clauses
-grammar2prolog_abs = {- encodeUTF8 . -} foldr (++++) [] . pgf2clauses_abs
-
-
-pgf2clauses :: PGF -> [String]
-pgf2clauses (PGF absname cncnames gflags abstract concretes) =
- [":- " ++ plFact "module" [plp absname, "[]"]] ++
- clauseHeader "%% concrete(?Module)"
- [plFact "concrete" [plp cncname] | cncname <- cncnames] ++
- clauseHeader "%% flag(?Flag, ?Value): global flags"
- (map (plpFact2 "flag") (Map.assocs gflags)) ++
- plAbstract (absname, abstract) ++
- concatMap plConcrete (Map.assocs concretes)
-
-pgf2clauses_abs :: PGF -> [String]
-pgf2clauses_abs (PGF absname _cncnames gflags abstract _concretes) =
- [":- " ++ plFact "module" [plp absname, "[]"]] ++
- clauseHeader "%% flag(?Flag, ?Value): global flags"
- (map (plpFact2 "flag") (Map.assocs gflags)) ++
- plAbstract (absname, abstract)
-
-clauseHeader :: String -> [String] -> [String]
-clauseHeader hdr [] = []
-clauseHeader hdr clauses = "":hdr:clauses
-
-
-----------------------------------------------------------------------
--- abstract syntax
-
-plAbstract :: (CId, Abstr) -> [String]
-plAbstract (name, Abstr aflags funs cats _catfuns) =
- ["", "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%",
- "%% abstract module: " ++ plp name] ++
- clauseHeader "%% absflag(?Flag, ?Value): flags for abstract syntax"
- (map (plpFact2 "absflag") (Map.assocs aflags)) ++
- clauseHeader "%% cat(?Type, ?[X:Type,...])"
- (map plCat (Map.assocs cats)) ++
- clauseHeader "%% fun(?Fun, ?Type, ?[X:Type,...])"
- (map plFun (Map.assocs funs)) ++
- clauseHeader "%% def(?Fun, ?Expr)"
- (concatMap plFundef (Map.assocs funs))
-
-plCat :: (CId, [Hypo]) -> String
-plCat (cat, hypos) = plFact "cat" (plTypeWithHypos typ)
- where ((_,subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos
- args = reverse [EFun x | (_,x) <- subst]
- typ = DTyp hypos' cat args
-
-plFun :: (CId, (Type, Int, [Equation])) -> String
-plFun (fun, (typ,_,_)) = plFact "fun" (plp fun : plTypeWithHypos typ')
- where typ' = snd $ alphaConvert emptyEnv typ
-
-plTypeWithHypos :: Type -> [String]
-plTypeWithHypos (DTyp hypos cat args) = [plTerm (plp cat) (map plp args), plList (map (\(_,x,ty) -> plOper ":" (plp x) (plp ty)) hypos)]
-
-plFundef :: (CId, (Type,Int,[Equation])) -> [String]
-plFundef (fun, (_,_,[])) = []
-plFundef (fun, (_,_,eqs)) = [plFact "def" [plp fun, plp fundef']]
- where fundef' = snd $ alphaConvert emptyEnv eqs
-
-
-----------------------------------------------------------------------
--- concrete syntax
-
-plConcrete :: (CId, Concr) -> [String]
-plConcrete (cncname, Concr cflags lins opers lincats lindefs
- _printnames _paramlincats _parser) =
- ["", "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%",
- "%% concrete module: " ++ plp cncname] ++
- clauseHeader "%% cncflag(?Flag, ?Value): flags for concrete syntax"
- (map (mod . plpFact2 "cncflag") (Map.assocs cflags)) ++
- clauseHeader "%% lincat(?Cat, ?Linearization type)"
- (map (mod . plpFact2 "lincat") (Map.assocs lincats)) ++
- clauseHeader "%% lindef(?Cat, ?Linearization default)"
- (map (mod . plpFact2 "lindef") (Map.assocs lindefs)) ++
- clauseHeader "%% lin(?Fun, ?Linearization)"
- (map (mod . plpFact2 "lin") (Map.assocs lins)) ++
- clauseHeader "%% oper(?Oper, ?Linearization)"
- (map (mod . plpFact2 "oper") (Map.assocs opers))
- where mod clause = plp cncname ++ ": " ++ clause
-
-
-----------------------------------------------------------------------
--- prolog-printing pgf datatypes
-
-instance PLPrint Type where
- plp (DTyp hypos cat args) | null hypos = result
- | otherwise = plOper " -> " (plList (map (\(_,x,ty) -> plOper ":" (plp x) (plp ty)) hypos)) result
- where result = plTerm (plp cat) (map plp args)
-
-instance PLPrint Expr where
- plp (EFun x) = plp x
- plp (EAbs _ x e)= plOper "^" (plp x) (plp e)
- plp (EApp e e') = plOper " * " (plp e) (plp e')
- plp (ELit lit) = plp lit
- plp (EMeta n) = "Meta_" ++ show n
-
-instance PLPrint Patt where
- plp (PVar x) = plp x
- plp (PApp f ps) = plOper " * " (plp f) (plp ps)
- plp (PLit lit) = plp lit
-
-instance PLPrint Equation where
- plp (Equ patterns result) = plOper ":" (plp patterns) (plp result)
-
-instance PLPrint Term where
- plp (S terms) = plTerm "s" [plp terms]
- plp (C n) = plTerm "c" [show n]
- plp (K tokn) = plTerm "k" [plp tokn]
- plp (FV trms) = plTerm "fv" [plp trms]
- plp (P t1 t2) = plTerm "p" [plp t1, plp t2]
- plp (W s trm) = plTerm "w" [plp s, plp trm]
- plp (R terms) = plTerm "r" [plp terms]
- plp (F oper) = plTerm "f" [plp oper]
- plp (V n) = plTerm "v" [show n]
- plp (TM str) = plTerm "tm" [plp str]
-
-{-- more prolog-like syntax for PGF terms, but also more difficult to handle:
-instance PLPrint Term where
- plp (S terms) = plp terms
- plp (C n) = show n
- plp (K token) = plp token
- plp (FV terms) = prCurlyList (map plp terms)
- plp (P t1 t2) = plOper "/" (plp t1) (plp t2)
- plp (W s trm) = plOper "+" (plp s) (plp trm)
- plp (R terms) = plTerm "r" (map plp terms)
- plp (F oper) = plTerm "f" [plp oper]
- plp (V n) = plTerm "arg" [show n]
- plp (TM str) = plTerm "meta" [plp str]
---}
-
-instance PLPrint CId where
- plp cid | isLogicalVariable str ||
- cid == wildCId = plVar str
- | otherwise = plAtom str
- where str = showCId cid
-
-instance PLPrint Literal where
- plp (LStr s) = plp s
- plp (LInt n) = plp (show n)
- plp (LFlt f) = plp (show f)
-
-instance PLPrint Tokn where
- plp (KS tokn) = plp tokn
- plp (KP strs alts) = plTerm "kp" [plp strs, plList [plOper "/" (plp ss1) (plp ss2) |
- Alt ss1 ss2 <- alts]]
-
-----------------------------------------------------------------------
--- basic prolog-printing
-
-class PLPrint a where
- plp :: a -> String
- plps :: [a] -> String
- plps = plList . map plp
-
-instance PLPrint Char where
- plp c = plAtom [c]
- plps s = plAtom s
-
-instance PLPrint a => PLPrint [a] where
- plp = plps
-
-plpFact2 :: (PLPrint a, PLPrint b) => String -> (a, b) -> String
-plpFact2 fun (arg1, arg2) = plFact fun [plp arg1, plp arg2]
-
-plFact :: String -> [String] -> String
-plFact fun args = plTerm fun args ++ "."
-
-plTerm :: String -> [String] -> String
-plTerm fun args = plAtom fun ++ prParenth (prTList ", " args)
-
-plList :: [String] -> String
-plList = prBracket . prTList ","
-
-plOper :: String -> String -> String -> String
-plOper op a b = prParenth (a ++ op ++ b)
-
-plVar :: String -> String
-plVar = varPrefix . concatMap changeNonAlphaNum
- where varPrefix var@(c:_) | isAsciiUpper c || c=='_' = var
- | otherwise = "_" ++ var
- changeNonAlphaNum c | isAlphaNumUnderscore c = [c]
- | otherwise = "_" ++ show (ord c) ++ "_"
-
-plAtom :: String -> String
-plAtom "" = "''"
-plAtom atom@(c:cs) | isAsciiLower c && all isAlphaNumUnderscore cs
- || c == '\'' && cs /= "" && last cs == '\'' = atom
- | otherwise = "'" ++ concatMap changeQuote atom ++ "'"
- where changeQuote '\'' = "\\'"
- changeQuote c = [c]
-
-isAlphaNumUnderscore :: Char -> Bool
-isAlphaNumUnderscore c = isAlphaNum c || c == '_'
-
-
-----------------------------------------------------------------------
--- prolog variables
-
-createLogicalVariable :: Int -> CId
-createLogicalVariable n = mkCId (logicalVariablePrefix ++ show n)
-
-isLogicalVariable :: String -> Bool
-isLogicalVariable = isPrefixOf logicalVariablePrefix
-
-logicalVariablePrefix :: String
-logicalVariablePrefix = "X"
-
-----------------------------------------------------------------------
--- alpha convert variables to (unique) logical variables
--- * this is needed if we want to translate variables to Prolog variables
--- * used for abstract syntax, not concrete
--- * not (yet?) used for variables bound in pattern equations
-
-type ConvertEnv = (Int, [(CId,CId)])
-
-emptyEnv :: ConvertEnv
-emptyEnv = (0, [])
-
-class AlphaConvert a where
- alphaConvert :: ConvertEnv -> a -> (ConvertEnv, a)
-
-instance AlphaConvert a => AlphaConvert [a] where
- alphaConvert env [] = (env, [])
- alphaConvert env (a:as) = (env'', a':as')
- where (env', a') = alphaConvert env a
- (env'', as') = alphaConvert env' as
-
-instance AlphaConvert Type where
- alphaConvert env@(_,subst) (DTyp hypos cat args)
- = ((ctr,subst), DTyp hypos' cat args')
- where (env', hypos') = mapAccumL alphaConvertHypo env hypos
- ((ctr,_), args') = alphaConvert env' args
-
-alphaConvertHypo env (b,x,typ) = ((ctr+1,(x,x'):subst), (b,x',typ'))
- where ((ctr,subst), typ') = alphaConvert env typ
- x' = createLogicalVariable ctr
-
-instance AlphaConvert Expr where
- alphaConvert (ctr,subst) (EAbs b x e) = ((ctr',subst), EAbs b x' e')
- where ((ctr',_), e') = alphaConvert (ctr+1,(x,x'):subst) e
- x' = createLogicalVariable ctr
- alphaConvert env (EApp e1 e2) = (env'', EApp e1' e2')
- where (env', e1') = alphaConvert env e1
- (env'', e2') = alphaConvert env' e2
- alphaConvert env expr@(EFun i) = (env, maybe expr EFun (lookup i (snd env)))
- alphaConvert env expr = (env, expr)
-
--- pattern variables are not alpha converted
--- (but they probably should be...)
-instance AlphaConvert Equation where
- alphaConvert env@(_,subst) (Equ patterns result)
- = ((ctr,subst), Equ patterns result')
- where ((ctr,_), result') = alphaConvert env result
diff --git a/src/GF/Compile/GenerateFCFG.hs b/src/GF/Compile/GenerateFCFG.hs
deleted file mode 100644
index 52e95f686..000000000
--- a/src/GF/Compile/GenerateFCFG.hs
+++ /dev/null
@@ -1,568 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Maintainer : Krasimir Angelov
--- Stability : (stable)
--- Portability : (portable)
---
--- Converting SimpleGFC grammars to fast nonerasing MCFG grammar.
---
--- the resulting grammars might be /very large/
---
--- the conversion is only equivalent if the GFC grammar has a context-free backbone.
------------------------------------------------------------------------------
-
-
-module GF.Compile.GenerateFCFG
- (convertConcrete) where
-
-import PGF.CId
-import PGF.Data
-import PGF.Macros --hiding (prt)
-import PGF.Parsing.FCFG.Utilities
-
-import GF.Data.BacktrackM
-import GF.Data.SortedList
-import GF.Data.Utilities (updateNthM, sortNub)
-
-import qualified Data.Map as Map
-import qualified Data.IntMap as IntMap
-import qualified Data.Set as Set
-import qualified Data.List as List
-import qualified Data.ByteString.Char8 as BS
-import Data.Array.IArray
-import Data.Maybe
-import Control.Monad
-
-----------------------------------------------------------------------
--- main conversion function
-
-convertConcrete :: Abstr -> Concr -> ParserInfo
-convertConcrete abs cnc = fixHoasFuns $ convert abs_defs' conc' cats'
- where abs_defs = Map.assocs (funs abs)
- conc = Map.union (opers cnc) (lins cnc) -- "union big+small most efficient"
- cats = lincats cnc
- (abs_defs',conc',cats') = expandHOAS abs_defs conc cats
-
-expandHOAS :: [(CId,(Type,Int,[Equation]))] -> TermMap -> TermMap -> ([(CId,(Type,Int,[Equation]))],TermMap,TermMap)
-expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns,
- Map.unions [lins, hoLins, varLins],
- Map.unions [lincats, hoLincats, varLincat])
- where
- -- replace higher-order fun argument types with new categories
- funs' = [(f,(fixType ty,a,e)) | (f,(ty,a,e)) <- funs]
- where
- fixType :: Type -> Type
- fixType ty = let (ats,rt) = typeSkeleton ty in cftype (map catName ats) rt
-
- hoTypes :: [(Int,CId)]
- hoTypes = sortNub [(n,c) | (_,(ty,_,_)) <- funs, (n,c) <- fst (typeSkeleton ty), n > 0]
- hoCats = sortNub (map snd hoTypes)
- -- for each Cat with N bindings, we add a new category _NCat
- -- each new category contains a single function __NCat : Cat -> _Var -> ... -> _Var -> _NCat
- hoFuns = [(funName ty,(cftype (c : replicate n varCat) (catName ty),0,[])) | ty@(n,c) <- hoTypes]
- -- lincats for the new categories
- hoLincats = Map.fromList [(catName ty, modifyRec (++ replicate n (S [])) (lincatOf c)) | ty@(n,c) <- hoTypes]
- -- linearizations of the new functions, lin __NCat v_0 ... v_n-1 x = { s1 = x.s1; ...; sk = x.sk; $0 = v_0.s ...
- hoLins = Map.fromList [ (funName ty, mkLin c n) | ty@(n,c) <- hoTypes]
- where mkLin c n = modifyRec (\fs -> [P (V 0) (C j) | j <- [0..length fs-1]] ++ [P (V i) (C 0) | i <- [1..n]]) (lincatOf c)
- -- for each Cat, we a add a fun _Var_Cat : _Var -> Cat
- varFuns = [(varFunName cat, (cftype [varCat] cat,0,[])) | cat <- hoCats]
- -- linearizations of the _Var_Cat functions
- varLins = Map.fromList [(varFunName cat, R [P (V 0) (C 0)]) | cat <- hoCats]
- -- lincat for the _Var category
- varLincat = Map.singleton varCat (R [S []])
-
- lincatOf c = fromMaybe (error $ "No lincat for " ++ showCId c) $ Map.lookup c lincats
-
- modifyRec :: ([Term] -> [Term]) -> Term -> Term
- modifyRec f (R xs) = R (f xs)
- modifyRec _ t = error $ "Not a record: " ++ show t
-
- varCat = mkCId "_Var"
-
- catName :: (Int,CId) -> CId
- catName (0,c) = c
- catName (n,c) = mkCId ("_" ++ show n ++ showCId c)
-
- funName :: (Int,CId) -> CId
- funName (n,c) = mkCId ("__" ++ show n ++ showCId c)
-
- varFunName :: CId -> CId
- varFunName c = mkCId ("_Var_" ++ showCId c)
-
--- replaces __NCat with _B and _Var_Cat with _.
--- the temporary names are just there to avoid name collisions.
-fixHoasFuns :: ParserInfo -> ParserInfo
-fixHoasFuns pinfo = pinfo{functions=mkArray [FFun (fixName n) prof lins | FFun n prof lins <- elems (functions pinfo)]}
- where fixName (CId n) | BS.pack "__" `BS.isPrefixOf` n = (mkCId "_B")
- | BS.pack "_Var_" `BS.isPrefixOf` n = wildCId
- fixName n = n
-
-convert :: [(CId,(Type,Int,[Equation]))] -> TermMap -> TermMap -> ParserInfo
-convert abs_defs cnc_defs cat_defs = getParserInfo (loop grammarEnv)
- where
- srules = [
- (XRule id args res (map findLinType args) (findLinType res) term) |
- (id, (ty,_,_)) <- abs_defs, let (args,res) = catSkeleton ty,
- term <- maybeToList (Map.lookup id cnc_defs)]
-
- findLinType id = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs)
-
- (xrulesMap,grammarEnv) = List.foldl' helper (Map.empty,emptyFFunsEnv) srules
- where
- helper (xrulesMap,grammarEnv) rule@(XRule id abs_args abs_res cnc_args cnc_res term) =
- let xrulesMap' = Map.insertWith (++) abs_res [rule] xrulesMap
- grammarEnv' = List.foldl' (\env selector -> convertRule cnc_defs selector rule env)
- grammarEnv
- (mkSingletonSelectors cnc_defs cnc_res)
- in xrulesMap' `seq` grammarEnv' `seq` (xrulesMap',grammarEnv')
-
- loop grammarEnv =
- let (todo, grammarEnv') = takeToDoRules xrulesMap grammarEnv
- in case todo of
- [] -> grammarEnv'
- _ -> loop $! List.foldl' (\env (srules,selector) ->
- List.foldl' (\env srule -> convertRule cnc_defs selector srule env) env srules) grammarEnv' todo
-
-convertRule :: TermMap -> TermSelector -> XRule -> GrammarEnv -> GrammarEnv
-convertRule cnc_defs selector (XRule fun args cat ctypes ctype term) grammarEnv =
- foldBM addRule
- grammarEnv
- (convertTerm cnc_defs selector term [([],[])])
- (protoFCat cat, map (\scat -> (protoFCat scat,[])) args, ctype, ctypes)
- where
- addRule linRec (newCat', newArgs', _, _) env0 =
- let (env1, newCat) = genFCatHead env0 newCat'
- (env2, newArgs,idxArgs) = foldr (\((xcat@(PFCat cat rcs tcs),xpaths),ctype,idx) (env,args,all_args) ->
- let xargs = xcat:[PFCat cat [path] tcs | path <- reverse xpaths]
- (env1, xargs1) = List.mapAccumL (genFCatArg cnc_defs ctype) env xargs
- in case xcat of
- PFCat _ [] _ -> (env , args, all_args)
- _ -> (env1,xargs1++args,(idx,zip xargs1 xargs):all_args))
- (env1,[],[]) (zip3 newArgs' ctypes [0..])
-
- (env3,newLinRec) = List.mapAccumL (translateLin idxArgs linRec) env2 (case newCat' of {PFCat _ rcs _ -> rcs})
-
- (_,newProfile) = List.mapAccumL accumProf 0 newArgs'
- where
- accumProf nr (PFCat _ [] _,_ ) = (nr, [] )
- accumProf nr (_ ,xpaths) = (nr+cnt+1, [nr..nr+cnt])
- where cnt = length xpaths
-
- (env4,funid) = addFFun env3 (FFun fun newProfile (mkArray newLinRec))
-
- in addProduction env4 newCat (FApply funid newArgs)
-
-translateLin idxArgs [] grammarEnv lbl' = error "translateLin"
-translateLin idxArgs ((lbl,syms) : lins) grammarEnv lbl'
- | lbl' == lbl = addFSeq grammarEnv (lbl,map instSym syms)
- | otherwise = translateLin idxArgs lins grammarEnv lbl'
- where
- instSym = either (\(lbl, nr, xnr) -> instCat lbl nr xnr 0 idxArgs)
- (\t -> case t of
- KS s -> FSymKS [s]
- KP strs vars -> FSymKP strs vars)
- instCat lbl nr xnr nr' ((idx,xargs):idxArgs)
- | nr == idx = let (fcat, PFCat _ rcs _) = xargs !! xnr
- in FSymCat (nr'+xnr) (index lbl rcs 0)
- | otherwise = instCat lbl nr xnr (nr'+length xargs) idxArgs
-
- index lbl' (lbl:lbls) idx
- | lbl' == lbl = idx
- | otherwise = index lbl' lbls $! (idx+1)
-
-
-----------------------------------------------------------------------
--- term conversion
-
-type CnvMonad a = BacktrackM Env a
-
-type FPath = [FIndex]
-type Env = (ProtoFCat, [(ProtoFCat,[FPath])], Term, [Term])
-type LinRec = [(FPath, [Either (FPath, FIndex, Int) Tokn])]
-
-type TermMap = Map.Map CId Term
-
-convertTerm :: TermMap -> TermSelector -> Term -> LinRec -> CnvMonad LinRec
-convertTerm cnc_defs selector (V nr) ((lbl_path,lin) : lins) = convertArg selector nr [] lbl_path lin lins
-convertTerm cnc_defs selector (C nr) ((lbl_path,lin) : lins) = convertCon selector nr lbl_path lin lins
-convertTerm cnc_defs selector (R record) ((lbl_path,lin) : lins) = convertRec cnc_defs selector 0 record lbl_path lin lins
-
-convertTerm cnc_defs selector (P term sel) lins = do nr <- evalTerm cnc_defs [] sel
- convertTerm cnc_defs (TuplePrj nr selector) term lins
-convertTerm cnc_defs selector (FV vars) lins = do term <- member vars
- convertTerm cnc_defs selector term lins
-convertTerm cnc_defs selector (S ts) ((lbl_path,lin) : lins) = do projectHead lbl_path
- foldM (\lins t -> convertTerm cnc_defs selector t lins) ((lbl_path,lin) : lins) (reverse ts)
-convertTerm cnc_defs selector (K (KS str)) ((lbl_path,lin) : lins) =
- do projectHead lbl_path
- return ((lbl_path,Right (KS str) : lin) : lins)
-convertTerm cnc_defs selector (K (KP strs vars))((lbl_path,lin) : lins) =
- do projectHead lbl_path
- toks <- member (strs:[strs' | Alt strs' _ <- vars])
- return ((lbl_path, map (Right . KS) toks ++ lin) : lins)
-convertTerm cnc_defs selector (F id) lins = case Map.lookup id cnc_defs of
- Just term -> convertTerm cnc_defs selector term lins
- Nothing -> mzero
-convertTerm cnc_defs selector (W s t) ((lbl_path,lin) : lins) = do
- ss <- case t of
- R ss -> return ss
- F f -> case Map.lookup f cnc_defs of
- Just (R ss) -> return ss
- _ -> mzero
- convertRec cnc_defs selector 0 [K (KS (s ++ s1)) | K (KS s1) <- ss] lbl_path lin lins
-convertTerm cnc_defs selector x lins = error ("convertTerm ("++show x++")")
-
-
-convertArg (TupleSel record) nr path lbl_path lin lins =
- foldM (\lins (lbl, selector) -> convertArg selector nr (lbl:path) (lbl:lbl_path) lin lins) lins record
-convertArg (TuplePrj lbl selector) nr path lbl_path lin lins =
- convertArg selector nr (lbl:path) lbl_path lin lins
-convertArg (ConSel indices) nr path lbl_path lin lins = do
- index <- member indices
- restrictHead lbl_path index
- restrictArg nr path index
- return lins
-convertArg StrSel nr path lbl_path lin lins = do
- projectHead lbl_path
- xnr <- projectArg nr path
- return ((lbl_path, Left (path, nr, xnr) : lin) : lins)
-
-convertCon (ConSel indices) index lbl_path lin lins = do
- guard (index `elem` indices)
- restrictHead lbl_path index
- return lins
-convertCon x _ _ _ _ = error $ "SimpleToFCFG,convertCon: " ++ show x
-
-convertRec cnc_defs selector index [] lbl_path lin lins = return lins
-convertRec cnc_defs selector@(TupleSel fields) index (val:record) lbl_path lin lins = select fields
- where
- select [] = convertRec cnc_defs selector (index+1) record lbl_path lin lins
- select ((index',sub_sel) : fields)
- | index == index' = do lins <- convertTerm cnc_defs sub_sel val ((index:lbl_path,lin) : lins)
- convertRec cnc_defs selector (index+1) record lbl_path lin lins
- | otherwise = select fields
-convertRec cnc_defs (TuplePrj index' sub_sel) index record lbl_path lin lins = do
- convertTerm cnc_defs sub_sel (record !! (index'-index)) ((lbl_path,lin) : lins)
-
-
-------------------------------------------------------------
--- eval a term to ground terms
-
-evalTerm :: TermMap -> FPath -> Term -> CnvMonad FIndex
-evalTerm cnc_defs path (V nr) = do term <- readArgCType nr
- unifyPType nr (reverse path) (selectTerm path term)
-evalTerm cnc_defs path (C nr) = return nr
-evalTerm cnc_defs path (R record) = case path of
- (index:path) -> evalTerm cnc_defs path (record !! index)
-evalTerm cnc_defs path (P term sel) = do index <- evalTerm cnc_defs [] sel
- evalTerm cnc_defs (index:path) term
-evalTerm cnc_defs path (FV terms) = member terms >>= evalTerm cnc_defs path
-evalTerm cnc_defs path (F id) = case Map.lookup id cnc_defs of
- Just term -> evalTerm cnc_defs path term
- Nothing -> mzero
-evalTerm cnc_defs path x = error ("evalTerm ("++show x++")")
-
-unifyPType :: FIndex -> FPath -> Term -> CnvMonad FIndex
-unifyPType nr path (C max_index) =
- do (_, args, _, _) <- get
- let (PFCat _ _ tcs,_) = args !! nr
- case lookup path tcs of
- Just index -> return index
- Nothing -> do index <- member [0..max_index]
- restrictArg nr path index
- return index
-unifyPType nr path t = error $ "unifyPType " ++ show t ---- AR 2/10/2007
-
-selectTerm :: FPath -> Term -> Term
-selectTerm [] term = term
-selectTerm (index:path) (R record) = selectTerm path (record !! index)
-
-
-----------------------------------------------------------------------
--- GrammarEnv
-
-
-data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int FCatSet FSeqSet FFunSet (IntMap.IntMap (Set.Set Production))
-type FCatSet = Map.Map CId (Map.Map [FPath] (Map.Map [(FPath,FIndex)] (Either FCat FCat)))
-type FSeqSet = Map.Map FSeq SeqId
-type FFunSet = Map.Map FFun FunId
-
-data ProtoFCat = PFCat CId [FPath] [(FPath,FIndex)]
-
-protoFCat :: CId -> ProtoFCat
-protoFCat cat = PFCat cat [] []
-
-emptyFFunsEnv = GrammarEnv 0 initFCatSet Map.empty Map.empty IntMap.empty
- where
- initFCatSet = (ins fcatString (mkCId "String") [[0]] [] $
- ins fcatInt (mkCId "Int") [[0]] [] $
- ins fcatFloat (mkCId "Float") [[0]] [] $
- ins fcatVar (mkCId "_Var") [[0]] [] $
- Map.empty)
-
- ins fcat cat rcs tcs catSet =
- Map.insertWith (\_ -> Map.insertWith (\_ -> Map.insert tcs right_fcat) rcs tmap_s) cat rmap_s catSet
- where
- right_fcat = Right fcat
- tmap_s = Map.singleton tcs right_fcat
- rmap_s = Map.singleton rcs tmap_s
-
-addProduction :: GrammarEnv -> FCat -> Production -> GrammarEnv
-addProduction (GrammarEnv last_id catSet seqSet funSet prodSet) cat p =
- GrammarEnv last_id catSet seqSet funSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet)
-
-addFSeq :: GrammarEnv -> (FPath,[FSymbol]) -> (GrammarEnv,SeqId)
-addFSeq env@(GrammarEnv last_id catSet seqSet funSet prodSet) (_,lst) =
- case Map.lookup seq seqSet of
- Just id -> (env,id)
- Nothing -> let !last_seq = Map.size seqSet
- in (GrammarEnv last_id catSet (Map.insert seq last_seq seqSet) funSet prodSet,last_seq)
- where
- seq = mkArray lst
-
-addFFun :: GrammarEnv -> FFun -> (GrammarEnv,FunId)
-addFFun env@(GrammarEnv last_id catSet seqSet funSet prodSet) fun =
- case Map.lookup fun funSet of
- Just id -> (env,id)
- Nothing -> let !last_funid = Map.size funSet
- in (GrammarEnv last_id catSet seqSet (Map.insert fun last_funid funSet) prodSet,last_funid)
-
-getParserInfo :: GrammarEnv -> ParserInfo
-getParserInfo (GrammarEnv last_id catSet seqSet funSet prodSet) =
- ParserInfo { functions = mkArray funSet
- , sequences = mkArray seqSet
- , productions0= prodSet
- , productions = prodSet
- , startCats = Map.map getFCatList catSet
- , totalCats = last_id+1
- }
- where
- mkArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
-
- getFCatList rcs = Map.fold (\tcs lst -> Map.fold (\x lst -> either id id x : lst) lst tcs) [] rcs
-
-
-genFCatHead :: GrammarEnv -> ProtoFCat -> (GrammarEnv, FCat)
-genFCatHead env@(GrammarEnv last_id catSet seqSet funSet prodSet) (PFCat cat rcs tcs) =
- case Map.lookup cat catSet >>= Map.lookup rcs >>= Map.lookup tcs of
- Just (Left fcat) -> (GrammarEnv last_id (ins fcat) seqSet funSet prodSet, fcat)
- Just (Right fcat) -> (env, fcat)
- Nothing -> let fcat = last_id+1
- in (GrammarEnv fcat (ins fcat) seqSet funSet prodSet, fcat)
- where
- ins fcat = Map.insertWith (\_ -> Map.insertWith (\_ -> Map.insert tcs right_fcat) rcs tmap_s) cat rmap_s catSet
- where
- right_fcat = Right fcat
- tmap_s = Map.singleton tcs right_fcat
- rmap_s = Map.singleton rcs tmap_s
-
-genFCatArg :: TermMap -> Term -> GrammarEnv -> ProtoFCat -> (GrammarEnv, FCat)
-genFCatArg cnc_defs ctype env@(GrammarEnv last_id catSet seqSet funSet prodSet) (PFCat cat rcs tcs) =
- case Map.lookup cat catSet >>= Map.lookup rcs of
- Just tmap -> case Map.lookup tcs tmap of
- Just (Left fcat) -> (env, fcat)
- Just (Right fcat) -> (env, fcat)
- Nothing -> ins tmap
- Nothing -> ins Map.empty
- where
- ins tmap =
- let fcat = last_id+1
- (either_fcat,last_id1,tmap1,prodSet1)
- = foldBM (\tcs st (either_fcat,last_id,tmap,prodSet) ->
- let (last_id1,tmap1,fcat_arg) = addArg tcs last_id tmap
- p = FCoerce fcat_arg
- prodSet1 = IntMap.insertWith Set.union fcat (Set.singleton p) prodSet
- in if st
- then (Right fcat, last_id1,tmap1,prodSet1)
- else (either_fcat,last_id, tmap ,prodSet ))
- (Left fcat,fcat,Map.insert tcs either_fcat tmap,prodSet)
- (gen_tcs ctype [] [])
- False
- rmap1 = Map.singleton rcs tmap1
- in (GrammarEnv last_id1 (Map.insertWith (\_ -> Map.insert rcs tmap1) cat rmap1 catSet) seqSet funSet prodSet1, fcat)
- where
- addArg tcs last_id tmap =
- case Map.lookup tcs tmap of
- Just (Left fcat) -> (last_id, tmap, fcat)
- Just (Right fcat) -> (last_id, tmap, fcat)
- Nothing -> let fcat = last_id+1
- in (fcat, Map.insert tcs (Left fcat) tmap, fcat)
-
- gen_tcs :: Term -> FPath -> [(FPath,FIndex)] -> BacktrackM Bool [(FPath,FIndex)]
- gen_tcs (R record) path acc = foldM (\acc (label,ctype) -> gen_tcs ctype (label:path) acc) acc (zip [0..] record)
- gen_tcs (S _) path acc = return acc
- gen_tcs (C max_index) path acc =
- case List.lookup path tcs of
- Just index -> return $! addConstraint path index acc
- Nothing -> do put True
- index <- member [0..max_index]
- return $! addConstraint path index acc
- where
- addConstraint path0 index0 (c@(path,index) : cs)
- | path0 > path = c:addConstraint path0 index0 cs
- addConstraint path0 index0 cs = (path0,index0) : cs
- gen_tcs (F id) path acc = case Map.lookup id cnc_defs of
- Just term -> gen_tcs term path acc
- Nothing -> error ("unknown identifier: "++showCId id)
-
-
-
-------------------------------------------------------------
--- TODO queue organization
-
-type XRulesMap = Map.Map CId [XRule]
-data XRule = XRule CId {- function -}
- [CId] {- argument types -}
- CId {- result type -}
- [Term] {- argument lin-types representation -}
- Term {- result lin-type representation -}
- Term {- body -}
-
-takeToDoRules :: XRulesMap -> GrammarEnv -> ([([XRule], TermSelector)], GrammarEnv)
-takeToDoRules xrulesMap (GrammarEnv last_id catSet seqSet funSet prodSet) =
- (todo,GrammarEnv last_id catSet' seqSet funSet prodSet)
- where
- (todo,catSet') =
- Map.mapAccumWithKey (\todo cat rmap ->
- let (todo1,rmap1) = Map.mapAccumWithKey (\todo rcs tmap ->
- let (tcss,tmap') = Map.mapAccumWithKey (\tcss tcs either_xcat ->
- case either_xcat of
- Left xcat -> (tcs:tcss,Right xcat)
- Right xcat -> ( tcss,either_xcat)) [] tmap
- in case tcss of
- [] -> ( todo,tmap )
- _ -> ((srules,mkSelector rcs tcss) : todo,tmap')) todo rmap
- mb_srules = Map.lookup cat xrulesMap
- Just srules = mb_srules
-
- in case mb_srules of
- Just srules -> (todo1,rmap1)
- Nothing -> (todo ,rmap1)) [] catSet
-
-
-------------------------------------------------------------
--- The TermSelector
-
-data TermSelector
- = TupleSel [(FIndex, TermSelector)]
- | TuplePrj FIndex TermSelector
- | ConSel [FIndex]
- | StrSel
- deriving Show
-
-mkSingletonSelectors :: TermMap
- -> Term -- ^ Type representation term
- -> [TermSelector] -- ^ list of selectors containing just one string field
-mkSingletonSelectors cnc_defs term = sels0
- where
- (sels0,tcss0) = loop [] ([],[]) term
-
- loop path st (R record) = List.foldl' (\st (index,term) -> loop (index:path) st term) st (zip [0..] record)
- loop path (sels,tcss) (C i) = ( sels,map ((,) path) [0..i] : tcss)
- loop path (sels,tcss) (S _) = (mkSelector [path] tcss0 : sels, tcss)
- loop path (sels,tcss) (F id) = case Map.lookup id cnc_defs of
- Just term -> loop path (sels,tcss) term
- Nothing -> error ("unknown identifier: "++showCId id)
-
-mkSelector :: [FPath] -> [[(FPath,FIndex)]] -> TermSelector
-mkSelector rcs tcss =
- List.foldl' addRestriction (case xs of
- (path:xs) -> List.foldl' addProjection (path2selector StrSel path) xs) ys
- where
- xs = [ reverse path | path <- rcs]
- ys = [(reverse path,term) | tcs <- tcss, (path,term) <- tcs]
-
- addRestriction :: TermSelector -> (FPath,FIndex) -> TermSelector
- addRestriction (ConSel indices) ([] ,n_index) = ConSel (add indices)
- where
- add [] = [n_index]
- add (index':indices)
- | n_index == index' = index': indices
- | otherwise = index':add indices
- addRestriction (TupleSel fields) (index : path,n_index) = TupleSel (add fields)
- where
- add [] = [(index,path2selector (ConSel [n_index]) path)]
- add (field@(index',sub_sel):fields)
- | index == index' = (index',addRestriction sub_sel (path,n_index)):fields
- | otherwise = field : add fields
-
- addProjection :: TermSelector -> FPath -> TermSelector
- addProjection StrSel [] = StrSel
- addProjection (TupleSel fields) (index : path) = TupleSel (add fields)
- where
- add [] = [(index,path2selector StrSel path)]
- add (field@(index',sub_sel):fields)
- | index == index' = (index',addProjection sub_sel path):fields
- | otherwise = field : add fields
-
- path2selector base [] = base
- path2selector base (index : path) = TupleSel [(index,path2selector base path)]
-
-------------------------------------------------------------
--- updating the MCF rule
-
-readArgCType :: FIndex -> CnvMonad Term
-readArgCType nr = do (_, _, _, ctypes) <- get
- return (ctypes !! nr)
-
-restrictArg :: FIndex -> FPath -> FIndex -> CnvMonad ()
-restrictArg nr path index = do
- (head, args, ctype, ctypes) <- get
- args' <- updateNthM (\(xcat,xs) -> do xcat <- restrictProtoFCat path index xcat
- return (xcat,xs) ) nr args
- put (head, args', ctype, ctypes)
-
-projectArg :: FIndex -> FPath -> CnvMonad Int
-projectArg nr path = do
- (head, args, ctype, ctypes) <- get
- (xnr,args') <- updateArgs nr args
- put (head, args', ctype, ctypes)
- return xnr
- where
- updateArgs :: FIndex -> [(ProtoFCat,[FPath])] -> CnvMonad (Int,[(ProtoFCat,[FPath])])
- updateArgs 0 ((a@(PFCat _ rcs _),xpaths) : as)
- | path `elem` rcs = return (length xpaths+1,(a,path:xpaths):as)
- | otherwise = do a <- projectProtoFCat path a
- return (0,(a,xpaths):as)
- updateArgs n (a : as) = do
- (xnr,as) <- updateArgs (n-1) as
- return (xnr,a:as)
-
-readHeadCType :: CnvMonad Term
-readHeadCType = do (_, _, ctype, _) <- get
- return ctype
-
-restrictHead :: FPath -> FIndex -> CnvMonad ()
-restrictHead path term
- = do (head, args, ctype, ctypes) <- get
- head' <- restrictProtoFCat path term head
- put (head', args, ctype, ctypes)
-
-projectHead :: FPath -> CnvMonad ()
-projectHead path
- = do (head, args, ctype, ctypes) <- get
- head' <- projectProtoFCat path head
- put (head', args, ctype, ctypes)
-
-restrictProtoFCat :: FPath -> FIndex -> ProtoFCat -> CnvMonad ProtoFCat
-restrictProtoFCat path0 index0 (PFCat cat rcs tcs) = do
- tcs <- addConstraint tcs
- return (PFCat cat rcs tcs)
- where
- addConstraint (c@(path,index) : cs)
- | path0 > path = liftM (c:) (addConstraint cs)
- | path0 == path = guard (index0 == index) >>
- return (c : cs)
- addConstraint cs = return ((path0,index0) : cs)
-
-projectProtoFCat :: FPath -> ProtoFCat -> CnvMonad ProtoFCat
-projectProtoFCat path0 (PFCat cat rcs tcs) = do
- return (PFCat cat (addConstraint rcs) tcs)
- where
- addConstraint (path : rcs)
- | path0 > path = path : addConstraint rcs
- | path0 == path = path : rcs
- addConstraint rcs = path0 : rcs
-
-mkArray lst = listArray (0,length lst-1) lst
diff --git a/src/GF/Compile/GeneratePMCFG.hs b/src/GF/Compile/GeneratePMCFG.hs
deleted file mode 100644
index 458cf3f5c..000000000
--- a/src/GF/Compile/GeneratePMCFG.hs
+++ /dev/null
@@ -1,510 +0,0 @@
-{-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses #-}
-----------------------------------------------------------------------
--- |
--- Maintainer : Krasimir Angelov
--- Stability : (stable)
--- Portability : (portable)
---
--- Convert PGF grammar to PMCFG grammar.
---
------------------------------------------------------------------------------
-
-module GF.Compile.GeneratePMCFG
- (convertConcrete) where
-
-import PGF.CId
-import PGF.Data
-import PGF.Macros
-
-import GF.Infra.Option
-import GF.Data.BacktrackM
-import GF.Data.Utilities (updateNthM, updateNth, sortNub)
-
-import System.IO
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import qualified Data.List as List
-import qualified Data.IntMap as IntMap
-import qualified Data.ByteString.Char8 as BS
-import Data.Array.IArray
-import Data.Maybe
-import Control.Monad
-import Control.Exception
-
-----------------------------------------------------------------------
--- main conversion function
-
-
-convertConcrete :: Options -> Abstr -> CId -> Concr -> IO ParserInfo
-convertConcrete opts abs lang cnc = do
- let env0 = emptyGrammarEnv cnc_defs cat_defs
- when (flag optProf opts) $ do
- profileGrammar lang cnc_defs env0 pfrules
- let env1 = expandHOAS abs_defs cnc_defs cat_defs lin_defs env0
- env2 = List.foldl' (convertRule cnc_defs) env1 pfrules
- return $ getParserInfo env2
- where
- abs_defs = Map.assocs (funs abs)
- cnc_defs = Map.union (opers cnc) (lins cnc) -- "union big+small most efficient"
- cat_defs = Map.insert cidVar (S []) (lincats cnc)
- lin_defs = lindefs cnc
-
- pfrules = [
- (PFRule id args (0,res) (map findLinType args) (findLinType (0,res)) term) |
- (id, (ty,_,_)) <- abs_defs, let (args,res) = typeSkeleton ty,
- term <- maybeToList (Map.lookup id cnc_defs)]
-
- findLinType (_,id) = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs)
-
-profileGrammar lang cnc_defs (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) pfrules = do
- hPutStrLn stderr ""
- hPutStrLn stderr ("Language: " ++ show lang)
- hPutStrLn stderr ""
- hPutStrLn stderr "Categories Count"
- hPutStrLn stderr "--------------------------------"
- case IntMap.lookup 0 catSet of
- Just cats -> mapM_ profileCat (Map.toList cats)
- Nothing -> return ()
- hPutStrLn stderr "--------------------------------"
- hPutStrLn stderr ""
- hPutStrLn stderr "Rules Count"
- hPutStrLn stderr "--------------------------------"
- mapM_ profileRule pfrules
- hPutStrLn stderr "--------------------------------"
- where
- profileCat (cid,(fcat1,fcat2,_)) = do
- hPutStrLn stderr (lformat 23 cid ++ rformat 9 (fcat2-fcat1+1))
-
- profileRule (PFRule fun args res ctypes ctype term) = do
- let pargs = zipWith (protoFCat cnc_defs) args ctypes
- hPutStrLn stderr (lformat 23 fun ++ rformat 9 (product [length xs | PFCat _ _ _ tcs <- pargs, (_,xs) <- tcs]))
-
- lformat :: Show a => Int -> a -> String
- lformat n x = s ++ replicate (n-length s) ' '
- where
- s = show x
-
- rformat :: Show a => Int -> a -> String
- rformat n x = replicate (n-length s) ' ' ++ s
- where
- s = show x
-
-brk :: (GrammarEnv -> GrammarEnv) -> (GrammarEnv -> GrammarEnv)
-brk f (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) =
- case f (GrammarEnv last_id catSet seqSet funSet crcSet IntMap.empty) of
- (GrammarEnv last_id catSet seqSet funSet crcSet topdown1) -> IntMap.foldWithKey optimize (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) topdown1
- where
- optimize cat ps env = IntMap.foldWithKey ff env (IntMap.fromListWith (++) [(funid,[args]) | FApply funid args <- Set.toList ps])
- where
- ff :: FunId -> [[FCat]] -> GrammarEnv -> GrammarEnv
- ff funid xs env
- | product (map Set.size ys) == count =
- case List.mapAccumL (\env c -> addFCoercion env (Set.toList c)) env ys of
- (env,args) -> addProduction env cat (FApply funid args)
- | otherwise = List.foldl (\env args -> addProduction env cat (FApply funid args)) env xs
- where
- count = length xs
- ys = foldr (zipWith Set.insert) (repeat Set.empty) xs
-
-convertRule :: TermMap -> GrammarEnv -> ProtoFRule -> GrammarEnv
-convertRule cnc_defs grammarEnv (PFRule fun args res ctypes ctype term) =
- let pres = protoFCat cnc_defs res ctype
- pargs = zipWith (protoFCat cnc_defs) args ctypes
-
- b = runBranchM (convertTerm cnc_defs [] ctype term) (pargs,[])
- (grammarEnv1,b1) = addSequences' grammarEnv b
- grammarEnv2 = brk (\grammarEnv -> foldBM addRule
- grammarEnv
- (go' b1 [] [])
- (pres,pargs) ) grammarEnv1
- in grammarEnv2
- where
- addRule lins (newCat', newArgs') env0 =
- let [newCat] = getFCats env0 newCat'
- (env1, newArgs) = List.mapAccumL (\env -> addFCoercion env . getFCats env) env0 newArgs'
-
- (env2,funid) = addFFun env1 (FFun fun [[n] | n <- [0..length newArgs-1]] (mkArray lins))
-
- in addProduction env2 newCat (FApply funid newArgs)
-
-----------------------------------------------------------------------
--- Branch monad
-
-newtype BranchM a = BM (forall b . (a -> ([ProtoFCat],[FSymbol]) -> Branch b) -> ([ProtoFCat],[FSymbol]) -> Branch b)
-
-instance Monad BranchM where
- return a = BM (\c s -> c a s)
- BM m >>= k = BM (\c s -> m (\a s -> unBM (k a) c s) s)
- where unBM (BM m) = m
-
-instance MonadState ([ProtoFCat],[FSymbol]) BranchM where
- get = BM (\c s -> c s s)
- put s = BM (\c _ -> c () s)
-
-instance Functor BranchM where
- fmap f (BM m) = BM (\c s -> m (c . f) s)
-
-runBranchM :: BranchM (Value a) -> ([ProtoFCat],[FSymbol]) -> Branch a
-runBranchM (BM m) s = m (\v s -> Return v) s
-
-variants :: [a] -> BranchM a
-variants xs = BM (\c s -> Variant (go xs c s))
- where
- go [] c s = []
- go (x:xs) c s = c x s : go xs c s
-
-choices :: Int -> FPath -> BranchM FIndex
-choices nr path = BM (\c s -> let (args,_) = s
- PFCat _ _ _ tcs = args !! nr
- in case fromMaybe (error "evalTerm: wrong path") (lookup path tcs) of
- [index] -> c index s
- indices -> Case nr path (go indices c s))
- where
- go [] c s = []
- go (i:is) c s = (c i (updateEnv i s)) : go is c s
-
- updateEnv index (args,seq) = (updateNth (restrictArg path index) nr args,seq)
-
- restrictArg path index (PFCat n cat rcs tcs) = PFCat n cat rcs (addConstraint path index tcs)
-
- addConstraint path0 index0 [] = error "restrictProtoFCat: unknown path"
- addConstraint path0 index0 (c@(path,indices) : tcs)
- | path0 == path = ((path,[index0]) : tcs)
- | otherwise = c : addConstraint path0 index0 tcs
-
-mkRecord :: [BranchM (Value a)] -> BranchM (Value a)
-mkRecord xs = BM (\c -> go xs (c . Rec))
- where
- go [] c s = c [] s
- go (BM m:fs) c s = go fs (\bs s -> c (m (\v s -> Return v) s : bs) s) s
-
--- cutBranch :: BranchM (Value a) -> BranchM (Branch a)
--- cutBranch (BM m) = BM (\c e -> c (m (\v e -> Return v) e) e)
-
-
-----------------------------------------------------------------------
--- term conversion
-
-type CnvMonad a = BranchM a
-
-type FPath = [FIndex]
-data ProtoFCat = PFCat Int CId [FPath] [(FPath,[FIndex])]
-type Env = (ProtoFCat, [ProtoFCat])
-data ProtoFRule = PFRule CId {- function -}
- [(Int,CId)] {- argument types: context size and category -}
- (Int,CId) {- result type : context size (always 0) and category -}
- [Term] {- argument lin-types representation -}
- Term {- result lin-type representation -}
- Term {- body -}
-type TermMap = Map.Map CId Term
-
-
-protoFCat :: TermMap -> (Int,CId) -> Term -> ProtoFCat
-protoFCat cnc_defs (n,cat) ctype =
- let (rcs,tcs) = loop [] [] [] ctype'
- in PFCat n cat rcs tcs
- where
- ctype' -- extend the high-order linearization type
- | n > 0 = case ctype of
- R xs -> R (xs ++ replicate n (S []))
- _ -> error $ "Not a record: " ++ show ctype
- | otherwise = ctype
-
- loop path rcs tcs (R record) = List.foldl' (\(rcs,tcs) (index,term) -> loop (index:path) rcs tcs term) (rcs,tcs) (zip [0..] record)
- loop path rcs tcs (C i) = ( rcs,(path,[0..i]):tcs)
- loop path rcs tcs (S _) = (path:rcs, tcs)
- loop path rcs tcs (F id) = case Map.lookup id cnc_defs of
- Just term -> loop path rcs tcs term
- Nothing -> error ("unknown identifier: "++show id)
-
-data Branch a
- = Case Int FPath [Branch a]
- | Variant [Branch a]
- | Return (Value a)
-
-data Value a
- = Rec [Branch a]
- | Str a
- | Con FIndex
-
-
-go' :: Branch SeqId -> FPath -> [SeqId] -> BacktrackM Env [SeqId]
-go' (Case nr path_ bs) path ss = do (index,b) <- member (zip [0..] bs)
- restrictArg nr path_ index
- go' b path ss
-go' (Variant bs) path ss = do b <- member bs
- go' b path ss
-go' (Return v) path ss = go v path ss
-
-go :: Value SeqId -> FPath -> [SeqId] -> BacktrackM Env [SeqId]
-go (Rec xs) path ss = foldM (\ss (lbl,b) -> go' b (lbl:path) ss) ss (zip [0..] xs)
-go (Str seqid) path ss = return (seqid : ss)
-go (Con i) path ss = restrictHead path i >> return ss
-
-addSequences' :: GrammarEnv -> Branch [FSymbol] -> (GrammarEnv, Branch SeqId)
-addSequences' env (Case nr path bs) = let (env1,bs1) = List.mapAccumL addSequences' env bs
- in (env1,Case nr path bs1)
-addSequences' env (Variant bs) = let (env1,bs1) = List.mapAccumL addSequences' env bs
- in (env1,Variant bs1)
-addSequences' env (Return v) = let (env1,v1) = addSequences env v
- in (env1,Return v1)
-
-addSequences :: GrammarEnv -> Value [FSymbol] -> (GrammarEnv, Value SeqId)
-addSequences env (Rec vs) = let (env1,vs1) = List.mapAccumL addSequences' env vs
- in (env1,Rec vs1)
-addSequences env (Str lin) = let (env1,seqid) = addFSeq env (optimizeLin lin)
- in (env1,Str seqid)
-addSequences env (Con i) = (env,Con i)
-
-
-optimizeLin [] = []
-optimizeLin lin@(FSymKS _ : _) =
- let (ts,lin') = getRest lin
- in FSymKS ts : optimizeLin lin'
- where
- getRest (FSymKS ts : lin) = let (ts1,lin') = getRest lin
- in (ts++ts1,lin')
- getRest lin = ([],lin)
-optimizeLin (sym : lin) = sym : optimizeLin lin
-
-
-convertTerm :: TermMap -> FPath -> Term -> Term -> CnvMonad (Value [FSymbol])
-convertTerm cnc_defs sel ctype (V nr) = convertArg ctype nr (reverse sel)
-convertTerm cnc_defs sel ctype (C nr) = convertCon ctype nr (reverse sel)
-convertTerm cnc_defs sel ctype (R record) = convertRec cnc_defs sel ctype record
-convertTerm cnc_defs sel ctype (P term p) = do nr <- evalTerm cnc_defs [] p
- convertTerm cnc_defs (nr:sel) ctype term
-convertTerm cnc_defs sel ctype (FV vars) = do term <- variants vars
- convertTerm cnc_defs sel ctype term
-convertTerm cnc_defs sel ctype (S ts) = do vs <- mapM (convertTerm cnc_defs sel ctype) ts
- return (Str (concat [s | Str s <- vs]))
-convertTerm cnc_defs sel ctype (K (KS t)) = return (Str [FSymKS [t]])
-convertTerm cnc_defs sel ctype (K (KP s v))=return (Str [FSymKP s v])
-convertTerm cnc_defs sel ctype (F id) = case Map.lookup id cnc_defs of
- Just term -> convertTerm cnc_defs sel ctype term
- Nothing -> error ("unknown id " ++ showCId id)
-convertTerm cnc_defs sel ctype (W s t) = do
- ss <- case t of
- R ss -> return ss
- F f -> case Map.lookup f cnc_defs of
- Just (R ss) -> return ss
- _ -> error ("unknown id " ++ showCId f)
- convertRec cnc_defs sel ctype [K (KS (s ++ s1)) | K (KS s1) <- ss]
-convertTerm cnc_defs sel ctype x = error ("convertTerm ("++show x++")")
-
-convertArg :: Term -> Int -> FPath -> CnvMonad (Value [FSymbol])
-convertArg (R ctypes) nr path = do
- mkRecord (zipWith (\lbl ctype -> convertArg ctype nr (lbl:path)) [0..] ctypes)
-convertArg (C max) nr path = do
- index <- choices nr path
- return (Con index)
-convertArg (S _) nr path = do
- (args,_) <- get
- let PFCat _ cat rcs tcs = args !! nr
- l = index path rcs 0
- sym | isLiteralCat cat = FSymLit nr l
- | otherwise = FSymCat nr l
- return (Str [sym])
- where
- index lbl' (lbl:lbls) idx
- | lbl' == lbl = idx
- | otherwise = index lbl' lbls $! (idx+1)
-
-convertCon (C max) index [] = return (Con index)
-convertCon x _ _ = fail $ "SimpleToFCFG.convertCon: " ++ show x
-
-convertRec cnc_defs [] (R ctypes) record = do
- mkRecord (zipWith (convertTerm cnc_defs []) ctypes record)
-convertRec cnc_defs (index:sub_sel) ctype record =
- convertTerm cnc_defs sub_sel ctype (record !! index)
-
-
-------------------------------------------------------------
--- eval a term to ground terms
-
-evalTerm :: TermMap -> FPath -> Term -> CnvMonad FIndex
-evalTerm cnc_defs path (V nr) = choices nr (reverse path)
-evalTerm cnc_defs path (C nr) = return nr
-evalTerm cnc_defs path (R record) = case path of
- (index:path) -> evalTerm cnc_defs path (record !! index)
-evalTerm cnc_defs path (P term sel) = do index <- evalTerm cnc_defs [] sel
- evalTerm cnc_defs (index:path) term
-evalTerm cnc_defs path (FV terms) = variants terms >>= evalTerm cnc_defs path
-evalTerm cnc_defs path (F id) = case Map.lookup id cnc_defs of
- Just term -> evalTerm cnc_defs path term
- Nothing -> error ("unknown id " ++ showCId id)
-evalTerm cnc_defs path x = error ("evalTerm ("++show x++")")
-
-
-----------------------------------------------------------------------
--- GrammarEnv
-
-data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int CatSet SeqSet FunSet CoerceSet (IntMap.IntMap (Set.Set Production))
-type CatSet = IntMap.IntMap (Map.Map CId (FCat,FCat,[Int]))
-type SeqSet = Map.Map FSeq SeqId
-type FunSet = Map.Map FFun FunId
-type CoerceSet= Map.Map [FCat] FCat
-
-emptyGrammarEnv cnc_defs lincats =
- let (last_id,catSet) = Map.mapAccumWithKey computeCatRange 0 lincats
- in GrammarEnv last_id (IntMap.singleton 0 catSet) Map.empty Map.empty Map.empty IntMap.empty
- where
- computeCatRange index cat ctype
- | cat == cidString = (index, (fcatString,fcatString,[]))
- | cat == cidInt = (index, (fcatInt, fcatInt, []))
- | cat == cidFloat = (index, (fcatFloat, fcatFloat, []))
- | cat == cidVar = (index, (fcatVar, fcatVar, []))
- | otherwise = (index+size,(index,index+size-1,poly))
- where
- (size,poly) = getMultipliers 1 [] ctype
-
- getMultipliers m ms (R record) = foldl (\(m,ms) t -> getMultipliers m ms t) (m,ms) record
- getMultipliers m ms (S _) = (m,ms)
- getMultipliers m ms (C max_index) = (m*(max_index+1),m : ms)
- getMultipliers m ms (F id) = case Map.lookup id cnc_defs of
- Just term -> getMultipliers m ms term
- Nothing -> error ("unknown identifier: "++showCId id)
-
-expandHOAS abs_defs cnc_defs lincats lindefs env =
- foldl add_varFun (foldl (\env ncat -> add_hoFun (add_hoCat env ncat) ncat) env hoTypes) hoCats
- where
- hoTypes :: [(Int,CId)]
- hoTypes = sortNub [(n,c) | (_,(ty,_,_)) <- abs_defs
- , (n,c) <- fst (typeSkeleton ty), n > 0]
-
- hoCats :: [CId]
- hoCats = sortNub [c | (_,(ty,_,_)) <- abs_defs
- , h <- case ty of {DTyp hyps val _ -> hyps}
- , let ty = typeOfHypo h
- , c <- fst (catSkeleton ty)]
-
- -- add a range of PMCFG categories for each GF high-order category
- add_hoCat env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (n,cat) =
- case IntMap.lookup 0 catSet >>= Map.lookup cat of
- Just (start,end,ms) -> let !catSet' = IntMap.insertWith Map.union n (Map.singleton cat (last_id,last_id+(end-start),ms)) catSet
- !last_id' = last_id+(end-start)+1
- in (GrammarEnv last_id' catSet' seqSet funSet crcSet prodSet)
- Nothing -> env
-
- -- add one PMCFG function for each high-order type: _B : Cat -> Var -> ... -> Var -> HoCat
- add_hoFun env (n,cat) =
- let linRec = reverse $
- [[FSymCat 0 i] | (l,i) <- case arg of {PFCat _ _ rcs _ -> zip rcs [0..]}] ++
- [[FSymLit i 0] | i <- [1..n]]
- (env1,lins) = List.mapAccumL addFSeq env linRec
- newLinRec = mkArray lins
-
- (env2,funid) = addFFun env1 (FFun _B [[i] | i <- [0..n]] newLinRec)
-
- env3 = foldl (\env (arg,res) -> addProduction env res (FApply funid (arg : replicate n fcatVar)))
- env2
- (zip (getFCats env2 arg) (getFCats env2 res))
- in env3
- where
- (arg,res) = case Map.lookup cat lincats of
- Nothing -> error $ "No lincat for " ++ showCId cat
- Just ctype -> (protoFCat cnc_defs (0,cat) ctype, protoFCat cnc_defs (n,cat) ctype)
-
- -- add one PMCFG function for each high-order category: _V : Var -> Cat
- add_varFun env cat =
- convertRule cnc_defs env (PFRule _V [(0,cidVar)] (0,cat) [arg] res lindef)
- where
- lindef =
- case Map.lookup cat lindefs of
- Nothing -> error $ "No lindef for " ++ showCId cat
- Just def -> def
-
- arg =
- case Map.lookup cidVar lincats of
- Nothing -> error $ "No lincat for " ++ showCId cat
- Just ctype -> ctype
-
- res =
- case Map.lookup cat lincats of
- Nothing -> error $ "No lincat for " ++ showCId cat
- Just ctype -> ctype
-
- _B = mkCId "_B"
- _V = mkCId "_V"
-
-addProduction :: GrammarEnv -> FCat -> Production -> GrammarEnv
-addProduction (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) cat p =
- GrammarEnv last_id catSet seqSet funSet crcSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet)
-
-addFSeq :: GrammarEnv -> [FSymbol] -> (GrammarEnv,SeqId)
-addFSeq env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) lst =
- case Map.lookup seq seqSet of
- Just id -> (env,id)
- Nothing -> let !last_seq = Map.size seqSet
- in (GrammarEnv last_id catSet (Map.insert seq last_seq seqSet) funSet crcSet prodSet,last_seq)
- where
- seq = mkArray lst
-
-addFFun :: GrammarEnv -> FFun -> (GrammarEnv,FunId)
-addFFun env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) fun =
- case Map.lookup fun funSet of
- Just id -> (env,id)
- Nothing -> let !last_funid = Map.size funSet
- in (GrammarEnv last_id catSet seqSet (Map.insert fun last_funid funSet) crcSet prodSet,last_funid)
-
-addFCoercion :: GrammarEnv -> [FCat] -> (GrammarEnv,FCat)
-addFCoercion env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) sub_fcats =
- case sub_fcats of
- [fcat] -> (env,fcat)
- _ -> case Map.lookup sub_fcats crcSet of
- Just fcat -> (env,fcat)
- Nothing -> let !fcat = last_id+1
- in (GrammarEnv fcat catSet seqSet funSet (Map.insert sub_fcats fcat crcSet) prodSet,fcat)
-
-getParserInfo :: GrammarEnv -> ParserInfo
-getParserInfo (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) =
- ParserInfo { functions = mkArray funSet
- , sequences = mkArray seqSet
- , productions0= productions0
- , productions = filterProductions productions0
- , startCats = maybe Map.empty (Map.map (\(start,end,_) -> range (start,end))) (IntMap.lookup 0 catSet)
- , totalCats = last_id+1
- }
- where
- mkArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
-
- productions0 = IntMap.union prodSet coercions
- coercions = IntMap.fromList [(fcat,Set.fromList (map FCoerce sub_fcats)) | (sub_fcats,fcat) <- Map.toList crcSet]
-
-getFCats :: GrammarEnv -> ProtoFCat -> [FCat]
-getFCats (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (PFCat n cat rcs tcs) =
- case IntMap.lookup n catSet >>= Map.lookup cat of
- Just (start,end,ms) -> reverse (solutions (variants ms tcs start) ())
- where
- variants _ [] fcat = return fcat
- variants (m:ms) ((_,indices) : tcs) fcat = do index <- member indices
- variants ms tcs ((m*index) + fcat)
-
-
-------------------------------------------------------------
--- updating the MCF rule
-
-restrictArg :: FIndex -> FPath -> FIndex -> BacktrackM Env ()
-restrictArg nr path index = do
- (head, args) <- get
- args' <- updateNthM (restrictProtoFCat path index) nr args
- put (head, args')
-
-restrictHead :: FPath -> FIndex -> BacktrackM Env ()
-restrictHead path term
- = do (head, args) <- get
- head' <- restrictProtoFCat path term head
- put (head', args)
-
-restrictProtoFCat :: FPath -> FIndex -> ProtoFCat -> BacktrackM Env ProtoFCat
-restrictProtoFCat path0 index0 (PFCat n cat rcs tcs) = do
- tcs <- addConstraint tcs
- return (PFCat n cat rcs tcs)
- where
- addConstraint [] = error "restrictProtoFCat: unknown path"
- addConstraint (c@(path,indices) : tcs)
- | path0 == path = guard (index0 `elem` indices) >>
- return ((path,[index0]) : tcs)
- | otherwise = liftM (c:) (addConstraint tcs)
-
-mkArray lst = listArray (0,length lst-1) lst
diff --git a/src/GF/Compile/GeneratePMCFGOld.hs b/src/GF/Compile/GeneratePMCFGOld.hs
deleted file mode 100644
index 244ed68fe..000000000
--- a/src/GF/Compile/GeneratePMCFGOld.hs
+++ /dev/null
@@ -1,374 +0,0 @@
-{-# LANGUAGE BangPatterns, CPP #-}
-----------------------------------------------------------------------
--- |
--- Maintainer : Krasimir Angelov
--- Stability : (stable)
--- Portability : (portable)
---
--- Converting SimpleGFC grammars to fast nonerasing MCFG grammar.
---
--- the resulting grammars might be /very large/
---
--- the conversion is only equivalent if the GFC grammar has a context-free backbone.
------------------------------------------------------------------------------
-
-module GF.Compile.GeneratePMCFG
- (convertConcrete) where
-
-import PGF.CId
-import PGF.Data
-import PGF.Macros --hiding (prt)
-
-import GF.Data.BacktrackM
-import GF.Data.SortedList
-import GF.Data.Utilities (updateNthM, sortNub)
-
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import qualified Data.List as List
-import qualified Data.IntMap as IntMap
-import qualified Data.ByteString.Char8 as BS
-import Data.Array.IArray
-import Data.Maybe
-import Control.Monad
-import Debug.Trace
-
-----------------------------------------------------------------------
--- main conversion function
-
-convertConcrete :: Abstr -> Concr -> ParserInfo
-convertConcrete abs cnc = convert abs_defs conc cats
- where abs_defs = Map.assocs (funs abs)
- conc = Map.union (opers cnc) (lins cnc) -- "union big+small most efficient"
- cats = lincats cnc
-
-convert :: [(CId,(Type,Expr))] -> TermMap -> TermMap -> ParserInfo
-convert abs_defs cnc_defs cat_defs =
- let env = expandHOAS abs_defs cnc_defs cat_defs (emptyGrammarEnv cnc_defs cat_defs)
- in getParserInfo (List.foldl' (convertRule cnc_defs) env xrules)
- where
- xrules = [
- (XRule id args (0,res) (map findLinType args) (findLinType (0,res)) term) |
- (id, (ty,_)) <- abs_defs, let (args,res) = typeSkeleton ty,
- term <- maybeToList (Map.lookup id cnc_defs)]
-
- findLinType (_,id) = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs)
-
-brk :: (GrammarEnv -> GrammarEnv) -> (GrammarEnv -> GrammarEnv)
-brk f (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) =
- case f (GrammarEnv last_id catSet seqSet funSet crcSet IntMap.empty) of
- (GrammarEnv last_id catSet seqSet funSet crcSet topdown1) -> IntMap.foldWithKey optimize (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) topdown1
- where
- optimize cat ps env = IntMap.foldWithKey ff env (IntMap.fromListWith (++) [(funid,[args]) | FApply funid args <- Set.toList ps])
- where
- ff :: FunId -> [[FCat]] -> GrammarEnv -> GrammarEnv
- ff funid xs env
- | product (map Set.size ys) == count =
- case List.mapAccumL (\env c -> addFCoercion env (Set.toList c)) env ys of
- (env,args) -> addProduction env cat (FApply funid args)
- | otherwise = List.foldl (\env args -> addProduction env cat (FApply funid args)) env xs
- where
- count = length xs
- ys = foldr (zipWith Set.insert) (repeat Set.empty) xs
-
-convertRule :: TermMap -> GrammarEnv -> XRule -> GrammarEnv
-convertRule cnc_defs grammarEnv (XRule fun args res ctypes ctype term) =
- brk (\grammarEnv -> foldBM addRule
- grammarEnv
- (convertTerm cnc_defs [] ctype term [([],[])])
- (protoFCat cnc_defs res ctype, zipWith (protoFCat cnc_defs) args ctypes)) grammarEnv
- where
- addRule linRec (newCat', newArgs') env0 =
- let [newCat] = getFCats env0 newCat'
- (env1, newArgs) = List.mapAccumL (\env -> addFCoercion env . getFCats env) env0 newArgs'
-
- (env2,lins) = List.mapAccumL addFSeq env1 linRec
- newLinRec = mkArray lins
-
- (env3,funid) = addFFun env2 (FFun fun [[n] | n <- [0..length newArgs-1]] newLinRec)
-
- in addProduction env3 newCat (FApply funid newArgs)
-
-----------------------------------------------------------------------
--- term conversion
-
-type CnvMonad a = BacktrackM Env a
-
-type FPath = [FIndex]
-data ProtoFCat = PFCat Int CId [FPath] [(FPath,[FIndex])]
-type Env = (ProtoFCat, [ProtoFCat])
-type LinRec = [(FPath, [FSymbol])]
-data XRule = XRule CId {- function -}
- [(Int,CId)] {- argument types: context size and category -}
- (Int,CId) {- result type : context size (always 0) and category -}
- [Term] {- argument lin-types representation -}
- Term {- result lin-type representation -}
- Term {- body -}
-
-protoFCat :: TermMap -> (Int,CId) -> Term -> ProtoFCat
-protoFCat cnc_defs (n,cat) ctype =
- let (rcs,tcs) = loop [] [] [] ctype'
- in PFCat n cat rcs tcs
- where
- ctype' -- extend the high-order linearization type
- | n > 0 = case ctype of
- R xs -> R (xs ++ replicate n (S []))
- _ -> error $ "Not a record: " ++ show ctype
- | otherwise = ctype
-
- loop path rcs tcs (R record) = List.foldl' (\(rcs,tcs) (index,term) -> loop (index:path) rcs tcs term) (rcs,tcs) (zip [0..] record)
- loop path rcs tcs (C i) = ( rcs,(path,[0..i]):tcs)
- loop path rcs tcs (S _) = (path:rcs, tcs)
- loop path rcs tcs (F id) = case Map.lookup id cnc_defs of
- Just term -> loop path rcs tcs term
- Nothing -> error ("unknown identifier: "++show id)
-
-type TermMap = Map.Map CId Term
-
-convertTerm :: TermMap -> FPath -> Term -> Term -> LinRec -> CnvMonad LinRec
-convertTerm cnc_defs sel ctype (V nr) ((lbl_path,lin) : lins) = convertArg ctype nr (reverse sel) lbl_path lin lins
-convertTerm cnc_defs sel ctype (C nr) ((lbl_path,lin) : lins) = convertCon ctype nr (reverse sel) lbl_path lin lins
-convertTerm cnc_defs sel ctype (R record) ((lbl_path,lin) : lins) = convertRec cnc_defs sel ctype record lbl_path lin lins
-convertTerm cnc_defs sel ctype (P term p) lins = do nr <- evalTerm cnc_defs [] p
- convertTerm cnc_defs (nr:sel) ctype term lins
-convertTerm cnc_defs sel ctype (FV vars) lins = do term <- member vars
- convertTerm cnc_defs sel ctype term lins
-convertTerm cnc_defs sel ctype (S ts) lins = foldM (\lins t -> convertTerm cnc_defs sel ctype t lins) lins (reverse ts)
---convertTerm cnc_defs sel ctype (K t) ((lbl_path,lin) : lins) = return ((lbl_path,FSymTok t : lin) : lins)
-convertTerm cnc_defs sel ctype (K (KS t)) ((lbl_path,lin) : lins) = return ((lbl_path,FSymTok (KS t) : lin) : lins)
-convertTerm cnc_defs sel ctype (K (KP strs vars))((lbl_path,lin) : lins) =
- do toks <- member (strs:[strs' | Alt strs' _ <- vars])
- return ((lbl_path, map (FSymTok . KS) toks ++ lin) : lins)
-convertTerm cnc_defs sel ctype (F id) lins = case Map.lookup id cnc_defs of
- Just term -> convertTerm cnc_defs sel ctype term lins
- Nothing -> mzero
-convertTerm cnc_defs sel ctype (W s t) ((lbl_path,lin) : lins) = do
- ss <- case t of
- R ss -> return ss
- F f -> case Map.lookup f cnc_defs of
- Just (R ss) -> return ss
- _ -> mzero
- convertRec cnc_defs sel ctype [K (KS (s ++ s1)) | K (KS s1) <- ss] lbl_path lin lins
-convertTerm cnc_defs sel ctype x lins = error ("convertTerm ("++show x++")")
-
-
-convertArg (R record) nr path lbl_path lin lins =
- foldM (\lins (lbl, ctype) -> convertArg ctype nr (lbl:path) (lbl:lbl_path) lin lins) lins (zip [0..] record)
-convertArg (C max) nr path lbl_path lin lins = do
- index <- member [0..max]
- restrictHead lbl_path index
- restrictArg nr path index
- return lins
-convertArg (S _) nr path lbl_path lin lins = do
- (_, args) <- get
- let PFCat _ cat rcs tcs = args !! nr
- l = index path rcs 0
- sym | isLiteralCat cat = FSymLit nr l
- | otherwise = FSymCat nr l
- return ((lbl_path, sym : lin) : lins)
- where
- index lbl' (lbl:lbls) idx
- | lbl' == lbl = idx
- | otherwise = index lbl' lbls $! (idx+1)
-
-
-convertCon (C max) index [] lbl_path lin lins = do
- guard (index <= max)
- restrictHead lbl_path index
- return lins
-convertCon x _ _ _ _ _ = error $ "SimpleToFCFG,convertCon: " ++ show x
-
-convertRec cnc_defs [] (R ctypes) record lbl_path lin lins =
- foldM (\lins (index,ctype,val) -> convertTerm cnc_defs [] ctype val ((index:lbl_path,lin) : lins))
- lins
- (zip3 [0..] ctypes record)
-convertRec cnc_defs (index:sub_sel) ctype record lbl_path lin lins = do
- convertTerm cnc_defs sub_sel ctype (record !! index) ((lbl_path,lin) : lins)
-
-
-------------------------------------------------------------
--- eval a term to ground terms
-
-evalTerm :: TermMap -> FPath -> Term -> CnvMonad FIndex
-evalTerm cnc_defs path (V nr) = do (_, args) <- get
- let PFCat _ _ _ tcs = args !! nr
- rpath = reverse path
- index <- member (fromMaybe (error "evalTerm: wrong path") (lookup rpath tcs))
- restrictArg nr rpath index
- return index
-evalTerm cnc_defs path (C nr) = return nr
-evalTerm cnc_defs path (R record) = case path of
- (index:path) -> evalTerm cnc_defs path (record !! index)
-evalTerm cnc_defs path (P term sel) = do index <- evalTerm cnc_defs [] sel
- evalTerm cnc_defs (index:path) term
-evalTerm cnc_defs path (FV terms) = member terms >>= evalTerm cnc_defs path
-evalTerm cnc_defs path (F id) = case Map.lookup id cnc_defs of
- Just term -> evalTerm cnc_defs path term
- Nothing -> mzero
-evalTerm cnc_defs path x = error ("evalTerm ("++show x++")")
-
-
-----------------------------------------------------------------------
--- GrammarEnv
-
-data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int CatSet SeqSet FunSet CoerceSet (IntMap.IntMap (Set.Set Production))
-type CatSet = IntMap.IntMap (Map.Map CId (FCat,FCat,[Int]))
-type SeqSet = Map.Map FSeq SeqId
-type FunSet = Map.Map FFun FunId
-type CoerceSet= Map.Map [FCat] FCat
-
-emptyGrammarEnv cnc_defs lincats =
- let (last_id,catSet) = Map.mapAccumWithKey computeCatRange 0 lincats
- in GrammarEnv last_id (IntMap.singleton 0 catSet) Map.empty Map.empty Map.empty IntMap.empty
- where
- computeCatRange index cat ctype
- | cat == cidString = (index, (fcatString,fcatString,[]))
- | cat == cidInt = (index, (fcatInt, fcatInt, []))
- | cat == cidFloat = (index, (fcatFloat, fcatFloat, []))
- | otherwise = (index+size,(index,index+size-1,poly))
- where
- (size,poly) = getMultipliers 1 [] ctype
-
- getMultipliers m ms (R record) = foldl (\(m,ms) t -> getMultipliers m ms t) (m,ms) record
- getMultipliers m ms (S _) = (m,ms)
- getMultipliers m ms (C max_index) = (m*(max_index+1),m : ms)
- getMultipliers m ms (F id) = case Map.lookup id cnc_defs of
- Just term -> getMultipliers m ms term
- Nothing -> error ("unknown identifier: "++prCId id)
-
-
-expandHOAS abs_defs cnc_defs lincats env =
- foldl add_varFun (foldl (\env ncat -> add_hoFun (add_hoCat env ncat) ncat) env hoTypes) hoCats
- where
- hoTypes :: [(Int,CId)]
- hoTypes = sortNub [(n,c) | (_,(ty,_)) <- abs_defs
- , (n,c) <- fst (typeSkeleton ty), n > 0]
-
- hoCats :: [CId]
- hoCats = sortNub [c | (_,(ty,_)) <- abs_defs
- , Hyp _ ty <- case ty of {DTyp hyps val _ -> hyps}
- , c <- fst (catSkeleton ty)]
-
- -- add a range of PMCFG categories for each GF high-order category
- add_hoCat env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (n,cat) =
- case IntMap.lookup 0 catSet >>= Map.lookup cat of
- Just (start,end,ms) -> let !catSet' = IntMap.insertWith Map.union n (Map.singleton cat (last_id,last_id+(end-start),ms)) catSet
- !last_id' = last_id+(end-start)+1
- in (GrammarEnv last_id' catSet' seqSet funSet crcSet prodSet)
- Nothing -> env
-
- -- add one PMCFG function for each high-order type: _B : Cat -> Var -> ... -> Var -> HoCat
- add_hoFun env (n,cat) =
- let linRec = reverse $
- [(l ,[FSymCat 0 i]) | (l,i) <- case arg of {PFCat _ _ rcs _ -> zip rcs [0..]}] ++
- [([],[FSymLit i 0]) | i <- [1..n]]
- (env1,lins) = List.mapAccumL addFSeq env linRec
- newLinRec = mkArray lins
-
- (env2,funid) = addFFun env1 (FFun _B [[i] | i <- [0..n]] newLinRec)
-
- env3 = foldl (\env (arg,res) -> addProduction env res (FApply funid (arg : replicate n fcatVar)))
- env2
- (zip (getFCats env2 arg) (getFCats env2 res))
- in env3
- where
- (arg,res) = case Map.lookup cat lincats of
- Nothing -> error $ "No lincat for " ++ prCId cat
- Just ctype -> (protoFCat cnc_defs (0,cat) ctype, protoFCat cnc_defs (n,cat) ctype)
-
- -- add one PMCFG function for each high-order category: _V : Var -> Cat
- add_varFun env cat =
- let (env1,seqid) = addFSeq env ([],[FSymLit 0 0])
- lins = replicate (case res of {PFCat _ _ rcs _ -> length rcs}) seqid
- (env2,funid) = addFFun env1 (FFun _V [[0]] (mkArray lins))
- env3 = foldl (\env res -> addProduction env2 res (FApply funid [fcatVar]))
- env2
- (getFCats env2 res)
- in env3
- where
- res = case Map.lookup cat lincats of
- Nothing -> error $ "No lincat for " ++ prCId cat
- Just ctype -> protoFCat cnc_defs (0,cat) ctype
-
- _B = mkCId "_B"
- _V = mkCId "_V"
-
-
-addProduction :: GrammarEnv -> FCat -> Production -> GrammarEnv
-addProduction (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) cat p =
- GrammarEnv last_id catSet seqSet funSet crcSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet)
-
-addFSeq :: GrammarEnv -> (FPath,[FSymbol]) -> (GrammarEnv,SeqId)
-addFSeq env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (_,lst) =
- case Map.lookup seq seqSet of
- Just id -> (env,id)
- Nothing -> let !last_seq = Map.size seqSet
- in (GrammarEnv last_id catSet (Map.insert seq last_seq seqSet) funSet crcSet prodSet,last_seq)
- where
- seq = mkArray lst
-
-addFFun :: GrammarEnv -> FFun -> (GrammarEnv,FunId)
-addFFun env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) fun =
- case Map.lookup fun funSet of
- Just id -> (env,id)
- Nothing -> let !last_funid = Map.size funSet
- in (GrammarEnv last_id catSet seqSet (Map.insert fun last_funid funSet) crcSet prodSet,last_funid)
-
-addFCoercion :: GrammarEnv -> [FCat] -> (GrammarEnv,FCat)
-addFCoercion env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) sub_fcats =
- case sub_fcats of
- [fcat] -> (env,fcat)
- _ -> case Map.lookup sub_fcats crcSet of
- Just fcat -> (env,fcat)
- Nothing -> let !fcat = last_id+1
- in (GrammarEnv fcat catSet seqSet funSet (Map.insert sub_fcats fcat crcSet) prodSet,fcat)
-
-getParserInfo :: GrammarEnv -> ParserInfo
-getParserInfo (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) =
- ParserInfo { functions = mkArray funSet
- , sequences = mkArray seqSet
- , productions = IntMap.union prodSet coercions
- , startCats = maybe Map.empty (Map.map (\(start,end,_) -> range (start,end))) (IntMap.lookup 0 catSet)
- , totalCats = last_id+1
- }
- where
- mkArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
-
- coercions = IntMap.fromList [(fcat,Set.fromList (map FCoerce sub_fcats)) | (sub_fcats,fcat) <- Map.toList crcSet]
-
-getFCats :: GrammarEnv -> ProtoFCat -> [FCat]
-getFCats (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (PFCat n cat rcs tcs) =
- case IntMap.lookup n catSet >>= Map.lookup cat of
- Just (start,end,ms) -> reverse (solutions (variants ms tcs start) ())
- where
- variants _ [] fcat = return fcat
- variants (m:ms) ((_,indices) : tcs) fcat = do index <- member indices
- variants ms tcs ((m*index) + fcat)
-
-------------------------------------------------------------
--- updating the MCF rule
-
-restrictArg :: FIndex -> FPath -> FIndex -> CnvMonad ()
-restrictArg nr path index = do
- (head, args) <- get
- args' <- updateNthM (restrictProtoFCat path index) nr args
- put (head, args')
-
-restrictHead :: FPath -> FIndex -> CnvMonad ()
-restrictHead path term
- = do (head, args) <- get
- head' <- restrictProtoFCat path term head
- put (head', args)
-
-restrictProtoFCat :: FPath -> FIndex -> ProtoFCat -> CnvMonad ProtoFCat
-restrictProtoFCat path0 index0 (PFCat n cat rcs tcs) = do
- tcs <- addConstraint tcs
- return (PFCat n cat rcs tcs)
- where
- addConstraint [] = error "restrictProtoFCat: unknown path"
- addConstraint (c@(path,indices) : tcs)
- | path0 == path = guard (index0 `elem` indices) >>
- return ((path,[index0]) : tcs)
- | otherwise = liftM (c:) (addConstraint tcs)
-
-mkArray lst = listArray (0,length lst-1) lst
diff --git a/src/GF/Compile/GetGrammar.hs b/src/GF/Compile/GetGrammar.hs
deleted file mode 100644
index c85f9588f..000000000
--- a/src/GF/Compile/GetGrammar.hs
+++ /dev/null
@@ -1,52 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : GetGrammar
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/11/15 17:56:13 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.16 $
---
--- this module builds the internal GF grammar that is sent to the type checker
------------------------------------------------------------------------------
-
-module GF.Compile.GetGrammar (getSourceModule, addOptionsToModule) where
-
-import GF.Data.Operations
-
-import GF.Infra.UseIO
-import GF.Infra.Modules
-import GF.Infra.Option
-import GF.Grammar.Lexer
-import GF.Grammar.Parser
-import GF.Grammar.Grammar
-
-import GF.Compile.ReadFiles
-
-import Data.Char (toUpper)
-import Data.List (nub)
-import qualified Data.ByteString.Char8 as BS
-import Control.Monad (foldM)
-import System.Cmd (system)
-
-getSourceModule :: Options -> FilePath -> IOE SourceModule
-getSourceModule opts file0 = ioe $
- catch (do file <- foldM runPreprocessor file0 (flag optPreprocessors opts)
- content <- BS.readFile file
- case runP pModDef content of
- Left (Pn l c,msg) -> return (Bad (file++":"++show l++":"++show c++": "++msg))
- Right mo -> return (Ok (addOptionsToModule opts mo)))
- (\e -> return (Bad (show e)))
-
-addOptionsToModule :: Options -> SourceModule -> SourceModule
-addOptionsToModule opts = mapSourceModule (\m -> m { flags = flags m `addOptions` opts })
-
--- FIXME: should use System.IO.openTempFile
-runPreprocessor :: FilePath -> String -> IO FilePath
-runPreprocessor file0 p = do
- let tmp = "_gf_preproc.tmp"
- cmd = p +++ file0 ++ ">" ++ tmp
- system cmd
- return tmp
diff --git a/src/GF/Compile/GrammarToGFCC.hs b/src/GF/Compile/GrammarToGFCC.hs
deleted file mode 100644
index fb92ef74c..000000000
--- a/src/GF/Compile/GrammarToGFCC.hs
+++ /dev/null
@@ -1,587 +0,0 @@
-{-# LANGUAGE PatternGuards #-}
-module GF.Compile.GrammarToGFCC (mkCanon2gfcc,addParsers) where
-
-import GF.Compile.Export
-import qualified GF.Compile.GenerateFCFG as FCFG
-import qualified GF.Compile.GeneratePMCFG as PMCFG
-
-import PGF.CId
-import qualified PGF.Macros as CM
-import qualified PGF.Data as C
-import qualified PGF.Data as D
-import GF.Grammar.Predef
-import GF.Grammar.Printer
-import GF.Grammar.Grammar
-import qualified GF.Grammar.Lookup as Look
-import qualified GF.Grammar as A
-import qualified GF.Grammar.Macros as GM
-import qualified GF.Compile.Concrete.Compute as Compute ----
-import qualified GF.Infra.Modules as M
-import qualified GF.Infra.Option as O
-
-import GF.Infra.Ident
-import GF.Infra.Option
-import GF.Data.Operations
-
-import Data.List
-import Data.Char (isDigit,isSpace)
-import qualified Data.Map as Map
-import qualified Data.ByteString.Char8 as BS
-import Text.PrettyPrint
-import Debug.Trace ----
-
--- when developing, swap commenting
---traceD s t = trace s t
-traceD s t = t
-
-
--- the main function: generate PGF from GF.
-mkCanon2gfcc :: Options -> String -> SourceGrammar -> (String,D.PGF)
-mkCanon2gfcc opts cnc gr =
- (showIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon opts abs) gr)
- where
- abs = err (const c) id $ M.abstractOfConcrete gr c where c = identC (BS.pack cnc)
- pars = mkParamLincat gr
-
--- Adds parsers for all concretes
-addParsers :: Options -> D.PGF -> IO D.PGF
-addParsers opts pgf = do cncs <- sequence [conv lang cnc | (lang,cnc) <- Map.toList (D.concretes pgf)]
- return pgf { D.concretes = Map.fromList cncs }
- where
- conv lang cnc = do pinfo <- if flag optErasing (erasingFromCnc `addOptions` opts)
- then PMCFG.convertConcrete opts (D.abstract pgf) lang cnc
- else return $ FCFG.convertConcrete (D.abstract pgf) cnc
- return (lang,cnc { D.parser = Just pinfo })
- where
- erasingFromCnc = modifyFlags (\o -> o { optErasing = Map.lookup (mkCId "erasing") (D.cflags cnc) == Just "on"})
-
--- Generate PGF from GFCM.
--- this assumes a grammar translated by canon2canon
-
-canon2gfcc :: Options -> (Ident -> Ident -> C.Term) -> SourceGrammar -> D.PGF
-canon2gfcc opts pars cgr@(M.MGrammar ((a,abm):cms)) =
- (if dump opts DumpCanon then trace (render (vcat (map (ppModule Qualified) (M.modules cgr)))) else id) $
- D.PGF an cns gflags abs cncs
- where
- -- abstract
- an = (i2i a)
- cns = map (i2i . fst) cms
- abs = D.Abstr aflags funs cats catfuns
- gflags = Map.empty
- aflags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF (M.flags abm)]
-
- mkDef (Just eqs) = [C.Equ ps' (mkExp scope' e) | (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
- mkDef Nothing = []
-
- mkArrity (Just a) = a
- mkArrity Nothing = 0
-
- -- concretes
- lfuns = [(f', (mkType [] ty, mkArrity ma, mkDef pty)) |
- (f,AbsFun (Just ty) ma pty) <- tree2list (M.jments abm), let f' = i2i f]
- funs = Map.fromAscList lfuns
- lcats = [(i2i c, snd (mkContext [] cont)) |
- (c,AbsCat (Just cont) _) <- tree2list (M.jments abm)]
- cats = Map.fromAscList lcats
- catfuns = Map.fromList
- [(cat,[f | (f, (C.DTyp _ c _,_,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
-
- cncs = Map.fromList [mkConcr lang (i2i lang) mo | (lang,mo) <- cms]
- mkConcr lang0 lang mo =
- (lang,D.Concr flags lins opers lincats lindefs printnames params fcfg)
- where
- js = tree2list (M.jments mo)
- flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF (M.flags mo)]
- opers = Map.fromAscList [] -- opers will be created as optimization
- utf = id -- trace (show lang0 +++ show flags) $
- -- if moduleFlag optEncoding (moduleOptions (M.flags mo)) == UTF_8
- -- then id else id
- ---- then (trace "decode" D.convertStringsInTerm decodeUTF8) else id
- umkTerm = utf . mkTerm
- lins = Map.fromAscList
- [(f', umkTerm tr) | (f,CncFun _ (Just tr) _) <- js,
- let f' = i2i f, exists f'] -- eliminating lins without fun
- -- needed even here because of restricted inheritance
- lincats = Map.fromAscList
- [(i2i c, mkCType ty) | (c,CncCat (Just ty) _ _) <- js]
- lindefs = Map.fromAscList
- [(i2i c, umkTerm tr) | (c,CncCat _ (Just tr) _) <- js]
- printnames = Map.union
- (Map.fromAscList [(i2i f, umkTerm tr) | (f,CncFun _ _ (Just tr)) <- js])
- (Map.fromAscList [(i2i f, umkTerm tr) | (f,CncCat _ _ (Just tr)) <- js])
- params = Map.fromAscList
- [(i2i c, pars lang0 c) | (c,CncCat (Just ty) _ _) <- js]
- fcfg = Nothing
-
- exists f = Map.member f funs
-
-i2i :: Ident -> CId
-i2i = CId . ident2bs
-
-b2b :: A.BindType -> C.BindType
-b2b A.Explicit = C.Explicit
-b2b A.Implicit = C.Implicit
-
-mkType :: [Ident] -> A.Type -> C.Type
-mkType scope t =
- case GM.typeForm t of
- (hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps
- in C.DTyp hyps' (i2i cat) (map (mkExp scope') args)
-
-mkExp :: [Ident] -> A.Term -> C.Expr
-mkExp scope t = case GM.termForm t of
- Ok (xs,c,args) -> mkAbs xs (mkApp (map snd (reverse xs)++scope) c (map (mkExp scope) args))
- where
- mkAbs xs t = foldr (\(b,v) -> C.EAbs (b2b b) (i2i v)) t xs
- mkApp scope c args = case c of
- Q _ c -> foldl C.EApp (C.EFun (i2i c)) args
- QC _ c -> foldl C.EApp (C.EFun (i2i c)) args
- Vr x -> case lookup x (zip scope [0..]) of
- Just i -> foldl C.EApp (C.EVar i) args
- Nothing -> foldl C.EApp (C.EMeta 0) args
- EInt i -> C.ELit (C.LInt i)
- EFloat f -> C.ELit (C.LFlt f)
- K s -> C.ELit (C.LStr s)
- Meta i -> C.EMeta i
- _ -> C.EMeta 0
-
-mkPatt scope p =
- case p of
- A.PP _ c ps -> let (scope',ps') = mapAccumL mkPatt scope ps
- in (scope',C.PApp (i2i c) ps')
- A.PV x -> (x:scope,C.PVar (i2i x))
- A.PW -> ( scope,C.PWild)
- A.PInt i -> ( scope,C.PLit (C.LInt i))
- A.PFloat f -> ( scope,C.PLit (C.LFlt f))
- A.PString s -> ( scope,C.PLit (C.LStr s))
-
-
-mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo])
-mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
- in if x == identW
- then ( scope,(b2b bt,i2i x,ty'))
- else (x:scope,(b2b bt,i2i x,ty'))) scope hyps
-
-mkTerm :: Term -> C.Term
-mkTerm tr = case tr of
- Vr (IA _ i) -> C.V i
- Vr (IAV _ _ i) -> C.V i
- Vr (IC s) | isDigit (BS.last s) ->
- C.V ((read . BS.unpack . snd . BS.spanEnd isDigit) s)
- ---- from gf parser of gfc
- EInt i -> C.C $ fromInteger i
- R rs -> C.R [mkTerm t | (_, (_,t)) <- rs]
- P t l -> C.P (mkTerm t) (C.C (mkLab l))
- T _ cs -> C.R [mkTerm t | (_,t) <- cs] ------
- V _ cs -> C.R [mkTerm t | t <- cs]
- S t p -> C.P (mkTerm t) (mkTerm p)
- C s t -> C.S $ concatMap flats [mkTerm x | x <- [s,t]]
- FV ts -> C.FV [mkTerm t | t <- ts]
- K s -> C.K (C.KS s)
------ K (KP ss _) -> C.K (C.KP ss []) ---- TODO: prefix variants
- Empty -> C.S []
- App _ _ -> prtTrace tr $ C.C 66661 ---- for debugging
- Abs _ _ t -> mkTerm t ---- only on toplevel
- Alts (td,tvs) ->
- C.K (C.KP (strings td) [C.Alt (strings u) (strings v) | (u,v) <- tvs])
- _ -> prtTrace tr $ C.S [C.K (C.KS (render (A.ppTerm Unqualified 0 tr <+> int 66662)))] ---- for debugging
- where
- mkLab (LIdent l) = case BS.unpack l of
- '_':ds -> (read ds) :: Int
- _ -> prtTrace tr $ 66663
- strings t = case t of
- K s -> [s]
- C u v -> strings u ++ strings v
- Strs ss -> concatMap strings ss
- _ -> prtTrace tr $ ["66660"]
- flats t = case t of
- C.S ts -> concatMap flats ts
- _ -> [t]
-
--- encoding PGF-internal lincats as terms
-mkCType :: Type -> C.Term
-mkCType t = case t of
- EInt i -> C.C $ fromInteger i
- RecType rs -> C.R [mkCType t | (_, t) <- rs]
- Table pt vt -> case pt of
- EInt i -> C.R $ replicate (1 + fromInteger i) $ mkCType vt
- RecType rs -> mkCType $ foldr Table vt (map snd rs)
- _ | Just i <- GM.isTypeInts pt -> C.R $ replicate (fromInteger i) $ mkCType vt
-
- Sort s | s == cStr -> C.S [] --- Str only
- _ | Just i <- GM.isTypeInts t -> C.C $ fromInteger i
- _ -> error $ "mkCType " ++ show t
-
--- encoding showable lincats (as in source gf) as terms
-mkParamLincat :: SourceGrammar -> Ident -> Ident -> C.Term
-mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do
- typ <- Look.lookupLincat sgr lang cat
- mkPType typ
- where
- mkPType typ = case typ of
- RecType lts -> do
- ts <- mapM (mkPType . snd) lts
- return $ C.R [ C.P (kks $ showIdent (label2ident l)) t | ((l,_),t) <- zip lts ts]
- Table (RecType lts) v -> do
- ps <- mapM (mkPType . snd) lts
- v' <- mkPType v
- return $ foldr (\p v -> C.S [p,v]) v' ps
- Table p v -> do
- p' <- mkPType p
- v' <- mkPType v
- return $ C.S [p',v']
- Sort s | s == cStr -> return $ C.S []
- _ -> return $
- C.FV $ map (kks . filter showable . render . ppTerm Unqualified 0) $
- errVal [] $ Look.allParamValues sgr typ
- showable c = not (isSpace c) ---- || (c == ' ') -- to eliminate \n in records
- kks = C.K . C.KS
-
--- return just one module per language
-
-reorder :: Ident -> SourceGrammar -> SourceGrammar
-reorder abs cg = M.MGrammar $
- (abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs poss):
- [(c, M.ModInfo (M.MTConcrete abs) M.MSComplete fs [] Nothing [] [] (sorted2tree js) poss)
- | (c,(fs,js)) <- cncs]
- where
- poss = emptyBinTree -- positions no longer needed
- mos = M.modules cg
- adefs = sorted2tree $ sortIds $
- predefADefs ++ Look.allOrigInfos cg abs
- predefADefs =
- [(c, AbsCat (Just []) Nothing) | c <- [cFloat,cInt,cString]]
- aflags =
- concatOptions [M.flags mo | (_,mo) <- M.modules cg, M.isModAbs mo]
-
- cncs = sortIds [(lang, concr lang) | lang <- M.allConcretes cg abs]
- concr la = (flags,
- sortIds (predefCDefs ++ jments)) where
- jments = Look.allOrigInfos cg la
- flags = concatOptions
- [M.flags mo |
- (i,mo) <- mos, M.isModCnc mo,
- Just r <- [lookup i (M.allExtendSpecs cg la)]]
-
- predefCDefs =
- [(c, CncCat (Just GM.defLinType) Nothing Nothing) | c <- [cInt,cFloat,cString]]
-
- sortIds = sortBy (\ (f,_) (g,_) -> compare f g)
-
-
--- one grammar per language - needed for symtab generation
-repartition :: Ident -> SourceGrammar -> [SourceGrammar]
-repartition abs cg =
- [M.partOfGrammar cg (lang,mo) |
- let mos = M.modules cg,
- lang <- case M.allConcretes cg abs of
- [] -> [abs] -- to make pgf nonempty even when there are no concretes
- cncs -> cncs,
- let mo = errVal
- (error (render (text "no module found for" <+> A.ppIdent lang))) $ M.lookupModule cg lang
- ]
-
--- translate tables and records to arrays, parameters and labels to indices
-
-canon2canon :: Options -> Ident -> SourceGrammar -> SourceGrammar
-canon2canon opts abs cg0 =
- (recollect . map cl2cl . repartition abs . purgeGrammar abs) cg0
- where
- recollect = M.MGrammar . nubBy (\ (i,_) (j,_) -> i==j) . concatMap M.modules
- cl2cl = M.MGrammar . js2js . map (c2c p2p) . M.modules
-
- js2js ms = map (c2c (j2j (M.MGrammar ms))) ms
-
- c2c f2 (c,mo) = (c, M.replaceJudgements mo $ mapTree f2 (M.jments mo))
-
- j2j cg (f,j) =
- let debug = if verbAtLeast opts Verbose then trace ("+ " ++ showIdent f) else id in
- case j of
- CncFun x (Just tr) z -> CncFun x (Just (debug (t2t (unfactor cg0 tr)))) z
- CncCat (Just ty) (Just x) y -> CncCat (Just (ty2ty ty)) (Just (t2t (unfactor cg0 x))) y
- _ -> j
- where
- cg1 = cg
- t2t = term2term f cg1 pv
- ty2ty = type2type cg1 pv
- pv@(labels,untyps,typs) = trs $ paramValues cg1
-
- unfactor :: SourceGrammar -> Term -> Term
- unfactor gr t = case t of
- T (TTyped ty) [(PV x,u)] -> V ty [restore x v (unfac u) | v <- vals ty]
- _ -> GM.composSafeOp unfac t
- where
- unfac = unfactor gr
- vals = err error id . Look.allParamValues gr
- restore x u t = case t of
- Vr y | y == x -> u
- _ -> GM.composSafeOp (restore x u) t
-
- -- flatten record arguments of param constructors
- p2p (f,j) = case j of
- ResParam (Just ps) (Just vs) ->
- ResParam (Just [(c,concatMap unRec cont) | (c,cont) <- ps]) (Just (map unrec vs))
- _ -> j
- unRec (bt,x,ty) = case ty of
- RecType fs -> [ity | (_,typ) <- fs, ity <- unRec (Explicit,identW,typ)]
- _ -> [(bt,x,ty)]
- unrec t = case t of
- App f (R fs) -> GM.mkApp (unrec f) [unrec u | (_,(_,u)) <- fs]
- _ -> GM.composSafeOp unrec t
-
-
-----
- trs v = traceD (render (tr v)) v
-
- tr (labels,untyps,typs) =
- (text "LABELS:" <+>
- vcat [A.ppIdent c <> char '.' <> hsep (map A.ppLabel l) <+> char '=' <+> text (show i) | ((c,l),i) <- Map.toList labels]) $$
- (text "UNTYPS:" <+>
- vcat [A.ppTerm Unqualified 0 t <+> char '=' <+> text (show i) | (t,i) <- Map.toList untyps]) $$
- (text "TYPS: " <+>
- vcat [A.ppTerm Unqualified 0 t <+> char '=' <+> text (show (Map.assocs i)) | (t,i) <- Map.toList typs])
-----
-
-purgeGrammar :: Ident -> SourceGrammar -> SourceGrammar
-purgeGrammar abstr gr =
- (M.MGrammar . list . filter complete . purge . M.modules) gr
- where
- list ms = traceD (render (text "MODULES" <+> hsep (punctuate comma (map (ppIdent . fst) ms)))) ms
- purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst)
- needed = nub $ concatMap (requiredCanModules isSingle gr) acncs
- acncs = abstr : M.allConcretes gr abstr
- isSingle = True
- complete (i,m) = M.isCompleteModule m --- not . isIncompleteCanon
-
-type ParamEnv =
- (Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels
- Map.Map Term Integer, -- untyped terms to values
- Map.Map Type (Map.Map Term Integer)) -- types to their terms to values
-
---- gathers those param types that are actually used in lincats and lin terms
-paramValues :: SourceGrammar -> ParamEnv
-paramValues cgr = (labels,untyps,typs) where
- partyps = nub $
- --- [App (Q (IC "Predef") (IC "Ints")) (EInt i) | i <- [1,9]] ---linTypeInt
- [ty |
- (_,(_,CncCat (Just ty0) _ _)) <- jments,
- ty <- typsFrom ty0
- ] ++ [
- Q m ty |
- (m,(ty,ResParam _ _)) <- jments
- ] ++ [ty |
- (_,(_,CncFun _ (Just tr) _)) <- jments,
- ty <- err (const []) snd $ appSTM (typsFromTrm tr) []
- ]
- params = [(ty, errVal (traceD ("UNKNOWN PARAM TYPE" +++ show ty) []) $
- Look.allParamValues cgr ty) | ty <- partyps]
- typsFrom ty = (if isParam ty then (ty:) else id) $ case ty of
- Table p t -> typsFrom p ++ typsFrom t
- RecType ls -> concat [typsFrom t | (_, t) <- ls]
- _ -> []
-
- isParam ty = case ty of
- Q _ _ -> True
- QC _ _ -> True
- RecType rs -> all isParam (map snd rs)
- _ -> False
-
- typsFromTrm :: Term -> STM [Type] Term
- typsFromTrm tr = case tr of
- R fs -> mapM_ (typsFromField . snd) fs >> return tr
- where
- typsFromField (mty, t) = case mty of
- Just x -> updateSTM (x:) >> typsFromTrm t
- _ -> typsFromTrm t
- V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr
- T (TTyped ty) cs ->
- updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
- T (TComp ty) cs ->
- updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
- _ -> GM.composOp typsFromTrm tr
-
- mods = traceD (render (hsep (map (ppIdent . fst) ms))) ms where ms = M.modules cgr
-
- jments =
- [(m,j) | (m,mo) <- mods, j <- tree2list $ M.jments mo]
- typs =
- Map.fromList [(ci,Map.fromList (zip vs [0..])) | (ci,vs) <- params]
- untyps =
- Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs]
- lincats =
- [(cat,[f | let RecType fs = GM.defLinType, f <- fs]) | cat <- [cInt,cFloat, cString]] ++
- reverse ---- TODO: really those lincats that are reached
- ---- reverse is enough to expel overshadowed ones...
- [(cat,ls) | (_,(cat,CncCat (Just ty) _ _)) <- jments,
- RecType ls <- [unlockTy ty]]
- labels = Map.fromList $ concat
- [((cat,[lab]),(typ,i)):
- [((cat,[LVar v]),(typ,toInteger (mx + v))) | v <- [0,1]] ++ ---- 1 or 2 vars
- [((cat,[lab,lab2]),(ty,j)) |
- rs <- getRec typ, ((lab2, ty),j) <- zip rs [0..]]
- |
- (cat,ls) <- lincats, ((lab, typ),i) <- zip ls [0..], let mx = length ls]
- -- go to tables recursively
- ---- TODO: even go to deeper records
- where
- getRec typ = case typ of
- RecType rs -> [rs] ---- [unlockTyp rs] -- (sort (unlockTyp ls))
- Table _ t -> getRec t
- _ -> []
-
-type2type :: SourceGrammar -> ParamEnv -> Type -> Type
-type2type cgr env@(labels,untyps,typs) ty = case ty of
- RecType rs ->
- RecType [(mkLab i, t2t t) | (i,(l, t)) <- zip [0..] (unlockTyp rs)]
- Table pt vt -> Table (t2t pt) (t2t vt)
- QC _ _ -> look ty
- _ -> ty
- where
- t2t = type2type cgr env
- look ty = EInt $ (+ (-1)) $ toInteger $ case Map.lookup ty typs of
- Just vs -> length $ Map.assocs vs
- _ -> trace ("unknown partype " ++ show ty) 66669
-
-term2term :: Ident -> SourceGrammar -> ParamEnv -> Term -> Term
-term2term fun cgr env@(labels,untyps,typs) tr = case tr of
- App _ _ -> mkValCase (unrec tr)
- QC _ _ -> mkValCase tr
- R rs -> R [(mkLab i, (Nothing, t2t t)) |
- (i,(l,(_,t))) <- zip [0..] (GM.sortRec (unlock rs))]
- P t l -> r2r tr
-
- T (TWild _) _ -> error $ (render (text "wild" <+> ppTerm Qualified 0 tr))
- T (TComp ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
- T (TTyped ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
- V ty ts -> mkCurry $ V ty [t2t t | t <- ts]
- S t p -> mkCurrySel (t2t t) (t2t p)
-
- _ -> GM.composSafeOp t2t tr
- where
- t2t = term2term fun cgr env
-
- unrec t = case t of
- App f (R fs) -> GM.mkApp (unrec f) [unrec u | (_,(_,u)) <- fs]
- _ -> GM.composSafeOp unrec t
-
- mkValCase tr = case appSTM (doVar tr) [] of
- Ok (tr', st@(_:_)) -> t2t $ comp $ foldr mkCase tr' st
- _ -> valNum $ comp tr
-
- --- this is mainly needed for parameter record projections
- ---- was:
- comp t = errVal t $ Compute.computeConcreteRec cgr t
-
- doVar :: Term -> STM [((Type,[Term]),(Term,Term))] Term
- doVar tr = case getLab tr of
- Ok (cat, lab) -> do
- k <- readSTM >>= return . length
- let tr' = Vr $ identC $ (BS.pack (show k)) -----
-
- let tyvs = case Map.lookup (cat,lab) labels of
- Just (ty,_) -> case Map.lookup ty typs of
- Just vs -> (ty,[t |
- (t,_) <- sortBy (\x y -> compare (snd x) (snd y))
- (Map.assocs vs)])
- _ -> error $ render (text "doVar1" <+> A.ppTerm Unqualified 0 ty)
- _ -> error $ render (text "doVar2" <+> A.ppTerm Unqualified 0 tr <+> text (show (cat,lab))) ---- debug
- updateSTM ((tyvs, (tr', tr)):)
- return tr'
- _ -> GM.composOp doVar tr
-
- r2r tr@(P (S (V ty ts) v) l) = t2t $ S (V ty [comp (P t l) | t <- ts]) v
-
- r2r tr@(P p _) = case getLab tr of
- Ok (cat,labs) -> P (t2t p) . mkLab $
- maybe (prtTrace tr $ 66664) snd $
- Map.lookup (cat,labs) labels
- _ -> K (render (A.ppTerm Unqualified 0 tr <+> prtTrace tr (int 66665)))
-
- -- this goes recursively into tables (ignored) and records (accumulated)
- getLab tr = case tr of
- Vr (IA cat _) -> return (identC cat,[])
- Vr (IAV cat _ _) -> return (identC cat,[])
- Vr (IC s) -> return (identC cat,[]) where
- cat = BS.takeWhile (/='_') s ---- also to match IAVs; no _ in a cat tolerated
- ---- init (reverse (dropWhile (/='_') (reverse s))) ---- from gf parser
----- Vr _ -> error $ "getLab " ++ show tr
- P p lab2 -> do
- (cat,labs) <- getLab p
- return (cat,labs++[lab2])
- S p _ -> getLab p
- _ -> Bad "getLab"
-
-
- mkCase ((ty,vs),(x,p)) tr =
- S (V ty [mkBranch x v tr | v <- vs]) p
- mkBranch x t tr = case tr of
- _ | tr == x -> t
- _ -> GM.composSafeOp (mkBranch x t) tr
-
- valNum tr = maybe (valNumFV $ tryFV tr) EInt $ Map.lookup tr untyps
- where
- tryFV tr = case GM.appForm tr of
- (c@(QC _ _), ts) -> [GM.mkApp c ts' | ts' <- combinations (map tryFV ts)]
- (FV ts,_) -> ts
- _ -> [tr]
- valNumFV ts = case ts of
- [tr] -> let msg = render (text "DEBUG" <+> ppIdent fun <> text ": error in valNum" <+> ppTerm Qualified 0 tr) in
- trace msg $ error (showIdent fun)
- _ -> FV $ map valNum ts
-
- mkCurry trm = case trm of
- V (RecType [(_,ty)]) ts -> V ty ts
- V (RecType ((_,ty):ltys)) ts ->
- V ty [mkCurry (V (RecType ltys) cs) |
- cs <- chop (product (map (lengthtyp . snd) ltys)) ts]
- _ -> trm
- lengthtyp ty = case Map.lookup ty typs of
- Just m -> length (Map.assocs m)
- _ -> error $ "length of type " ++ show ty
- chop i xs = case splitAt i xs of
- (xs1,[]) -> [xs1]
- (xs1,xs2) -> xs1:chop i xs2
-
-
- mkCurrySel t p = S t p -- done properly in CheckGFCC
-
-
-mkLab k = LIdent (BS.pack ("_" ++ show k))
-
--- remove lock fields; in fact, any empty records and record types
-unlock = filter notlock where
- notlock (l,(_, t)) = case t of --- need not look at l
- R [] -> False
- RecType [] -> False
- _ -> True
-
-unlockTyp = filter notlock
-
-notlock (l, t) = case t of --- need not look at l
- RecType [] -> False
- _ -> True
-
-unlockTy ty = case ty of
- RecType ls -> RecType $ GM.sortRec [(l, unlockTy t) | (l,t) <- ls, notlock (l,t)]
- _ -> GM.composSafeOp unlockTy ty
-
-
-prtTrace tr n =
- trace (render (text "-- INTERNAL COMPILER ERROR" <+> A.ppTerm Unqualified 0 tr $$ text (show n))) n
-prTrace tr n = trace (render (text "-- OBSERVE" <+> A.ppTerm Unqualified 0 tr <+> text (show n) <+> text (show tr))) n
-
-
--- | this function finds out what modules are really needed in the canonical gr.
--- its argument is typically a concrete module name
-requiredCanModules :: (Ord i, Show i) => Bool -> M.MGrammar i a -> i -> [i]
-requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where
- exts = M.allExtends gr c
- ops = if isSingle
- then map fst (M.modules gr)
- else iterFix (concatMap more) $ exts
- more i = errVal [] $ do
- m <- M.lookupModule gr i
- return $ M.extends m ++ [o | o <- map M.openedModule (M.opens m)]
- notReuse i = errVal True $ do
- m <- M.lookupModule gr i
- return $ M.isModRes m -- to exclude reused Cnc and Abs from required
diff --git a/src/GF/Compile/ModDeps.hs b/src/GF/Compile/ModDeps.hs
deleted file mode 100644
index 1e689aabc..000000000
--- a/src/GF/Compile/ModDeps.hs
+++ /dev/null
@@ -1,145 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : ModDeps
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/11/11 23:24:34 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.14 $
---
--- Check correctness of module dependencies. Incomplete.
---
--- AR 13\/5\/2003
------------------------------------------------------------------------------
-
-module GF.Compile.ModDeps (mkSourceGrammar,
- moduleDeps,
- openInterfaces,
- requiredCanModules
- ) where
-
-import GF.Grammar.Grammar
-import GF.Infra.Ident
-import GF.Infra.Option
-import GF.Grammar.Printer
-import GF.Compile.Update
-import GF.Grammar.Lookup
-import GF.Infra.Modules
-
-import GF.Data.Operations
-
-import Control.Monad
-import Data.List
-
--- | to check uniqueness of module names and import names, the
--- appropriateness of import and extend types,
--- to build a dependency graph of modules, and to sort them topologically
-mkSourceGrammar :: [SourceModule] -> Err SourceGrammar
-mkSourceGrammar ms = do
- let ns = map fst ms
- checkUniqueErr ns
- mapM (checkUniqueImportNames ns . snd) ms
- deps <- moduleDeps ms
- deplist <- either
- return
- (\ms -> Bad $ "circular modules" +++ unwords (map show ms)) $
- topoTest deps
- return $ MGrammar [(m, maybe undefined id $ lookup m ms) | IdentM m _ <- deplist]
-
-checkUniqueErr :: (Show i, Eq i) => [i] -> Err ()
-checkUniqueErr ms = do
- let msg = checkUnique ms
- if null msg then return () else Bad $ unlines msg
-
--- | check that import names don't clash with module names
-checkUniqueImportNames :: [Ident] -> SourceModInfo -> Err ()
-checkUniqueImportNames ns mo = test [n | OQualif n v <- opens mo, n /= v]
- where
- test ms = testErr (all (`notElem` ns) ms)
- ("import names clashing with module names among" +++ unwords (map prt ms))
-
-type Dependencies = [(IdentM Ident,[IdentM Ident])]
-
--- | to decide what modules immediately depend on what, and check if the
--- dependencies are appropriate
-moduleDeps :: [SourceModule] -> Err Dependencies
-moduleDeps ms = mapM deps ms where
- deps (c,m) = errIn ("checking dependencies of module" +++ prt c) $ case mtype m of
- MTConcrete a -> do
- aty <- lookupModuleType gr a
- testErr (aty == MTAbstract) "the of-module is not an abstract syntax"
- chDep (IdentM c (MTConcrete a))
- (extends m) (MTConcrete a) (opens m) MTResource
- t -> chDep (IdentM c t) (extends m) t (opens m) t
-
- chDep it es ety os oty = do
- ests <- mapM (lookupModuleType gr) es
- testErr (all (compatMType ety) ests) "inappropriate extension module type"
----- osts <- mapM (lookupModuleType gr . openedModule) os
----- testErr (all (compatOType oty) osts) "inappropriate open module type"
- let ab = case it of
- IdentM _ (MTConcrete a) -> [IdentM a MTAbstract]
- _ -> [] ----
- return (it, ab ++
- [IdentM e ety | e <- es] ++
- [IdentM (openedModule o) oty | o <- os])
-
- -- check for superficial compatibility, not submodule relation etc: what can be extended
- compatMType mt0 mt = case (mt0,mt) of
- (MTResource, MTConcrete _) -> True
- (MTInstance _, MTConcrete _) -> True
- (MTInterface, MTAbstract) -> True
- (MTConcrete _, MTConcrete _) -> True
- (MTInstance _, MTInstance _) -> True
- (MTInstance _, MTResource) -> True
- (MTResource, MTInstance _) -> True
- ---- some more?
- _ -> mt0 == mt
- -- in the same way; this defines what can be opened
- compatOType mt0 mt = case mt0 of
- MTAbstract -> mt == MTAbstract
- _ -> case mt of
- MTResource -> True
- MTInterface -> True
- MTInstance _ -> True
- _ -> False
-
- gr = MGrammar ms --- hack
-
-openInterfaces :: Dependencies -> Ident -> Err [Ident]
-openInterfaces ds m = do
- let deps = [(i,ds) | (IdentM i _,ds) <- ds]
- let more (c,_) = [(i,mt) | Just is <- [lookup c deps], IdentM i mt <- is]
- let mods = iterFix (concatMap more) (more (m,undefined))
- return $ [i | (i,MTInterface) <- mods]
-
--- | this function finds out what modules are really needed in the canonical gr.
--- its argument is typically a concrete module name
-requiredCanModules :: (Ord i, Show i) => Bool -> MGrammar i a -> i -> [i]
-requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where
- exts = allExtends gr c
- ops = if isSingle
- then map fst (modules gr)
- else iterFix (concatMap more) $ exts
- more i = errVal [] $ do
- m <- lookupModule gr i
- return $ extends m ++ [o | o <- map openedModule (opens m)]
- notReuse i = errVal True $ do
- m <- lookupModule gr i
- return $ isModRes m -- to exclude reused Cnc and Abs from required
-
-
-{-
--- to test
-exampleDeps = [
- (ir "Nat",[ii "Gen", ir "Adj"]),
- (ir "Adj",[ii "Num", ii "Gen", ir "Nou"]),
- (ir "Nou",[ii "Cas"])
- ]
-
-ii s = IdentM (IC s) MTInterface
-ir s = IdentM (IC s) MTResource
--}
-
diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs
deleted file mode 100644
index 2c556b36f..000000000
--- a/src/GF/Compile/Optimize.hs
+++ /dev/null
@@ -1,228 +0,0 @@
-{-# LANGUAGE PatternGuards #-}
-----------------------------------------------------------------------
--- |
--- Module : Optimize
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/09/16 13:56:13 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.18 $
---
--- Top-level partial evaluation for GF source modules.
------------------------------------------------------------------------------
-
-module GF.Compile.Optimize (optimizeModule) where
-
-import GF.Grammar.Grammar
-import GF.Infra.Ident
-import GF.Infra.Modules
-import GF.Grammar.Printer
-import GF.Grammar.Macros
-import GF.Grammar.Lookup
-import GF.Grammar.Predef
-import GF.Compile.Refresh
-import GF.Compile.Concrete.Compute
-import GF.Compile.CheckGrammar
-import GF.Compile.Update
-
-import GF.Data.Operations
-import GF.Infra.CheckM
-import GF.Infra.Option
-
-import Control.Monad
-import Data.List
-import qualified Data.Set as Set
-import Text.PrettyPrint
-import Debug.Trace
-import qualified Data.ByteString.Char8 as BS
-
-
--- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
-
-optimizeModule :: Options -> [SourceModule] -> SourceModule -> Err SourceModule
-optimizeModule opts ms m@(name,mi)
- | mstatus mi == MSComplete = do
- ids <- topoSortJments m
- mi <- foldM updateEvalInfo mi ids
- return (name,mi)
- | otherwise = return m
- where
- oopts = opts `addOptions` flagsModule m
-
- updateEvalInfo mi (i,info) = do
- info' <- evalInfo oopts ms (name,mi) i info
- return (updateModule mi i info')
-
-evalInfo :: Options -> [SourceModule] -> SourceModule -> Ident -> Info -> Err Info
-evalInfo opts ms m c info = do
-
- (if verbAtLeast opts Verbose then trace (" " ++ showIdent c) else id) return ()
-
- errIn ("optimizing " ++ showIdent c) $ case info of
-
- CncCat ptyp pde ppr -> do
- pde' <- case (ptyp,pde) of
- (Just typ, Just de) -> do
- de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de
- return (Just (factor param c 0 de))
- (Just typ, Nothing) -> do
- de <- mkLinDefault gr typ
- de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de
- return (Just (factor param c 0 de))
- _ -> return pde -- indirection
-
- ppr' <- liftM Just $ evalPrintname gr c ppr (Just $ K $ showIdent c)
-
- return (CncCat ptyp pde' ppr')
-
- CncFun (mt@(Just (_,cont,val))) pde ppr -> --trace (prt c) $
- eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd cont val []) $$ text "of function") $ do
- pde' <- case pde of
- Just de -> do de <- partEval opts gr (cont,val) de
- return (Just (factor param c 0 de))
- Nothing -> return pde
- ppr' <- liftM Just $ evalPrintname gr c ppr pde'
- return $ CncFun mt pde' ppr' -- only cat in type actually needed
-
- ResOper pty pde
- | OptExpand `Set.member` optim -> do
- pde' <- case pde of
- Just de -> do de <- computeConcrete gr de
- return (Just (factor param c 0 de))
- Nothing -> return Nothing
- return $ ResOper pty pde'
-
- _ -> return info
- where
- gr = MGrammar (m : ms)
- optim = flag optOptimizations opts
- param = OptParametrize `Set.member` optim
- eIn cat = errIn (render (text "Error optimizing" <+> cat <+> ppIdent c <+> colon))
-
--- | the main function for compiling linearizations
-partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term
-partEval opts gr (context, val) trm = errIn (render (text "partial evaluation" <+> ppTerm Qualified 0 trm)) $ do
- let vars = map (\(bt,x,t) -> x) context
- args = map Vr vars
- subst = [(v, Vr v) | v <- vars]
- trm1 = mkApp trm args
- trm2 <- computeTerm gr subst trm1
- trm3 <- if rightType trm2
- then computeTerm gr subst trm2
- else recordExpand val trm2 >>= computeTerm gr subst
- return $ mkAbs [(Explicit,v) | v <- vars] trm3
- where
- -- don't eta expand records of right length (correct by type checking)
- rightType (R rs) = case val of
- RecType ts -> length rs == length ts
- _ -> False
- rightType _ = False
-
-
-
-
--- here we must be careful not to reduce
--- variants {{s = "Auto" ; g = N} ; {s = "Wagen" ; g = M}}
--- {s = variants {"Auto" ; "Wagen"} ; g = variants {N ; M}} ;
-
-recordExpand :: Type -> Term -> Err Term
-recordExpand typ trm = case typ of
- RecType tys -> case trm of
- FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs]
- _ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys]
- _ -> return trm
-
-
--- | auxiliaries for compiling the resource
-
-mkLinDefault :: SourceGrammar -> Type -> Err Term
-mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
- where
- mkDefField typ = case typ of
- Table p t -> do
- t' <- mkDefField t
- let T _ cs = mkWildCases t'
- return $ T (TWild p) cs
- Sort s | s == cStr -> return $ Vr varStr
- QC q p -> do vs <- lookupParamValues gr q p
- case vs of
- v:_ -> return v
- _ -> Bad (render (text "no parameter values given to type" <+> ppIdent p))
- RecType r -> do
- let (ls,ts) = unzip r
- ts <- mapM mkDefField ts
- return $ R (zipWith assign ls ts)
- _ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val
- _ -> Bad (render (text "linearization type field cannot be" <+> ppTerm Unqualified 0 typ))
-
--- | Form the printname: if given, compute. If not, use the computed
--- lin for functions, cat name for cats (dispatch made in evalCncDef above).
---- We cannot use linearization at this stage, since we do not know the
---- defaults we would need for question marks - and we're not yet in canon.
-evalPrintname :: SourceGrammar -> Ident -> Maybe Term -> Maybe Term -> Err Term
-evalPrintname gr c ppr lin =
- case ppr of
- Just pr -> comp pr
- Nothing -> case lin of
- Just t -> return $ K $ clean $ render (ppTerm Unqualified 0 (oneBranch t))
- Nothing -> return $ K $ showIdent c ----
- where
- comp = computeConcrete gr
-
- oneBranch t = case t of
- Abs _ _ b -> oneBranch b
- R (r:_) -> oneBranch $ snd $ snd r
- T _ (c:_) -> oneBranch $ snd c
- V _ (c:_) -> oneBranch c
- FV (t:_) -> oneBranch t
- C x y -> C (oneBranch x) (oneBranch y)
- S x _ -> oneBranch x
- P x _ -> oneBranch x
- Alts (d,_) -> oneBranch d
- _ -> t
-
- --- very unclean cleaner
- clean s = case s of
- '+':'+':' ':cs -> clean cs
- '"':cs -> clean cs
- c:cs -> c: clean cs
- _ -> s
-
-
--- do even more: factor parametric branches
-
-factor :: Bool -> Ident -> Int -> Term -> Term
-factor param c i t =
- case t of
- T (TComp ty) cs -> factors ty [(p, factor param c (i+1) v) | (p, v) <- cs]
- _ -> composSafeOp (factor param c i) t
- where
- factors ty pvs0
- | not param = V ty (map snd pvs0)
- factors ty [] = V ty []
- factors ty pvs0@[(p,v)] = V ty [v]
- factors ty pvs0@(pv:pvs) =
- let t = mkFun pv
- ts = map mkFun pvs
- in if all (==t) ts
- then T (TTyped ty) (mkCases t)
- else V ty (map snd pvs0)
-
- --- we hope this will be fresh and don't check... in GFC would be safe
- qvar = identC (BS.pack ("q_" ++ showIdent c ++ "__" ++ show i))
-
- mkFun (patt, val) = replace (patt2term patt) (Vr qvar) val
- mkCases t = [(PV qvar, t)]
-
--- we need to replace subterms
-replace :: Term -> Term -> Term -> Term
-replace old new trm =
- case trm of
- -- these are the important cases, since they can correspond to patterns
- QC _ _ | trm == old -> new
- App _ _ | trm == old -> new
- R _ | trm == old -> new
- App x y -> App (replace old new x) (replace old new y)
- _ -> composSafeOp (replace old new) trm
diff --git a/src/GF/Compile/OptimizeGFCC.hs b/src/GF/Compile/OptimizeGFCC.hs
deleted file mode 100644
index 2a218e1bb..000000000
--- a/src/GF/Compile/OptimizeGFCC.hs
+++ /dev/null
@@ -1,121 +0,0 @@
-module GF.Compile.OptimizeGFCC where
-
-import PGF.CId
-import PGF.Data
-import PGF.Macros
-
-import GF.Data.Operations
-
-import Data.List
-import qualified Data.Map as Map
-
-
--- back-end optimization:
--- suffix analysis followed by common subexpression elimination
-
-optPGF :: PGF -> PGF
-optPGF = cseOptimize . suffixOptimize
-
-suffixOptimize :: PGF -> PGF
-suffixOptimize = mapConcretes opt
- where
- opt cnc = cnc {
- lins = Map.map optTerm (lins cnc),
- lindefs = Map.map optTerm (lindefs cnc),
- printnames = Map.map optTerm (printnames cnc)
- }
-
-cseOptimize :: PGF -> PGF
-cseOptimize = mapConcretes subex
-
--- analyse word form lists into prefix + suffixes
--- suffix sets can later be shared by subex elim
-
-optTerm :: Term -> Term
-optTerm tr = case tr of
- R ts@(_:_:_) | all isK ts -> mkSuff $ optToks [s | K (KS s) <- ts]
- R ts -> R $ map optTerm ts
- P t v -> P (optTerm t) v
- _ -> tr
- where
- optToks ss = prf : suffs where
- prf = pref (head ss) (tail ss)
- suffs = map (drop (length prf)) ss
- pref cand ss = case ss of
- s1:ss2 -> if isPrefixOf cand s1 then pref cand ss2 else pref (init cand) ss
- _ -> cand
- isK t = case t of
- K (KS _) -> True
- _ -> False
- mkSuff ("":ws) = R (map (K . KS) ws)
- mkSuff (p:ws) = W p (R (map (K . KS) ws))
-
-
--- common subexpression elimination
-
----subex :: [(CId,Term)] -> [(CId,Term)]
-subex :: Concr -> Concr
-subex cnc = err error id $ do
- (tree,_) <- appSTM (getSubtermsMod cnc) (Map.empty,0)
- return $ addSubexpConsts tree cnc
-
-type TermList = Map.Map Term (Int,Int) -- number of occs, id
-type TermM a = STM (TermList,Int) a
-
-addSubexpConsts :: TermList -> Concr -> Concr
-addSubexpConsts tree cnc = cnc {
- opers = Map.fromList [(f,recomp f trm) | (f,trm) <- ops],
- lins = rec lins,
- lindefs = rec lindefs,
- printnames = rec printnames
- }
- where
- ops = [(fid id, trm) | (trm,(_,id)) <- Map.assocs tree]
- mkOne (f,trm) = (f, recomp f trm)
- recomp f t = case Map.lookup t tree of
- Just (_,id) | fid id /= f -> F $ fid id -- not to replace oper itself
- _ -> case t of
- R ts -> R $ map (recomp f) ts
- S ts -> S $ map (recomp f) ts
- W s t -> W s (recomp f t)
- P t p -> P (recomp f t) (recomp f p)
- _ -> t
- fid n = mkCId $ "_" ++ show n
- rec field = Map.fromAscList [(f,recomp f trm) | (f,trm) <- Map.assocs (field cnc)]
-
-
-getSubtermsMod :: Concr -> TermM TermList
-getSubtermsMod cnc = do
- mapM getSubterms (Map.assocs (lins cnc))
- mapM getSubterms (Map.assocs (lindefs cnc))
- mapM getSubterms (Map.assocs (printnames cnc))
- (tree0,_) <- readSTM
- return $ Map.filter (\ (nu,_) -> nu > 1) tree0
- where
- getSubterms (f,trm) = collectSubterms trm >> return ()
-
-collectSubterms :: Term -> TermM ()
-collectSubterms t = case t of
- R ts -> do
- mapM collectSubterms ts
- add t
- S ts -> do
- mapM collectSubterms ts
- add t
- W s u -> do
- collectSubterms u
- add t
- P p u -> do
- collectSubterms p
- collectSubterms u
- add t
- _ -> return ()
- where
- add t = do
- (ts,i) <- readSTM
- 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)
-
diff --git a/src/GF/Compile/PGFPretty.hs b/src/GF/Compile/PGFPretty.hs
deleted file mode 100644
index 679714db5..000000000
--- a/src/GF/Compile/PGFPretty.hs
+++ /dev/null
@@ -1,93 +0,0 @@
--- | Print a part of a PGF grammar on the human-readable format used in
--- the paper "PGF: A Portable Run-Time Format for Type-Theoretical Grammars".
-module GF.Compile.PGFPretty (prPGFPretty, prPMCFGPretty) where
-
-import PGF.CId
-import PGF.Data
-import PGF.Macros
-import PGF.PMCFG
-
-import GF.Data.Operations
-
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Text.PrettyPrint.HughesPJ
-
-
-prPGFPretty :: PGF -> String
-prPGFPretty pgf = render $ prAbs (abstract pgf) $$ prAll (prCnc (abstract pgf)) (concretes pgf)
-
-prPMCFGPretty :: PGF -> CId -> String
-prPMCFGPretty pgf lang = render $
- case lookParser pgf lang of
- Nothing -> empty
- Just pinfo -> text "language" <+> ppCId lang $$ ppPMCFG pinfo
-
-
-prAbs :: Abstr -> Doc
-prAbs a = prAll prCat (cats a) $$ prAll prFun (funs a)
-
-prCat :: CId -> [Hypo] -> Doc
-prCat c h | isLiteralCat c = empty
- | otherwise = text "cat" <+> ppCId c
-
-prFun :: CId -> (Type,Int,[Equation]) -> Doc
-prFun f (t,_,_) = text "fun" <+> ppCId f <+> text ":" <+> prType t
-
-prType :: Type -> Doc
-prType t = parens (hsep (punctuate (text ",") (map ppCId cs))) <+> text "->" <+> ppCId c
- where (cs,c) = catSkeleton t
-
-
--- FIXME: show concrete name
--- FIXME: inline opers first
-prCnc :: Abstr -> CId -> Concr -> Doc
-prCnc abstr name c = prAll prLinCat (lincats c) $$ prAll prLin (lins (expand c))
- where
- prLinCat :: CId -> Term -> Doc
- prLinCat c t | isLiteralCat c = empty
- | otherwise = text "lincat" <+> ppCId c <+> text "=" <+> pr 0 t
- where
- pr p (R ts) = prec p 1 (hsep (punctuate (text " *") (map (pr 1) ts)))
- pr _ (S []) = text "Str"
- pr _ (C n) = text "Int_" <> text (show (n+1))
-
- prLin :: CId -> Term -> Doc
- prLin f t = text "lin" <+> ppCId f <+> text "=" <+> pr 0 t
- where
- pr :: Int -> Term -> Doc
- pr p (R ts) = text "<" <+> hsep (punctuate (text ",") (map (pr 0) ts)) <+> text ">"
- pr p (P t1 t2) = prec p 3 (pr 3 t1 <> text "!" <> pr 3 t2)
- pr p (S ts) = prec p 2 (hsep (punctuate (text " ++") (map (pr 2) ts)))
- pr p (K (KS t)) = doubleQuotes (text t)
- pr p (V i) = text ("argv_" ++ show (i+1))
- pr p (C i) = text (show (i+1))
- pr p (FV ts) = prec p 1 (hsep (punctuate (text " |") (map (pr 1) ts)))
- pr _ t = error $ "PGFPretty.prLin " ++ show t
-
-linCat :: Concr -> CId -> Term
-linCat cnc c = Map.findWithDefault (error $ "lincat: " ++ showCId c) c (lincats cnc)
-
-prec :: Int -> Int -> Doc -> Doc
-prec p m | p >= m = parens
- | otherwise = id
-
-expand :: Concr -> Concr
-expand cnc = cnc { lins = Map.map (f "") (lins cnc) }
- where
- -- FIXME: handle KP
- f :: String -> Term -> Term
- f w (R ts) = R (map (f w) ts)
- f w (P t1 t2) = P (f w t1) (f w t2)
- f w (S []) = S (if null w then [] else [K (KS w)])
- f w (S (t:ts)) = S (f w t : map (f "") ts)
- f w (FV ts) = FV (map (f w) ts)
- f w (W s t) = f (w++s) t
- f w (K (KS t)) = K (KS (w++t))
- f w (F o) = f w (Map.findWithDefault (error $ "Bad oper: " ++ showCId o) o (opers cnc))
- f w t = t
-
--- Utilities
-
-prAll :: (a -> b -> Doc) -> Map a b -> Doc
-prAll p m = vcat [ p k v | (k,v) <- Map.toList m] \ No newline at end of file
diff --git a/src/GF/Compile/ReadFiles.hs b/src/GF/Compile/ReadFiles.hs
deleted file mode 100644
index b96d3127b..000000000
--- a/src/GF/Compile/ReadFiles.hs
+++ /dev/null
@@ -1,220 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : ReadFiles
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/11/11 23:24:34 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.26 $
---
--- Decide what files to read as function of dependencies and time stamps.
---
--- make analysis for GF grammar modules. AR 11\/6\/2003--24\/2\/2004
---
--- to find all files that have to be read, put them in dependency order, and
--- decide which files need recompilation. Name @file.gf@ is returned for them,
--- and @file.gfo@ otherwise.
------------------------------------------------------------------------------
-
-module GF.Compile.ReadFiles
- ( getAllFiles,ModName,ModEnv,importsOfModule,
- gfoFile,gfFile,isGFO,gf2gfo,
- getOptionsFromFile) where
-
-import GF.Infra.UseIO
-import GF.Infra.Option
-import GF.Infra.Ident
-import GF.Infra.Modules
-import GF.Data.Operations
-import GF.Grammar.Lexer
-import GF.Grammar.Parser
-import GF.Grammar.Grammar
-import GF.Grammar.Binary
-
-import Control.Monad
-import Data.Char
-import Data.List
-import Data.Maybe(isJust)
-import qualified Data.ByteString.Char8 as BS
-import qualified Data.Map as Map
-import System.Time
-import System.Directory
-import System.FilePath
-import Text.PrettyPrint
-
-type ModName = String
-type ModEnv = Map.Map ModName (ClockTime,[ModName])
-
-
--- | Returns a list of all files to be compiled in topological order i.e.
--- the low level (leaf) modules are first.
-getAllFiles :: Options -> [InitPath] -> ModEnv -> FileName -> IOE [FullPath]
-getAllFiles opts ps env file = do
- -- read module headers from all files recursively
- ds <- liftM reverse $ get [] [] (justModuleName file)
- ioeIO $ putIfVerb opts $ "all modules:" +++ show [name | (name,_,_,_,_) <- ds]
- return $ paths ds
- where
- -- construct list of paths to read
- paths ds = concatMap mkFile ds
- where
- mkFile (f,st,gfTime,gfoTime,p) =
- case st of
- CSComp -> [p </> gfFile f]
- CSRead | isJust gfTime -> [gf2gfo opts (p </> gfFile f)]
- | otherwise -> [p </> gfoFile f]
- CSEnv -> []
-
- -- | traverses the dependency graph and returns a topologicaly sorted
- -- list of ModuleInfo. An error is raised if there is circular dependency
- get :: [ModName] -- ^ keeps the current path in the dependency graph to avoid cycles
- -> [ModuleInfo] -- ^ a list of already traversed modules
- -> ModName -- ^ the current module
- -> IOE [ModuleInfo] -- ^ the final
- get trc ds name
- | name `elem` trc = ioeErr $ Bad $ "circular modules" +++ unwords trc
- | (not . null) [n | (n,_,_,_,_) <- ds, name == n] --- file already read
- = return ds
- | otherwise = do
- (name,st0,t0,imps,p) <- findModule name
- ds <- foldM (get (name:trc)) ds imps
- let (st,t) | (not . null) [f | (f,_,t1,_,_) <- ds, elem f imps && liftM2 (>=) t0 t1 /= Just True]
- = (CSComp,Nothing)
- | otherwise = (st0,t0)
- return ((name,st,t,imps,p):ds)
-
- -- searches for module in the search path and if it is found
- -- returns 'ModuleInfo'. It fails if there is no such module
- findModule :: ModName -> IOE ModuleInfo
- findModule name = do
- (file,gfTime,gfoTime) <- do
- mb_gfFile <- ioeIO $ getFilePath ps (gfFile name)
- case mb_gfFile of
- Just gfFile -> do gfTime <- ioeIO $ getModificationTime gfFile
- mb_gfoTime <- ioeIO $ catch (liftM Just $ getModificationTime (gf2gfo opts gfFile))
- (\_->return Nothing)
- return (gfFile, Just gfTime, mb_gfoTime)
- Nothing -> do mb_gfoFile <- ioeIO $ getFilePath (maybe id (:) (flag optGFODir opts) ps) (gfoFile name)
- case mb_gfoFile of
- Just gfoFile -> do gfoTime <- ioeIO $ getModificationTime gfoFile
- return (gfoFile, Nothing, Just gfoTime)
- Nothing -> ioeErr $ Bad (render (text "File" <+> text (gfFile name) <+> text "does not exist." $$
- text "searched in:" <+> vcat (map text ps)))
-
-
- let mb_envmod = Map.lookup name env
- (st,t) = selectFormat opts (fmap fst mb_envmod) gfTime gfoTime
-
- (mname,imps) <- case st of
- CSEnv -> return (name, maybe [] snd mb_envmod)
- CSRead -> ioeIO $ fmap importsOfModule (decodeModHeader ((if isGFO file then id else gf2gfo opts) file))
- CSComp -> do s <- ioeIO $ BS.readFile file
- case runP pModHeader s of
- Left (Pn l c,msg) -> ioeBad (file ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg)
- Right mo -> return (importsOfModule mo)
- ioeErr $ testErr (mname == name)
- ("module name" +++ mname +++ "differs from file name" +++ name)
- return (name,st,t,imps,dropFileName file)
-
-isGFO :: FilePath -> Bool
-isGFO = (== ".gfo") . takeExtensions
-
-gfoFile :: FilePath -> FilePath
-gfoFile f = addExtension f "gfo"
-
-gfFile :: FilePath -> FilePath
-gfFile f = addExtension f "gf"
-
-gf2gfo :: Options -> FilePath -> FilePath
-gf2gfo opts file = maybe (gfoFile (dropExtension file))
- (\dir -> dir </> gfoFile (dropExtension (takeFileName file)))
- (flag optGFODir opts)
-
--- From the given Options and the time stamps computes
--- whether the module have to be computed, read from .gfo or
--- the environment version have to be used
-selectFormat :: Options -> Maybe ClockTime -> Maybe ClockTime -> Maybe ClockTime -> (CompStatus,Maybe ClockTime)
-selectFormat opts mtenv mtgf mtgfo =
- case (mtenv,mtgfo,mtgf) of
- (_,_,Just tgf) | fromSrc -> (CSComp,Nothing)
- (Just tenv,_,_) | fromComp -> (CSEnv, Just tenv)
- (_,Just tgfo,_) | fromComp -> (CSRead,Just tgfo)
- (Just tenv,_,Just tgf) | tenv > tgf -> (CSEnv, Just tenv)
- (_,Just tgfo,Just tgf) | tgfo > tgf -> (CSRead,Just tgfo)
- (Just tenv,_,Nothing) -> (CSEnv,Just tenv) -- source does not exist
- (_,Just tgfo,Nothing) -> (CSRead,Just tgfo) -- source does not exist
- _ -> (CSComp,Nothing)
- where
- fromComp = flag optRecomp opts == NeverRecomp
- fromSrc = flag optRecomp opts == AlwaysRecomp
-
-
--- internal module dep information
-
-
-data CompStatus =
- CSComp -- compile: read gf
- | CSRead -- read gfo
- | CSEnv -- gfo is in env
- deriving Eq
-
-type ModuleInfo = (ModName,CompStatus,Maybe ClockTime,[ModName],InitPath)
-
-importsOfModule :: SourceModule -> (ModName,[ModName])
-importsOfModule (m,mi) = (modName m,depModInfo mi [])
- where
- depModInfo mi =
- depModType (mtype mi) .
- depExtends (extend mi) .
- depWith (mwith mi) .
- depExDeps (mexdeps mi).
- depOpens (opens mi)
-
- depModType (MTAbstract) xs = xs
- depModType (MTResource) xs = xs
- depModType (MTInterface) xs = xs
- depModType (MTConcrete m2) xs = modName m2:xs
- depModType (MTInstance m2) xs = modName m2:xs
-
- depExtends es xs = foldr depInclude xs es
-
- depWith (Just (m,_,is)) xs = modName m : depInsts is xs
- depWith Nothing xs = xs
-
- depExDeps eds xs = map modName eds ++ xs
-
- depOpens os xs = foldr depOpen xs os
-
- depInsts is xs = foldr depInst xs is
-
- depInclude (m,_) xs = modName m:xs
-
- depOpen (OSimple n ) xs = modName n:xs
- depOpen (OQualif _ n) xs = modName n:xs
-
- depInst (m,n) xs = modName m:modName n:xs
-
- modName = showIdent
-
--- | options can be passed to the compiler by comments in @--#@, in the main file
-getOptionsFromFile :: FilePath -> IOE Options
-getOptionsFromFile file = do
- s <- ioe $ catch (fmap Ok $ BS.readFile file)
- (\_ -> return (Bad $ "File " ++ file ++ " does not exist"))
- let ls = filter (BS.isPrefixOf (BS.pack "--#")) $ BS.lines s
- fs = map (BS.unpack . BS.unwords . BS.words . BS.drop 3) ls
- ioeErr $ parseModuleOptions fs
-
-getFilePath :: [FilePath] -> String -> IO (Maybe FilePath)
-getFilePath paths file = get paths
- where
- get [] = return Nothing
- get (p:ps) = do
- let pfile = p </> file
- exist <- doesFileExist pfile
- if not exist
- then get ps
- else do pfile <- canonicalizePath pfile
- return (Just pfile)
diff --git a/src/GF/Compile/Refresh.hs b/src/GF/Compile/Refresh.hs
deleted file mode 100644
index 04800fcce..000000000
--- a/src/GF/Compile/Refresh.hs
+++ /dev/null
@@ -1,133 +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 (refreshTerm, refreshTermN,
- refreshModule
- ) where
-
-import GF.Data.Operations
-import GF.Grammar.Grammar
-import GF.Infra.Ident
-import GF.Infra.Modules
-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)
-
- _ -> 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 q c ps -> liftM (PP q 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,[SourceModule]) -> SourceModule -> Err (Int,[SourceModule])
-refreshModule (k,ms) mi@(i,mo)
- | isModCnc mo || isModRes mo = do
- (k',js') <- foldM refreshRes (k,[]) $ tree2list $ jments mo
- return (k', (i, replaceJudgements mo (buildTree js')) : ms)
- | otherwise = return (k, mi:ms)
- where
- refreshRes (k,cs) ci@(c,info) = case info of
- ResOper ptyp (Just trm) -> do ---- refresh ptyp
- (k',trm') <- refreshTermKN k trm
- return $ (k', (c, ResOper ptyp (Just trm')):cs)
- ResOverload os tyts -> do
- (k',tyts') <- liftM (\ (t,(_,i)) -> (i,t)) $
- appSTM (mapPairsM refresh tyts) (initIdStateN k)
- return $ (k', (c, ResOverload os tyts'):cs)
- CncCat mt (Just trm) pn -> do ---- refresh mt, pn
- (k',trm') <- refreshTermKN k trm
- return $ (k', (c, CncCat mt (Just trm') pn):cs)
- CncFun mt (Just trm) pn -> do ---- refresh pn
- (k',trm') <- refreshTermKN k trm
- return $ (k', (c, CncFun mt (Just trm') pn):cs)
- _ -> return (k, ci:cs)
-
diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs
deleted file mode 100644
index 30616b4cb..000000000
--- a/src/GF/Compile/Rename.hs
+++ /dev/null
@@ -1,313 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Rename
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/05/30 18:39:44 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.19 $
---
--- AR 14\/5\/2003
--- The top-level function 'renameGrammar' does several things:
---
--- - extends each module symbol table by indirections to extended module
---
--- - changes unqualified and as-qualified imports to absolutely qualified
---
--- - goes through the definitions and resolves names
---
--- Dependency analysis between modules has been performed before this pass.
--- Hence we can proceed by @fold@ing "from left to right".
------------------------------------------------------------------------------
-
-module GF.Compile.Rename (
- renameSourceTerm,
- renameModule
- ) where
-
-import GF.Grammar.Grammar
-import GF.Grammar.Values
-import GF.Grammar.Predef
-import GF.Infra.Modules
-import GF.Infra.Ident
-import GF.Infra.CheckM
-import GF.Grammar.Macros
-import GF.Grammar.Printer
-import GF.Grammar.Lookup
-import GF.Grammar.Printer
-import GF.Data.Operations
-
-import Control.Monad
-import Data.List (nub)
-import Text.PrettyPrint
-
--- | this gives top-level access to renaming term input in the cc command
-renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term
-renameSourceTerm g m t = do
- mo <- checkErr $ lookupModule g m
- status <- buildStatus g m mo
- renameTerm status [] t
-
-renameModule :: [SourceModule] -> SourceModule -> Check SourceModule
-renameModule ms (name,mo) = checkIn (text "renaming module" <+> ppIdent name) $ do
- let js1 = jments mo
- status <- buildStatus (MGrammar ms) name mo
- js2 <- checkMap (renameInfo mo status) js1
- return (name, mo {opens = map forceQualif (opens mo), jments = js2})
-
-type Status = (StatusTree, [(OpenSpec Ident, StatusTree)])
-
-type StatusTree = BinTree Ident StatusInfo
-
-type StatusInfo = Ident -> Term
-
-renameIdentTerm :: Status -> Term -> Check Term
-renameIdentTerm env@(act,imps) t =
- checkIn (text "atomic term" <+> ppTerm Qualified 0 t $$ text "given" <+> hsep (punctuate comma (map (ppIdent . fst) qualifs))) $
- case t of
- Vr c -> ident predefAbs c
- Cn c -> ident (\_ s -> checkError s) c
- Q m' c | m' == cPredef {- && isInPredefined c -} -> return t
- Q m' c -> do
- m <- checkErr (lookupErr m' qualifs)
- f <- lookupTree showIdent c m
- return $ f c
- QC m' c | m' == cPredef {- && isInPredefined c -} -> return t
- QC m' c -> do
- m <- checkErr (lookupErr m' qualifs)
- f <- lookupTree showIdent c m
- return $ f c
- _ -> return t
- where
- opens = [st | (OSimple _,st) <- imps]
- qualifs = [(m, st) | (OQualif m _, st) <- imps] ++
- [(m, st) | (OSimple m, st) <- imps] -- qualif is always possible
-
- -- this facility is mainly for BWC with GF1: you need not import PredefAbs
- predefAbs c s
- | isPredefCat c = return $ Q cPredefAbs c
- | otherwise = checkError s
-
- ident alt c = case lookupTree showIdent c act of
- Ok f -> return $ f c
- _ -> case lookupTreeManyAll showIdent opens c of
- [f] -> return $ f c
- [] -> alt c (text "constant not found:" <+> ppIdent c)
- fs -> case nub [f c | f <- fs] of
- [tr] -> return tr
- ts@(t:_) -> do checkWarn (text "conflict" <+> hsep (punctuate comma (map (ppTerm Qualified 0) ts)))
- return t
- -- a warning will be generated in CheckGrammar, and the head returned
- -- in next V:
- -- Bad $ "conflicting imports:" +++ unwords (map prt ts)
-
-info2status :: Maybe Ident -> (Ident,Info) -> StatusInfo
-info2status mq (c,i) = case i of
- AbsFun _ _ Nothing -> maybe Con QC mq
- ResValue _ -> maybe Con QC mq
- ResParam _ _ -> maybe Con QC mq
- AnyInd True m -> maybe Con (const (QC m)) mq
- AnyInd False m -> maybe Cn (const (Q m)) mq
- _ -> maybe Cn Q mq
-
-tree2status :: OpenSpec Ident -> BinTree Ident Info -> BinTree Ident StatusInfo
-tree2status o = case o of
- OSimple i -> mapTree (info2status (Just i))
- OQualif i j -> mapTree (info2status (Just j))
-
-buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Check Status
-buildStatus gr c mo = let mo' = self2status c mo in do
- let gr1 = MGrammar ((c,mo) : modules gr)
- ops = [OSimple e | e <- allExtends gr1 c] ++ opens mo
- mods <- checkErr $ mapM (lookupModule gr1 . openedModule) ops
- let sts = map modInfo2status $ zip ops mods
- return $ if isModCnc mo
- then (emptyBinTree, reverse sts) -- the module itself does not define any names
- else (mo',reverse sts) -- so the empty ident is not needed
-
-modInfo2status :: (OpenSpec Ident,SourceModInfo) -> (OpenSpec Ident, StatusTree)
-modInfo2status (o,mo) = (o,tree2status o (jments mo))
-
-self2status :: Ident -> SourceModInfo -> StatusTree
-self2status c m = mapTree (info2status (Just c)) (jments m)
-
-forceQualif o = case o of
- OSimple i -> OQualif i i
- OQualif _ i -> OQualif i i
-
-renameInfo :: SourceModInfo -> Status -> Ident -> Info -> Check Info
-renameInfo mo status i info = checkIn
- (text "renaming definition of" <+> ppIdent i <+> ppPosition mo i) $
- case info of
- AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco)
- (renPerh (mapM rent) pfs)
- AbsFun pty pa ptr -> liftM3 AbsFun (ren pty) (return pa) (renPerh (mapM (renameEquation status [])) ptr)
- ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr)
- ResOverload os tysts ->
- liftM (ResOverload os) (mapM (pairM rent) tysts)
-
- ResParam (Just pp) m -> do
- pp' <- mapM (renameParam status) pp
- return (ResParam (Just pp') m)
- ResValue t -> do
- t <- rent t
- return (ResValue t)
- CncCat pty ptr ppr -> liftM3 CncCat (ren pty) (ren ptr) (ren ppr)
- CncFun mt ptr ppr -> liftM2 (CncFun mt) (ren ptr) (ren ppr)
- _ -> return info
- where
- ren = renPerh rent
- rent = renameTerm status []
-
-renPerh ren (Just t) = liftM Just $ ren t
-renPerh ren Nothing = return Nothing
-
-renameTerm :: Status -> [Ident] -> Term -> Check Term
-renameTerm env vars = ren vars where
- ren vs trm = case trm of
- Abs b x t -> liftM (Abs b x) (ren (x:vs) t)
- Prod bt x a b -> liftM2 (Prod bt x) (ren vs a) (ren (x:vs) b)
- Typed a b -> liftM2 Typed (ren vs a) (ren vs b)
- Vr x
- | elem x vs -> return trm
- | otherwise -> renid trm
- Cn _ -> renid trm
- Con _ -> renid trm
- Q _ _ -> renid trm
- QC _ _ -> renid trm
- T i cs -> do
- i' <- case i of
- TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source
- _ -> return i
- liftM (T i') $ mapM (renCase vs) cs
-
- Let (x,(m,a)) b -> do
- m' <- case m of
- Just ty -> liftM Just $ ren vs ty
- _ -> return m
- a' <- ren vs a
- b' <- ren (x:vs) b
- return $ Let (x,(m',a')) b'
-
- P t@(Vr r) l -- Here we have $r.l$ and this is ambiguous it could be either
- -- record projection from variable or constant $r$ or qualified expression with module $r$
- | elem r vs -> return trm -- try var proj first ..
- | otherwise -> checks [ renid (Q r (label2ident l)) -- .. and qualified expression second.
- , renid t >>= \t -> return (P t l) -- try as a constant at the end
- , checkError (text "unknown qualified constant" <+> ppTerm Unqualified 0 trm)
- ]
-
- EPatt p -> do
- (p',_) <- renpatt p
- return $ EPatt p'
-
- _ -> composOp (ren vs) trm
-
- renid = renameIdentTerm env
- renCase vs (p,t) = do
- (p',vs') <- renpatt p
- t' <- ren (vs' ++ vs) t
- return (p',t')
- renpatt = renamePattern env
-
--- | vars not needed in env, since patterns always overshadow old vars
-renamePattern :: Status -> Patt -> Check (Patt,[Ident])
-renamePattern env patt = case patt of
-
- PMacro c -> do
- c' <- renid $ Vr c
- case c' of
- Q p d -> renp $ PM p d
- _ -> checkError (text "unresolved pattern" <+> ppPatt Unqualified 0 patt)
-
- PC c ps -> do
- c' <- renid $ Cn c
- case c' of
- QC m c -> do psvss <- mapM renp ps
- let (ps,vs) = unzip psvss
- return (PP m c ps, concat vs)
- Q _ _ -> checkError (text "data constructor expected but" <+> ppTerm Qualified 0 c' <+> text "is found instead")
- _ -> checkError (text "unresolved data constructor" <+> ppTerm Qualified 0 c')
-
- PP p c ps -> do
- (QC p' c') <- renid (QC p c)
- psvss <- mapM renp ps
- let (ps',vs) = unzip psvss
- return (PP p' c' ps', concat vs)
-
- PM p c -> do
- x <- renid (Q p c)
- (p',c') <- case x of
- (Q p' c') -> return (p',c')
- _ -> checkError (text "not a pattern macro" <+> ppPatt Qualified 0 patt)
- return (PM p' c', [])
-
- PV x -> checks [ renid (Vr x) >>= \t' -> case t' of
- QC m c -> return (PP m c [],[])
- _ -> checkError (text "not a constructor")
- , return (patt, [x])
- ]
-
- PR r -> do
- let (ls,ps) = unzip r
- psvss <- mapM renp ps
- let (ps',vs') = unzip psvss
- return (PR (zip ls ps'), concat vs')
-
- PAlt p q -> do
- (p',vs) <- renp p
- (q',ws) <- renp q
- return (PAlt p' q', vs ++ ws)
-
- PSeq p q -> do
- (p',vs) <- renp p
- (q',ws) <- renp q
- return (PSeq p' q', vs ++ ws)
-
- PRep p -> do
- (p',vs) <- renp p
- return (PRep p', vs)
-
- PNeg p -> do
- (p',vs) <- renp p
- return (PNeg p', vs)
-
- PAs x p -> do
- (p',vs) <- renp p
- return (PAs x p', x:vs)
-
- _ -> return (patt,[])
-
- where
- renp = renamePattern env
- renid = renameIdentTerm env
-
-renameParam :: Status -> (Ident, Context) -> Check (Ident, Context)
-renameParam env (c,co) = do
- co' <- renameContext env co
- return (c,co')
-
-renameContext :: Status -> Context -> Check Context
-renameContext b = renc [] where
- renc vs cont = case cont of
- (bt,x,t) : xts
- | isWildIdent x -> do
- t' <- ren vs t
- xts' <- renc vs xts
- return $ (bt,x,t') : xts'
- | otherwise -> do
- t' <- ren vs t
- let vs' = x:vs
- xts' <- renc vs' xts
- return $ (bt,x,t') : xts'
- _ -> return cont
- ren = renameTerm b
-
--- | vars not needed in env, since patterns always overshadow old vars
-renameEquation :: Status -> [Ident] -> Equation -> Check Equation
-renameEquation b vs (ps,t) = do
- (ps',vs') <- liftM unzip $ mapM (renamePattern b) ps
- t' <- renameTerm b (concat vs' ++ vs) t
- return (ps',t')
diff --git a/src/GF/Compile/SubExOpt.hs b/src/GF/Compile/SubExOpt.hs
deleted file mode 100644
index c7dbb5d3d..000000000
--- a/src/GF/Compile/SubExOpt.hs
+++ /dev/null
@@ -1,142 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : SubExOpt
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- This module implements a simple common subexpression elimination
--- for .gfo grammars, to factor out shared subterms in lin rules.
--- It works in three phases:
---
--- (1) collectSubterms collects recursively all subterms of forms table and (P x..y)
--- from lin definitions (experience shows that only these forms
--- tend to get shared) and counts how many times they occur
--- (2) addSubexpConsts takes those subterms t that occur more than once
--- and creates definitions of form "oper A''n = t" where n is a
--- fresh number; notice that we assume no ids of this form are in
--- scope otherwise
--- (3) elimSubtermsMod goes through lins and the created opers by replacing largest
--- possible subterms by the newly created identifiers
---
------------------------------------------------------------------------------
-
-module GF.Compile.SubExOpt (subexpModule,unsubexpModule) where
-
-import GF.Grammar.Grammar
-import GF.Grammar.Lookup
-import GF.Infra.Ident
-import qualified GF.Grammar.Macros as C
-import qualified GF.Infra.Modules as M
-import GF.Data.Operations
-
-import Control.Monad
-import Data.Map (Map)
-import qualified Data.Map as Map
-import qualified Data.ByteString.Char8 as BS
-import Data.List
-
-subexpModule :: SourceModule -> SourceModule
-subexpModule (n,mo) = errVal (n,mo) $ do
- let ljs = tree2list (M.jments mo)
- (tree,_) <- appSTM (getSubtermsMod n ljs) (Map.empty,0)
- js2 <- liftM buildTree $ addSubexpConsts n tree $ ljs
- return (n,M.replaceJudgements mo js2)
-
-unsubexpModule :: SourceModule -> SourceModule
-unsubexpModule sm@(i,mo)
- | hasSub ljs = (i,M.replaceJudgements mo (rebuild (map unparInfo ljs)))
- | otherwise = sm
- where
- ljs = tree2list (M.jments mo)
-
- -- perform this iff the module has opers
- hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs]
- unparInfo (c,info) = case info of
- CncFun xs (Just t) m -> [(c, CncFun xs (Just (unparTerm t)) m)]
- ResOper (Just (EInt 8)) _ -> [] -- subexp-generated opers
- ResOper pty (Just t) -> [(c, ResOper pty (Just (unparTerm t)))]
- _ -> [(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
- _ -> C.composSafeOp unparTerm t
- gr = M.MGrammar [sm]
- rebuild = buildTree . concat
-
--- implementation
-
-type TermList = Map Term (Int,Int) -- number of occs, id
-type TermM a = STM (TermList,Int) a
-
-addSubexpConsts ::
- Ident -> Map Term (Int,Int) -> [(Ident,Info)] -> Err [(Ident,Info)]
-addSubexpConsts mo tree lins = do
- let opers = [oper id trm | (trm,(_,id)) <- list]
- mapM mkOne $ opers ++ lins
- where
- mkOne (f,def) = case def of
- CncFun xs (Just trm) pn -> do
- trm' <- recomp f trm
- return (f,CncFun xs (Just trm') pn)
- ResOper ty (Just trm) -> do
- trm' <- recomp f trm
- return (f,ResOper ty (Just trm'))
- _ -> return (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
-
- list = Map.toList tree
-
- oper id trm = (operIdent id, ResOper (Just (EInt 8)) (Just trm))
- --- impossible type encoding generated opers
-
-getSubtermsMod :: Ident -> [(Ident,Info)] -> TermM (Map Term (Int,Int))
-getSubtermsMod mo js = do
- mapM (getInfo (collectSubterms mo)) js
- (tree0,_) <- readSTM
- return $ Map.filter (\ (nu,_) -> nu > 1) tree0
- where
- getInfo get fi@(f,i) = case i of
- CncFun xs (Just trm) pn -> do
- get trm
- return $ fi
- ResOper ty (Just trm) -> do
- get trm
- return $ fi
- _ -> return fi
-
-collectSubterms :: Ident -> Term -> TermM Term
-collectSubterms mo t = case t of
- App f a -> do
- collect f
- collect a
- add t
- T ty cs -> do
- let (_,ts) = unzip cs
- mapM collect ts
- add t
- V ty ts -> do
- mapM collect ts
- add t
----- K (KP _ _) -> add t
- _ -> C.composOp (collectSubterms mo) t
- where
- collect = collectSubterms mo
- add t = do
- (ts,i) <- readSTM
- 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)
- return t --- only because of composOp
-
-operIdent :: Int -> Ident
-operIdent i = identC (operPrefix `BS.append` (BS.pack (show i))) ---
-
-isOperIdent :: Ident -> Bool
-isOperIdent id = BS.isPrefixOf operPrefix (ident2bs id)
-
-operPrefix = BS.pack ("A''")
diff --git a/src/GF/Compile/Update.hs b/src/GF/Compile/Update.hs
deleted file mode 100644
index 1e39a2e03..000000000
--- a/src/GF/Compile/Update.hs
+++ /dev/null
@@ -1,226 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Update
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/05/30 18:39:44 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.8 $
---
--- (Description of the module)
------------------------------------------------------------------------------
-
-module GF.Compile.Update (buildAnyTree, extendModule, rebuildModule) where
-
-import GF.Infra.Ident
-import GF.Grammar.Grammar
-import GF.Grammar.Printer
-import GF.Grammar.Lookup
-import GF.Infra.Modules
-import GF.Infra.Option
-
-import GF.Data.Operations
-
-import Data.List
-import qualified Data.Map as Map
-import Control.Monad
-import Text.PrettyPrint
-
--- | combine a list of definitions into a balanced binary search tree
-buildAnyTree :: Ident -> [(Ident,Info)] -> Err (BinTree Ident Info)
-buildAnyTree m = go Map.empty
- where
- go map [] = return map
- go map ((c,j):is) = do
- case Map.lookup c map of
- Just i -> case unifyAnyInfo m i j of
- Ok k -> go (Map.insert c k map) is
- Bad _ -> fail $ render (text "cannot unify the informations" $$
- nest 4 (ppJudgement Qualified (c,i)) $$
- text "and" $+$
- nest 4 (ppJudgement Qualified (c,j)) $$
- text "in module" <+> ppIdent m)
- Nothing -> go (Map.insert c j map) is
-
-extendModule :: SourceGrammar -> SourceModule -> Err SourceModule
-extendModule gr (name,m)
- ---- Just to allow inheritance in incomplete concrete (which are not
- ---- compiled anyway), extensions are not built for them.
- ---- Should be replaced by real control. AR 4/2/2005
- | mstatus m == MSIncomplete && isModCnc m = return (name,m)
- | otherwise = do m' <- foldM extOne m (extend m)
- return (name,m')
- where
- extOne mo (n,cond) = do
- m0 <- lookupModule gr n
-
- -- test that the module types match, and find out if the old is complete
- testErr (sameMType (mtype m) (mtype mo))
- ("illegal extension type to module" +++ showIdent name)
-
- let isCompl = isCompleteModule m0
-
- -- build extension in a way depending on whether the old module is complete
- js1 <- extendMod gr isCompl (n, isInherited cond) name (jments m0) (jments mo)
-
- -- if incomplete, throw away extension information
- return $
- if isCompl
- then mo {jments = js1}
- else mo {extend = filter ((/=n) . fst) (extend mo)
- ,mexdeps= nub (n : mexdeps mo)
- ,jments = js1
- }
-
--- | rebuilding instance + interface, and "with" modules, prior to renaming.
--- AR 24/10/2003
-rebuildModule :: SourceGrammar -> SourceModule -> Err SourceModule
-rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do
----- deps <- moduleDeps ms
----- is <- openInterfaces deps i
- let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005
- mi' <- case mw of
-
- -- add the information given in interface into an instance module
- Nothing -> do
- testErr (null is || mstatus mi == MSIncomplete)
- ("module" +++ showIdent i +++
- "has open interfaces and must therefore be declared incomplete")
- case mt of
- MTInstance i0 -> do
- m1 <- lookupModule gr i0
- testErr (isModRes m1) ("interface expected instead of" +++ showIdent i0)
- js' <- extendMod gr False (i0,const True) i (jments m1) (jments mi)
- --- to avoid double inclusions, in instance I of I0 = J0 ** ...
- case extends mi of
- [] -> return $ replaceJudgements mi js'
- j0s -> do
- m0s <- mapM (lookupModule gr) j0s
- let notInM0 c _ = all (not . isInBinTree c . jments) m0s
- let js2 = filterBinTree notInM0 js'
- return $ (replaceJudgements mi js2)
- {positions = Map.union (positions m1) (positions mi)}
- _ -> return mi
-
- -- add the instance opens to an incomplete module "with" instances
- Just (ext,incl,ops) -> do
- let (infs,insts) = unzip ops
- let stat' = ifNull MSComplete (const MSIncomplete)
- [i | i <- is, notElem i infs]
- testErr (stat' == MSComplete || stat == MSIncomplete)
- ("module" +++ showIdent i +++ "remains incomplete")
- ModInfo mt0 _ fs me' _ ops0 _ js ps0 <- lookupModule gr ext
- let ops1 = nub $
- ops_ ++ -- N.B. js has been name-resolved already
- [OQualif i j | (i,j) <- ops] ++
- [o | o <- ops0, notElem (openedModule o) infs] ++
- [OQualif i i | i <- insts] ++
- [OSimple i | i <- insts]
-
- --- check if me is incomplete
- let fs1 = fs `addOptions` fs_ -- new flags have priority
- let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
- let js1 = buildTree (tree2list js_ ++ js0)
- let ps1 = Map.union ps_ ps0
- let med1= nub (ext : infs ++ insts ++ med_)
- return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 js1 ps1
-
- return (i,mi')
-
--- | When extending a complete module: new information is inserted,
--- and the process is interrupted if unification fails.
--- If the extended module is incomplete, its judgements are just copied.
-extendMod :: SourceGrammar ->
- Bool -> (Ident,Ident -> Bool) -> Ident ->
- BinTree Ident Info -> BinTree Ident Info ->
- Err (BinTree Ident Info)
-extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old
- where
- try new (c,i)
- | not (cond c) = return new
- | otherwise = case Map.lookup c new of
- Just j -> case unifyAnyInfo name i j of
- Ok k -> return $ updateTree (c,k) new
- Bad _ -> do (base,j) <- case j of
- AnyInd _ m -> lookupOrigInfo gr m c
- _ -> return (base,j)
- (name,i) <- case i of
- AnyInd _ m -> lookupOrigInfo gr m c
- _ -> return (name,i)
- fail $ render (text "cannot unify the information" $$
- nest 4 (ppJudgement Qualified (c,i)) $$
- text "in module" <+> ppIdent name <+> text "with" $$
- nest 4 (ppJudgement Qualified (c,j)) $$
- text "in module" <+> ppIdent base)
- Nothing-> if isCompl
- then return $ updateTree (c,indirInfo name i) new
- else return $ updateTree (c,i) new
-
- indirInfo :: Ident -> Info -> Info
- indirInfo n info = AnyInd b n' where
- (b,n') = case info of
- ResValue _ -> (True,n)
- ResParam _ _ -> (True,n)
- AbsFun _ _ Nothing -> (True,n)
- AnyInd b k -> (b,k)
- _ -> (False,n) ---- canonical in Abs
-
-unifyAnyInfo :: Ident -> Info -> Info -> Err Info
-unifyAnyInfo m i j = case (i,j) of
- (AbsCat mc1 mf1, AbsCat mc2 mf2) ->
- liftM2 AbsCat (unifMaybe mc1 mc2) (unifConstrs mf1 mf2) -- adding constrs
- (AbsFun mt1 ma1 md1, AbsFun mt2 ma2 md2) ->
- liftM3 AbsFun (unifMaybe mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) -- adding defs
-
- (ResParam mt1 mv1, ResParam mt2 mv2) ->
- liftM2 ResParam (unifMaybe mt1 mt2) (unifMaybe mv1 mv2)
- (ResValue t1, ResValue t2)
- | t1==t2 -> return (ResValue t1)
- | otherwise -> fail ""
- (_, ResOverload ms t) | elem m ms ->
- return $ ResOverload ms t
- (ResOper mt1 m1, ResOper mt2 m2) ->
- liftM2 ResOper (unifMaybe mt1 mt2) (unifMaybe m1 m2)
-
- (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) ->
- liftM3 CncCat (unifMaybe mc1 mc2) (unifMaybe mf1 mf2) (unifMaybe mp1 mp2)
- (CncFun m mt1 md1, CncFun _ mt2 md2) ->
- liftM2 (CncFun m) (unifMaybe mt1 mt2) (unifMaybe md1 md2) ---- adding defs
-
- (AnyInd b1 m1, AnyInd b2 m2) -> do
- testErr (b1 == b2) $ "indirection status"
- testErr (m1 == m2) $ "different sources of indirection"
- return i
-
- _ -> fail "informations"
-
--- | this is what happens when matching two values in the same module
-unifMaybe :: Eq a => Maybe a -> Maybe a -> Err (Maybe a)
-unifMaybe Nothing Nothing = return Nothing
-unifMaybe (Just p1) Nothing = return (Just p1)
-unifMaybe Nothing (Just p2) = return (Just p2)
-unifMaybe (Just p1) (Just p2)
- | p1==p2 = return (Just p1)
- | otherwise = fail ""
-
-unifAbsArrity :: Maybe Int -> Maybe Int -> Err (Maybe Int)
-unifAbsArrity Nothing Nothing = return Nothing
-unifAbsArrity (Just a ) Nothing = return (Just a )
-unifAbsArrity Nothing (Just a ) = return (Just a )
-unifAbsArrity (Just a1) (Just a2)
- | a1==a2 = return (Just a1)
- | otherwise = fail ""
-
-unifAbsDefs :: Maybe [Equation] -> Maybe [Equation] -> Err (Maybe [Equation])
-unifAbsDefs Nothing Nothing = return Nothing
-unifAbsDefs (Just _ ) Nothing = fail ""
-unifAbsDefs Nothing (Just _ ) = fail ""
-unifAbsDefs (Just xs) (Just ys) = return (Just (xs ++ ys))
-
-unifConstrs :: Maybe [Term] -> Maybe [Term] -> Err (Maybe [Term])
-unifConstrs p1 p2 = case (p1,p2) of
- (Nothing, _) -> return p2
- (_, Nothing) -> return p1
- (Just bs, Just ds) -> return $ Just $ bs ++ ds
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:20:38 +0000