diff --git a/src/GF/Command/Commands.hs b/src/GF/Command/Commands.hs index 27ac61c81..2aa616739 100644 --- a/src/GF/Command/Commands.hs +++ b/src/GF/Command/Commands.hs @@ -384,7 +384,7 @@ allCommands cod pgf = Map.fromList [ "p \"foo\" | pt -typecheck -- type check parse results" ], exec = \opts -> return . fromTrees . treeOps (map prOpt opts), - options = treeOpOptions + options = treeOpOptions pgf }), ("q", emptyCommandInfo { longname = "quit", @@ -608,7 +608,7 @@ allCommands cod pgf = Map.fromList [ app f = maybe id id (stringOp f) treeOps opts s = foldr app s (reverse opts) where - app f = maybe id id (treeOp f) + app f = maybe id id (treeOp pgf f) showAsString t = case t of Lit (LStr s) -> s @@ -641,7 +641,7 @@ stringOpOptions = [ ("words","lexer that assumes tokens separated by spaces (default)") ] -treeOpOptions = [(op,expl) | (op,(expl,_)) <- allTreeOps] +treeOpOptions pgf = [(op,expl) | (op,(expl,_)) <- allTreeOps pgf] translationQuiz :: String -> PGF -> Language -> Language -> Category -> IO () translationQuiz cod pgf ig og cat = do diff --git a/src/GF/Command/TreeOperations.hs b/src/GF/Command/TreeOperations.hs index f05b8dec3..0ff6ac682 100644 --- a/src/GF/Command/TreeOperations.hs +++ b/src/GF/Command/TreeOperations.hs @@ -2,11 +2,10 @@ module GF.Command.TreeOperations ( treeOp, allTreeOps --typeCheck, - --compute ) where import GF.Compile.TypeCheck -import GF.Compile.AbsCompute +import PGF (compute) -- for conversions import PGF.Data @@ -18,13 +17,13 @@ import Data.List type TreeOp = [Tree] -> [Tree] -treeOp :: String -> Maybe TreeOp -treeOp f = fmap snd $ lookup f allTreeOps +treeOp :: PGF -> String -> Maybe TreeOp +treeOp pgf f = fmap snd $ lookup f $ allTreeOps pgf -allTreeOps :: [(String,(String,TreeOp))] -allTreeOps = [ +allTreeOps :: PGF -> [(String,(String,TreeOp))] +allTreeOps pgf = [ ("compute",("compute by using semantic definitions (def)", - id)), + map (compute pgf))), ("smallest",("sort trees from smallest to largest, in number of nodes", smallest)), ("typecheck",("type check and solve metavariables; reject if incorrect", @@ -34,9 +33,6 @@ allTreeOps = [ typeCheck :: PGF -> Tree -> (Tree,(Bool,[String])) typeCheck pgf t = (t,(True,[])) -compute :: PGF -> Tree -> Tree -compute pgf t = t - smallest :: [Tree] -> [Tree] smallest = sortBy (\t u -> compare (size t) (size u)) where size t = case t of diff --git a/src/PGF.hs b/src/PGF.hs index 8c64469db..31801a54f 100644 --- a/src/PGF.hs +++ b/src/PGF.hs @@ -44,7 +44,7 @@ module PGF( parse, canParse, parseAllLang, parseAll, -- ** Evaluation - tree2expr, expr2tree, + tree2expr, expr2tree, compute, -- ** Word Completion (Incremental Parsing) complete, @@ -58,6 +58,7 @@ module PGF( import PGF.CId import PGF.Linearize import PGF.Generate +import PGF.AbsCompute import PGF.Macros import PGF.Data import PGF.Expr @@ -265,4 +266,4 @@ complete pgf from cat input = tokensAndPrefix s | not (null s) && isSpace (last s) = (words s, "") | null ws = ([],"") | otherwise = (init ws, last ws) - where ws = words s \ No newline at end of file + where ws = words s diff --git a/src/PGF/AbsCompute.hs b/src/PGF/AbsCompute.hs new file mode 100644 index 000000000..f38b8d952 --- /dev/null +++ b/src/PGF/AbsCompute.hs @@ -0,0 +1,106 @@ +---------------------------------------------------------------------- +-- | +-- Module : AbsCompute +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- computation in abstract syntax with def definitions. +-- +-- modified from src GF computation +----------------------------------------------------------------------------- + +module PGF.AbsCompute ( + compute + ) where + +import PGF.Data +import PGF.Macros (lookDef,isData) +import PGF.Expr +import PGF.CId + +compute :: PGF -> Tree -> Tree +compute pgf = computeAbsTermIn pgf [] + +computeAbsTermIn :: PGF -> [CId] -> Tree -> Tree +computeAbsTermIn pgf vv = expr2tree . compt vv . tree2expr where + compt vv t = + let + t' = beta vv t + (yy,f,aa) = exprForm t' + vv' = yy ++ vv + aa' = map (compt vv') aa + in + mkAbs yy $ case look f of + Left (EEq eqs) -> case match eqs aa' of + Just (d,g) -> compt vv' $ subst vv' g d + _ -> mkApp f aa' + Left (EMeta _) -> mkApp f aa' -- canonical or primitive + Left d -> compt vv' $ mkApp d aa' + _ -> mkApp f aa' -- literal + look f = case f of + EVar c -> Left $ lookDef pgf c + _ -> Right f + match = findMatch pgf + +beta :: [CId] -> Expr -> Expr +beta vv c = case c of + EApp f a -> + let (a',f') = (beta vv a, beta vv f) in + case f' of + EAbs x b -> beta vv $ subst vv [(x,a')] (beta (x:vv) b) + _ -> (if a'==a && f'==f then id else beta vv) $ EApp f' a' + EAbs x b -> EAbs x (beta (x:vv) b) + _ -> c + + +subst :: [CId] -> Subst -> Expr -> Expr +subst xs g e = case e of + EAbs x b -> EAbs x (subst (x:xs) g e) + EApp f a -> EApp (substg f) (substg a) + EVar x -> maybe e id $ lookup x g + _ -> e + where + substg = subst xs g + +type Subst = [(CId,Expr)] +type Patt = Expr + + +exprForm :: Expr -> ([CId],Expr,[Expr]) +exprForm exp = upd ([],exp,[]) where + upd (xs,f,es) = case f of + EAbs x b -> upd (x:xs,b,es) + EApp c a -> upd (xs,c,a:es) + _ -> (reverse xs,f,es) + +mkAbs xs b = foldr EAbs b xs +mkApp f es = foldl EApp f es + +-- special version of pattern matching, to deal with comp under lambda + +findMatch :: PGF -> [Equation] -> [Expr] -> Maybe (Expr, Subst) +findMatch pgf cases terms = case cases of + [] -> Nothing + (Equ patts _):_ | length patts /= length terms -> Nothing + (Equ patts val):cc -> case mapM tryMatch (zip patts terms) of + Just substs -> return (val, concat substs) + _ -> findMatch pgf cc terms + where + + tryMatch (p,t) = case (exprForm p, exprForm t) of + (([],EVar c,[]),_) | constructor c -> if p==t then return [] else Nothing + (([],EVar x,[]),_) | notMeta t -> return [(x,t)] + (([],p, pp), ([], f, tt)) | p == f && length pp == length tt -> do + matches <- mapM tryMatch (zip pp tt) + return (concat matches) + _ -> if p==t then return [] else Nothing + + notMeta e = case e of + EMeta _ -> False + EApp f a -> notMeta f && notMeta a + EAbs _ b -> notMeta b + _ -> True + + constructor = isData pgf + diff --git a/src/PGF/Macros.hs b/src/PGF/Macros.hs index b79715f44..4c73817dc 100644 --- a/src/PGF/Macros.hs +++ b/src/PGF/Macros.hs @@ -38,6 +38,11 @@ lookDef :: PGF -> CId -> Expr lookDef pgf f = snd $ lookMap (error $ "lookDef " ++ show f) f (funs (abstract pgf)) +isData :: PGF -> CId -> Bool +isData pgf f = case Map.lookup f (funs (abstract pgf)) of + Just (_,EMeta 0) -> True ---- the encoding of data constrs + _ -> False + lookValCat :: PGF -> CId -> CId lookValCat pgf = valCat . lookType pgf