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

change the PGF.Data.Exp type

Browse Source
This commit is contained in:
krasimir
2008-05-30 09:10:28 +00:00
parent 3d2ce9216d
commit 587eed4eaa
11 changed files with 118 additions and 145 deletions
Download Patch File Download Diff File Expand all files Collapse all files

7
src-3.0/GF/Command/Commands.hs
View File

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

43
src-3.0/GF/Command/PPrTree.hs
View File

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

34
src-3.0/GF/Compile/GrammarToGFCC.hs
View File

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

57
src-3.0/PGF.hs
View File

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

17
src-3.0/PGF/Data.hs
View File

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

14
src-3.0/PGF/Generate.hs
View File

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

34
src-3.0/PGF/Linearize.hs
View File

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

12
src-3.0/PGF/Macros.hs
View File

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

10
src-3.0/PGF/Parsing/FCFG/Utilities.hs
View File

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

33
src-3.0/PGF/Raw/Convert.hs
View File

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

2
src-3.0/PGF/ShowLinearize.hs
View File

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