diff --git a/src-3.0/GF/Command/Commands.hs b/src-3.0/GF/Command/Commands.hs index 759f9a8bf..bf5c737cc 100644 --- a/src-3.0/GF/Command/Commands.hs +++ b/src-3.0/GF/Command/Commands.hs @@ -149,10 +149,9 @@ allCommands mgr = Map.fromAscList [ gr = gfcc mgr fromTrees ts = (ts,unlines (map showTree ts)) - fromStrings ss = (map tStr ss, unlines ss) - fromString s = ([tStr s], s) - toStrings ts = [s | DTr [] (AS s) [] <- ts] - tStr s = DTr [] (AS s) [] + fromStrings ss = (map EStr ss, unlines ss) + fromString s = ([EStr s], s) + toStrings ts = [s | EStr s <- ts] prGrammar opts = case valIdOpts "printer" "" opts of "cats" -> unwords $ categories mgr diff --git a/src-3.0/GF/Command/PPrTree.hs b/src-3.0/GF/Command/PPrTree.hs index dcc057cb7..7562d6fab 100644 --- a/src-3.0/GF/Command/PPrTree.hs +++ b/src-3.0/GF/Command/PPrTree.hs @@ -1,39 +1,26 @@ -module GF.Command.PPrTree (pTree, prExp, tree2exp) where +module GF.Command.PPrTree (tree2exp, exp2tree) where import PGF.CId import PGF.Data -import PGF.Macros -import qualified GF.Command.ParGFShell as P -import GF.Command.PrintGFShell import GF.Command.AbsGFShell -import GF.Data.ErrM - -pTree :: String -> Exp -pTree s = case P.pTree (P.myLexer s) of - Ok t -> tree2exp t - Bad s -> error s tree2exp t = case t of - TApp f ts -> tree (AC (i2i f)) (map tree2exp ts) - TAbs xs t -> DTr (map i2i xs ++ ys) f ts where DTr ys f ts = tree2exp t - TId c -> tree (AC (i2i c)) [] - TInt i -> tree (AI i) [] - TStr s -> tree (AS s) [] - TFloat d -> tree (AF d) [] + TApp f ts -> EApp (i2i f) (map tree2exp ts) + TAbs xs t -> EAbs (map i2i xs) (tree2exp t) + TId c -> EApp (i2i c) [] + TInt i -> EInt i + TStr s -> EStr s + TFloat d -> EFloat d where i2i (Ident s) = mkCId s -prExp :: Exp -> String -prExp = printTree . exp2tree - -exp2tree (DTr xs at ts) = tabs (map i4i xs) (tapp at (map exp2tree ts)) +exp2tree t = case t of + (EAbs xs e) -> TAbs (map i4i xs) (exp2tree e) + (EApp f []) -> TId (i4i f) + (EApp f es) -> TApp (i4i f) (map exp2tree es) + (EInt i) -> TInt i + (EStr i) -> TStr i + (EFloat i) -> TFloat i + (EMeta i) -> TId (Ident "?") ---- where - tabs [] t = t - tabs ys t = TAbs ys t - tapp (AC f) [] = TId (i4i f) - tapp (AC f) vs = TApp (i4i f) vs - tapp (AI i) [] = TInt i - tapp (AS i) [] = TStr i - tapp (AF i) [] = TFloat i - tapp (AM i) [] = TId (Ident "?") ---- i4i s = Ident (prCId s) diff --git a/src-3.0/GF/Compile/GrammarToGFCC.hs b/src-3.0/GF/Compile/GrammarToGFCC.hs index 49ab4db70..677354280 100644 --- a/src-3.0/GF/Compile/GrammarToGFCC.hs +++ b/src-3.0/GF/Compile/GrammarToGFCC.hs @@ -117,22 +117,24 @@ mkExp :: A.Term -> C.Exp mkExp t = case t of A.Eqs eqs -> C.EEq [C.Equ (map mkPatt ps) (mkExp e) | (ps,e) <- eqs] _ -> case GM.termForm t of - Ok (xx,c,args) -> C.DTr [i2i x | x <- xx] (mkAt c) (map mkExp args) - where - mkAt c = case c of - Q _ c -> C.AC $ i2i c - QC _ c -> C.AC $ i2i c - Vr x -> C.AV $ i2i x - EInt i -> C.AI i - EFloat f -> C.AF f - K s -> C.AS s - Meta (MetaSymb i) -> C.AM $ toInteger i - _ -> C.AM 0 - mkPatt p = uncurry CM.tree $ case p of - A.PP _ c ps -> (C.AC (i2i c), map mkPatt ps) - A.PV x -> (C.AV (i2i x), []) - A.PW -> (C.AV wildCId, []) - A.PInt i -> (C.AI i, []) + Ok (xs,c,args) -> mkAbs xs (mkApp c (map mkExp args)) + where + mkAbs [] t = t + mkAbs xs t = C.EAbs [i2i x | x <- xs] t + mkApp c args = case c of + Q _ c -> C.EApp (i2i c) args + QC _ c -> C.EApp (i2i c) args + Vr x -> C.EVar (i2i x) + EInt i -> C.EInt i + EFloat f -> C.EFloat f + K s -> C.EStr s + Meta (MetaSymb i) -> C.EMeta (toInteger i) + _ -> C.EMeta 0 + mkPatt p = case p of + A.PP _ c ps -> C.EApp (i2i c) (map mkPatt ps) + A.PV x -> C.EVar (i2i x) + A.PW -> C.EVar wildCId + A.PInt i -> C.EInt i mkContext :: A.Context -> [C.Hypo] mkContext hyps = [C.Hyp (i2i x) (mkType ty) | (x,ty) <- hyps] diff --git a/src-3.0/PGF.hs b/src-3.0/PGF.hs index 4a44ac586..9e4ed7aab 100644 --- a/src-3.0/PGF.hs +++ b/src-3.0/PGF.hs @@ -109,30 +109,32 @@ generateRandom mgr cat = do generateAll mgr cat = generate (gfcc mgr) (mkCId cat) Nothing generateAllDepth mgr cat = generate (gfcc mgr) (mkCId cat) -readTree s = case RP.readP_to_S (pExp 0) s of +readTree s = case RP.readP_to_S (pExp False) s of [(x,"")] -> x _ -> error "no parse" pExps :: RP.ReadP [Exp] -pExps = liftM2 (:) (pExp 1) pExps RP.<++ (RP.skipSpaces >> return []) +pExps = liftM2 (:) (pExp True) pExps RP.<++ (RP.skipSpaces >> return []) -pExp :: Int -> RP.ReadP Exp -pExp n = RP.skipSpaces >> (pParen RP.<++ pApp RP.<++ pNum RP.<++ pStr RP.<++ pMeta) +pExp :: Bool -> RP.ReadP Exp +pExp isNested = RP.skipSpaces >> (pParen RP.<++ pAbs RP.<++ pApp RP.<++ pNum RP.<++ pStr RP.<++ pMeta) where - pParen = RP.between (RP.char '(') (RP.char ')') (pExp 0) - pApp = do xs <- RP.option [] (RP.between (RP.char '\\') (RP.string "->") (RP.sepBy1 pIdent (RP.char ','))) - f <- pIdent - ts <- (if n == 0 then pExps else return []) - return (DTr xs (AC f) ts) - pStr = RP.char '"' >> liftM (\s -> DTr [] (AS s) []) (RP.manyTill (pEsc RP.<++ RP.get) (RP.char '"')) + pParen = RP.between (RP.char '(') (RP.char ')') (pExp False) + pAbs = do xs <- RP.between (RP.char '\\') (RP.skipSpaces >> RP.string "->") (RP.sepBy1 (RP.skipSpaces >> pIdent) (RP.skipSpaces >> RP.char ',')) + t <- pExp False + return (EAbs xs t) + pApp = do f <- pIdent + ts <- (if isNested then return [] else pExps) + return (EApp f ts) + pStr = RP.char '"' >> liftM EStr (RP.manyTill (pEsc RP.<++ RP.get) (RP.char '"')) pEsc = RP.char '\\' >> RP.get pNum = do x <- RP.munch1 isDigit - ((RP.char '.' >> RP.munch1 isDigit >>= \y -> return (DTr [] (AF (read (x++"."++y))) [])) + ((RP.char '.' >> RP.munch1 isDigit >>= \y -> return (EFloat (read (x++"."++y)))) RP.<++ - (return (DTr [] (AI (read x)) []))) + (return (EInt (read x)))) pMeta = do RP.char '?' x <- RP.munch1 isDigit - return (DTr [] (AM (read x)) []) + return (EMeta (read x)) pIdent = fmap mkCId (liftM2 (:) (RP.satisfy isIdentFirst) (RP.munch isIdentRest)) isIdentFirst c = c == '_' || isLetter c @@ -141,23 +143,20 @@ pExp n = RP.skipSpaces >> (pParen RP.<++ pApp RP.<++ pNum RP.<++ pStr RP.<++ pMe showTree = PP.render . ppExp False -ppExp isNested (DTr [] at []) = ppAtom at -ppExp isNested (DTr xs at ts) = ppParens isNested (ppLambdas xs PP.<+> ppAtom at PP.<+> PP.hsep (map (ppExp True) ts)) - where - ppLambdas [] = PP.empty - ppLambdas xs = PP.char '\\' PP.<> - PP.hsep (PP.punctuate PP.comma (map (PP.text . prCId) xs)) PP.<+> - PP.text "->" +ppExp isNested (EAbs xs t) = ppParens isNested (PP.char '\\' PP.<> + PP.hsep (PP.punctuate PP.comma (map (PP.text . prCId) xs)) PP.<+> + PP.text "->" PP.<+> + ppExp False t) +ppExp isNested (EApp f []) = PP.text (prCId f) +ppExp isNested (EApp f ts) = ppParens isNested (PP.text (prCId f) PP.<+> PP.hsep (map (ppExp True) ts)) +ppExp isNested (EStr s) = PP.text (show s) +ppExp isNested (EInt n) = PP.integer n +ppExp isNested (EFloat d) = PP.double d +ppExp isNested (EMeta n) = PP.char '?' PP.<> PP.integer n +ppExp isNested (EVar id) = PP.text (prCId id) - ppParens True = PP.parens - ppParens False = id - -ppAtom (AC id) = PP.text (prCId id) -ppAtom (AS s) = PP.text (show s) -ppAtom (AI n) = PP.integer n -ppAtom (AF d) = PP.double d -ppAtom (AM n) = PP.char '?' PP.<> PP.integer n -ppAtom (AV id) = PP.text (prCId id) +ppParens True = PP.parens +ppParens False = id abstractName mgr = prCId (absname (gfcc mgr)) diff --git a/src-3.0/PGF/Data.hs b/src-3.0/PGF/Data.hs index 34c58e5d6..2750cbdfa 100644 --- a/src-3.0/PGF/Data.hs +++ b/src-3.0/PGF/Data.hs @@ -41,19 +41,16 @@ data Type = deriving (Eq,Ord,Show) data Exp = - DTr [CId] Atom [Exp] + EAbs [CId] Exp + | EApp CId [Exp] + | EStr String + | EInt Integer + | EFloat Double + | EMeta Integer + | EVar CId | EEq [Equation] deriving (Eq,Ord,Show) -data Atom = - AC CId - | AS String - | AI Integer - | AF Double - | AM Integer - | AV CId - deriving (Eq,Ord,Show) - data Term = R [Term] | P Term Term diff --git a/src-3.0/PGF/Generate.hs b/src-3.0/PGF/Generate.hs index 72340ffa3..ac5c25b08 100644 --- a/src-3.0/PGF/Generate.hs +++ b/src-3.0/PGF/Generate.hs @@ -11,13 +11,13 @@ import System.Random generate :: GFCC -> CId -> Maybe Int -> [Exp] generate gfcc cat dp = concatMap (\i -> gener i cat) depths where - gener 0 c = [tree (AC f) [] | (f, ([],_)) <- fns c] + gener 0 c = [EApp f [] | (f, ([],_)) <- fns c] gener i c = [ tr | (f, (cs,_)) <- fns c, let alts = map (gener (i-1)) cs, ts <- combinations alts, - let tr = tree (AC f) ts, + let tr = EApp f ts, depth tr >= i ] fns c = [(f,catSkeleton ty) | (f,ty) <- functionsToCat gfcc c] @@ -36,16 +36,16 @@ genRandom gen gfcc cat = genTrees (randomRs (0.0, 1.0 :: Double) gen) cat where (genTrees ds2 cat) -- else (drop k ds) genTree rs = gett rs where - gett ds cid | cid == mkCId "String" = (tree (AS "foo") [], 1) - gett ds cid | cid == mkCId "Int" = (tree (AI 12345) [], 1) - gett [] _ = (tree (AS "TIMEOUT") [], 1) ---- + gett ds cid | cid == mkCId "String" = (EStr "foo", 1) + gett ds cid | cid == mkCId "Int" = (EInt 12345, 1) + gett [] _ = (EStr "TIMEOUT", 1) ---- gett ds cat = case fns cat of - [] -> (tree (AM 0) [],1) + [] -> (EMeta 0,1) fs -> let d:ds2 = ds (f,args) = getf d fs (ts,k) = getts ds2 args - in (tree (AC f) ts, k+1) + in (EApp f ts, k+1) getf d fs = let lg = (length fs) in fs !! (floor (d * fromIntegral lg)) getts ds cats = case cats of diff --git a/src-3.0/PGF/Linearize.hs b/src-3.0/PGF/Linearize.hs index 94d8aa216..d84c48f89 100644 --- a/src-3.0/PGF/Linearize.hs +++ b/src-3.0/PGF/Linearize.hs @@ -26,25 +26,21 @@ realize trm = case trm of _ -> "ERROR " ++ show trm ---- debug linExp :: GFCC -> CId -> Exp -> Term -linExp mcfg lang tree@(DTr xs at trees) = - addB $ case at of - AC fun -> comp (map lin trees) $ look fun - AS s -> R [kks (show s)] -- quoted - AI i -> R [kks (show i)] - --- [C lst, kks (show i), C size] where - --- lst = mod (fromInteger i) 10 ; size = if i < 10 then 0 else 1 - AF d -> R [kks (show d)] - AV x -> TM (prCId x) - AM i -> TM (show i) - where - lin = linExp mcfg lang - comp = compute mcfg lang - look = lookLin mcfg lang - addB t - | Data.List.null xs = t - | otherwise = case t of - R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs) - TM s -> R $ t : (Data.List.map (kks . prCId) xs) +linExp gfcc lang = lin + where + lin (EAbs xs e ) = case lin e of + R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs) + TM s -> R $ (TM s) : (Data.List.map (kks . prCId) xs) + lin (EApp fun es) = comp (map lin es) $ look fun + lin (EStr s ) = R [kks (show s)] -- quoted + lin (EInt i ) = R [kks (show i)] + lin (EFloat d ) = R [kks (show d)] + lin (EVar x ) = TM (prCId x) + lin (EMeta i ) = TM (show i) + + comp = compute gfcc lang + look = lookLin gfcc lang + compute :: GFCC -> CId -> [Term] -> Term -> Term compute mcfg lang args = comp where diff --git a/src-3.0/PGF/Macros.hs b/src-3.0/PGF/Macros.hs index 64ddd24e4..6c6fef1e5 100644 --- a/src-3.0/PGF/Macros.hs +++ b/src-3.0/PGF/Macros.hs @@ -62,12 +62,9 @@ functionsToCat gfcc cat = fs = lookMap [] cat $ catfuns $ abstract gfcc depth :: Exp -> Int -depth tr = case tr of - DTr _ _ [] -> 1 - DTr _ _ ts -> maximum (map depth ts) + 1 - -tree :: Atom -> [Exp] -> Exp -tree = DTr [] +depth (EAbs _ t) = depth t +depth (EApp _ ts) = maximum (0:map depth ts) + 1 +depth _ = 1 cftype :: [CId] -> CId -> Type cftype args val = DTyp [Hyp wildCId (cftype [] arg) | arg <- args] val [] @@ -88,9 +85,6 @@ contextLength :: Type -> Int contextLength ty = case ty of DTyp hyps _ _ -> length hyps -exp0 :: Exp -exp0 = tree (AM 0) [] - primNotion :: Exp primNotion = EEq [] diff --git a/src-3.0/PGF/Parsing/FCFG/Utilities.hs b/src-3.0/PGF/Parsing/FCFG/Utilities.hs index b33d5ccaa..e435c6154 100644 --- a/src-3.0/PGF/Parsing/FCFG/Utilities.hs +++ b/src-3.0/PGF/Parsing/FCFG/Utilities.hs @@ -180,8 +180,8 @@ applyProfileToForest (FMeta) = [FMeta] forest2exps :: SyntaxForest CId -> [Exp] -forest2exps (FNode n forests) = map (DTr [] (AC n)) $ forests >>= mapM forest2exps -forest2exps (FString s) = [DTr [] (AS s) []] -forest2exps (FInt n) = [DTr [] (AI n) []] -forest2exps (FFloat f) = [DTr [] (AF f) []] -forest2exps (FMeta) = [DTr [] (AM 0) []] +forest2exps (FNode n forests) = map (EApp n) $ forests >>= mapM forest2exps +forest2exps (FString s) = [EStr s] +forest2exps (FInt n) = [EInt n] +forest2exps (FFloat f) = [EFloat f] +forest2exps (FMeta) = [EMeta 0] diff --git a/src-3.0/PGF/Raw/Convert.hs b/src-3.0/PGF/Raw/Convert.hs index 3e077cc8d..9954f3eb5 100644 --- a/src-3.0/PGF/Raw/Convert.hs +++ b/src-3.0/PGF/Raw/Convert.hs @@ -107,15 +107,14 @@ toHypo e = case e of toExp :: RExp -> Exp toExp e = case e of - App "App" [App fun [], App "B" xs, App "X" exps] -> - DTr [mkCId x | App x [] <- xs] (AC (mkCId fun)) (map toExp exps) - App "Eq" eqs -> - EEq [Equ (map toExp ps) (toExp v) | App "E" (v:ps) <- eqs] - App "Var" [App i []] -> DTr [] (AV (mkCId i)) [] - AMet -> DTr [] (AM 0) [] - AInt i -> DTr [] (AI i) [] - AFlt i -> DTr [] (AF i) [] - AStr i -> DTr [] (AS i) [] + App "Abs" [App "B" xs, exp] -> EAbs [mkCId x | App x [] <- xs] (toExp exp) + App "App" (App fun [] : exps) -> EApp (mkCId fun) (map toExp exps) + App "Eq" eqs -> EEq [Equ (map toExp ps) (toExp v) | App "E" (v:ps) <- eqs] + App "Var" [App i []] -> EVar (mkCId i) + AMet -> EMeta 0 + AInt i -> EInt i + AFlt i -> EFloat i + AStr i -> EStr i _ -> error $ "exp " ++ show e toTerm :: RExp -> Term @@ -173,14 +172,14 @@ fromHypo e = case e of fromExp :: Exp -> RExp fromExp e = case e of - DTr xs (AC fun) exps -> - App "App" [App (prCId fun) [], App "B" (map (flip App [] . prCId) xs), App "X" (map fromExp exps)] - DTr [] (AV x) [] -> App "Var" [App (prCId x) []] - DTr [] (AS s) [] -> AStr s - DTr [] (AF d) [] -> AFlt d - DTr [] (AI i) [] -> AInt (toInteger i) - DTr [] (AM _) [] -> AMet ---- - EEq eqs -> + EAbs xs exp -> App "Abs" [App "B" (map (flip App [] . prCId) xs), fromExp exp] + EApp fun exps -> App "App" (App (prCId fun) [] : map fromExp exps) + EVar x -> App "Var" [App (prCId x) []] + EStr s -> AStr s + EFloat d -> AFlt d + EInt i -> AInt (toInteger i) + EMeta _ -> AMet ---- + EEq eqs -> App "Eq" [App "E" (map fromExp (v:ps)) | Equ ps v <- eqs] _ -> error $ "exp " ++ show e diff --git a/src-3.0/PGF/ShowLinearize.hs b/src-3.0/PGF/ShowLinearize.hs index 9aa316ba9..2aecbffbd 100644 --- a/src-3.0/PGF/ShowLinearize.hs +++ b/src-3.0/PGF/ShowLinearize.hs @@ -77,7 +77,7 @@ recordLinearize gfcc lang = prRecord . recLinearize gfcc lang recLinearize :: GFCC -> CId -> Exp -> Record recLinearize gfcc lang exp = mkRecord typ $ linExp gfcc lang exp where typ = case exp of - DTr _ (AC f) _ -> lookParamLincat gfcc lang $ valCat $ lookType gfcc f + EApp f _ -> lookParamLincat gfcc lang $ valCat $ lookType gfcc f -- show GFCC term termLinearize :: GFCC -> CId -> Exp -> String