msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

peel head i ; gt nometas ; gf2hs

Browse Source
This commit is contained in:
aarne
2004-05-18 20:57:13 +00:00
parent a757409214
commit 0232a283a9
14 changed files with 208 additions and 35 deletions
Download Patch File Download Diff File Expand all files Collapse all files

14
src/GF/API.hs
View File

@@ -160,13 +160,14 @@ randomTreesIO opts gr n = do
generateTrees :: Options -> GFGrammar -> Maybe Tree -> [Tree]
generateTrees opts gr mt =
optIntOrAll opts flagNumber
[tr | t <- Gen.generateTrees gr' cat dpt mn mt, Ok tr <- [mkTr t]]
[tr | t <- Gen.generateTrees gr' ifm cat dpt mn mt, Ok tr <- [mkTr t]]
where
mkTr = annotate gr' . qualifTerm (absId gr)
gr' = grammar gr
cat = firstAbsCat opts gr
dpt = maybe 3 id $ getOptInt opts flagDepth
mn = getOptInt opts flagAlts
ifm = not $ oElem noMetas opts
speechGenerate :: Options -> String -> IO ()
speechGenerate opts str = do
@@ -296,11 +297,14 @@ optTermCommand opts st =
{-
-- wraps term in a function and optionally computes the result
wrapByFun :: Options -> StateGrammar -> Ident -> Term -> Term
wrapByFun opts g f t =
wrapByFun :: Options -> GFGrammar -> Ident -> Tree -> Tree
wrapByFun opts gr f t =
if oElem doCompute opts
then err (const t) id $ computeAbsTerm (stateAbstract g) (appCons f [t])
else appCons f [t]
then err (const t) id $ computeAbsTerm (stateAbstract g) (appCons f' [t])
else appCons f' [t]
where
qualifTerm (absId gr) $
optTransfer :: Options -> StateGrammar -> Term -> Term
optTransfer opts g = case getOptVal opts transferFun of

133
src/GF/API/GrammarToHaskell.hs Normal file
View File

@@ -0,0 +1,133 @@
module GrammarToHaskell (grammar2haskell) where
import qualified GFC
import Macros
import Modules
import Operations
-- 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
-- the main function
grammar2haskell :: GFC.CanonGrammar -> String
grammar2haskell gr = foldr (++++) [] $
haskPreamble ++ [datatypes gr', gfinstances gr', fginstances gr']
where gr' = hSkeleton gr
-- by this you can prefix all identifiers with stg; the default is 'G'
gId :: OIdent -> OIdent
gId i = 'G':i
haskPreamble =
[
"module GSyntax where",
"",
"import Ident",
"import Grammar",
"import PrGrammar",
"import Macros",
"import Operations",
"----------------------------------------------------",
"-- automatic translation from GF to Haskell",
"----------------------------------------------------",
"",
"class Gf a where gf :: a -> Trm",
"class Fg a where fg :: Trm -> a",
"",
predefInst "String" "K s",
"",
predefInst "Int" "EInt s",
"",
"----------------------------------------------------",
"-- below this line machine-generated",
"----------------------------------------------------",
""
]
predefInst typ patt = let gtyp = gId typ in
"newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show" +++++
"instance Gf" +++ gtyp +++ "where" ++++
" gf (" ++ gtyp +++ "s) =" +++ patt +++++
"instance Fg" +++ gtyp +++ "where" ++++
" fg t =" ++++
" case termForm t of" ++++
" Ok ([]," +++ patt +++ ",[]) ->" +++ gtyp +++ "s" ++++
" _ -> error (\"no" +++ gtyp +++ "\" ++ prt t)"
type OIdent = String
type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
datatypes, gfinstances, fginstances :: (String,HSkeleton) -> String
datatypes = (foldr (+++++) "") . (filter (/="")) . (map hDatatype) . snd
gfinstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (hInstance m)) g
fginstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (fInstance m)) g
hDatatype :: (OIdent, [(OIdent, [OIdent])]) -> String
hInstance, fInstance :: String -> (OIdent, [(OIdent, [OIdent])]) -> String
hDatatype ("Cn",_) = "" ---
hDatatype (cat,[]) = ""
hDatatype (cat,rules) =
"data" +++ gId cat +++ "=" ++
(if length rules == 1 then "" else "\n ") +++
foldr1 (\x y -> x ++ "\n |" +++ y)
[gId f +++ foldr (+++) "" (map gId xx) | (f,xx) <- rules] ++++
" deriving Show"
----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
hInstance m (cat,[]) = ""
hInstance m (cat,rules) =
"instance Gf" +++ gId cat +++ "where" ++
(if length rules == 1 then "" else "\n") +++
foldr1 (\x y -> x ++ "\n" +++ y) [mkInst f xx | (f,xx) <- rules]
where
mkInst f xx =
"gf " ++
(if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
"=" +++
"appqc \"" ++ m ++ "\" \"" ++ f ++ "\"" +++
"[" ++ prTList ", " ["gf" +++ x | x <- xx'] ++ "]"
where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
----fInstance m ("Cn",_) = "" ---
fInstance m (cat,[]) = ""
fInstance m (cat,rules) =
"instance Fg" +++ gId cat +++ "where" ++++
" fg t =" ++++
" case termForm t of" ++++
foldr1 (\x y -> x ++ "\n" ++ y) [mkInst f xx | (f,xx) <- rules] ++++
" _ -> error (\"no" +++ cat ++ " \" ++ prt t)"
where
mkInst f xx =
" Ok ([], Q (IC \"" ++ m ++ "\") (IC \"" ++ f ++ "\")," ++
"[" ++ prTList "," xx' ++ "])" +++
"->" +++
gId f +++
prTList " " [prParenth ("fg" +++ x) | x <- xx']
where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
hSkeleton :: GFC.CanonGrammar -> (String,HSkeleton)
hSkeleton gr = (name,collectR rules [(c,[]) | c <- cats]) where
collectR rr hh =
case rr of
(fun,typ):rs -> case catSkeleton typ of
Ok (cats,cat) ->
collectR rs (updateSkeleton (symid (snd cat)) hh (fun,
map (symid . snd) cats))
_ -> collectR rs hh
_ -> hh
cats = [symid cat | (cat,GFC.AbsCat _ _) <- defs]
rules = [(symid fun, typ) | (fun,GFC.AbsFun typ _) <- defs]
defs = concat [tree2list (jments m) | im@(_,ModMod m) <- modules gr, isModAbs m]
name = ifNull "UnknownModule" (symid . last) [n | (n,ModMod m) <- modules gr, isModAbs m]
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

6
src/GF/Data/Zipper.hs
View File

@@ -180,3 +180,9 @@ changeRoot f loc = case loc of
chPath pv = case pv of
(Top,a) -> (Top, f a)
(Node (left,pv,right),v) -> (Node (left, chPath pv,right),v)
nthSubtree :: Int -> Tr a -> Err (Tr a)
nthSubtree n (Tr (a,ts)) = ts !? n
arityTree :: Tr a -> Int
arityTree (Tr (_,ts)) = length ts

3
src/GF/Grammar/Macros.hs
View File

@@ -192,6 +192,9 @@ appCons = mkApp . Cn
appc :: String -> [Term] -> Term
appc = appCons . zIdent
appqc :: String -> String -> [Term] -> Term
appqc q c = mkApp (Q (zIdent q) (zIdent c))
mkLet :: [LocalDef] -> Term -> Term
mkLet defs t = foldr Let t defs

1
src/GF/Infra/Option.hs
View File

@@ -140,6 +140,7 @@ tableLin = iOpt "table"
defaultLinOpts = [firstLin]
useUTF8 = iOpt "utf8"
showLang = iOpt "lang"
noMetas = iOpt "nometas"
-- other
beVerbose = iOpt "v"

2
src/GF/Shell.hs
View File

@@ -200,7 +200,7 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = case comm of
CPutTerm -> changeArg (opTT2CommandArg (optTermCommand opts gro) . s2t) sa
----- CWrapTerm f -> changeArg (opTT2CommandArg (return . wrapByFun opts gro f)) sa
---- CWrapTerm f -> changeArg (opTT2CommandArg (return . wrapByFun opts gro f)) sa
CMorphoAnalyse -> changeArg (AString . morphoAnalyse opts gro . prCommandArg) sa
CTestTokenizer -> changeArg (AString . optTokenizer opts gro . prCommandArg) sa

2
src/GF/Shell/CommandL.hs
View File

@@ -68,7 +68,7 @@ pCommand = pCommandWords . words where
"r" : f : _ -> CRefineWithAtom f
"w" : f:i : _ -> CWrapWithFun (f, readIntArg i)
"ch": f : _ -> CChangeHead f
"ph": _ -> CPeelHead
"ph": f:i : _ -> CPeelHead (f, readIntArg i)
"x" : ws -> CAlphaConvert $ unwords ws
"s" : i : _ -> CSelectCand (readIntArg i)
"f" : "unstructured" : _ -> CRemoveOption showStruct --- hmmm

20
src/GF/Shell/Commands.hs
View File

@@ -63,7 +63,7 @@ data Command =
| CRefineParse String
| CWrapWithFun (String,Int)
| CChangeHead String
| CPeelHead
| CPeelHead (String,Int)
| CAlphaConvert String
| CRefineRandom
| CSelectCand Int
@@ -206,7 +206,7 @@ execECommand env c = case c of
uniqueRefinements cgr s'
CWrapWithFun (f,i) -> action2commandNext $ wrapWithFun cgr (qualif f, i)
CChangeHead f -> action2commandNext $ changeFunHead cgr (qualif f)
CPeelHead -> action2commandNext $ peelFunHead cgr
CPeelHead (f,i) -> action2commandNext $ peelFunHead cgr (qualif f,i)
CAlphaConvert s -> action2commandNext $ \x ->
string2varPair s >>= \xy -> alphaConvert cgr xy x
@@ -285,12 +285,12 @@ mkRefineMenuAll :: CEnv -> SState -> [(Command,(String,String))]
mkRefineMenuAll env sstate =
case (refinementsState cgr state, candsSState sstate, wrappingsState cgr state) of
([],[],wraps) ->
[(CWrapWithFun (prQIdent_ f, i), prWrap fit)
[(CWrapWithFun (prQIdent_ f, i), prWrap "w" "Wrap" fit)
| fit@((f,i),_) <- wraps] ++
[(CChangeHead (prQIdent_ f), prChangeHead f)
| f <- headChangesState cgr state] ++
[(CPeelHead, (ifShort "ph" "PeelHead", "ph"))
| canPeelState cgr state] ++
[(CPeelHead (prQIdent_ f, i), prPeel "ph" "PeelHead" fi)
| fi@(f,i) <- peelingsState cgr state] ++
[(CDelete, (ifShort "d" "Delete", "d"))] ++
[(CAddClip, (ifShort "ac" "AddClip", "ac"))]
(refs,[],_) ->
@@ -309,10 +309,14 @@ mkRefineMenuAll env sstate =
prChangeHead f =
(ifShort "ch" "ChangeHead" +++ prOrLinFun f,
"ch" +++ prQIdent_ f)
prWrap ((f,i),t) =
(ifShort "w" "Wrap" +++ prOrLinFun f +++ ifTyped (":" +++ prt t) +++
prWrap sh lg ((f,i),t) =
(ifShort sh lg +++ prOrLinFun f +++ ifTyped (":" +++ prt t) +++
ifShort (show i) (prBracket (show i)),
"w" +++ prQIdent_ f +++ show i)
sh +++ prQIdent_ f +++ show i)
prPeel sh lg (f,i) =
(ifShort sh lg +++ prOrLinFun f +++
ifShort (show i) (prBracket (show i)),
sh +++ prQIdent_ f +++ show i)
prCand (t,i) =
(ifShort ("s" +++ prOrLinExp t) ("Select" +++ prOrLinExp t),"s" +++ show i)

5
src/GF/UseGrammar/Custom.hs
View File

@@ -31,7 +31,7 @@ import CFtoSRG
import Zipper
import Morphology
-----import GrammarToHaskell
import GrammarToHaskell
-----import GrammarToCanon (showCanon, showCanonOpt)
-----import qualified GrammarToGFC as GFC
@@ -156,6 +156,7 @@ customGrammarPrinter =
,(strCI "old", printGrammarOld . stateGrammarST)
,(strCI "srg", prSRG . stateCF)
,(strCI "lbnf", prLBNF . stateCF)
,(strCI "haskell", grammar2haskell . stateGrammarST)
,(strCI "morpho", prMorpho . stateMorpho)
,(strCI "fullform",prFullForm . stateMorpho)
,(strCI "opts", prOpts . stateOptions)
@@ -208,7 +209,7 @@ customTermCommand =
,(strCI "generate", \g t -> let gr = grammar g
cat = actCat $ tree2loc t --- not needed
in
[tr | t <- generateTrees gr cat 2 Nothing (Just t),
[tr | t <- generateTrees gr False cat 2 Nothing (Just t),
Ok tr <- [annotate gr $ MM.qualifTerm (absId g) t]])
,(strCI "typecheck", \g t -> let gr = grammar g in

35
src/GF/UseGrammar/Editing.hs
View File

@@ -40,6 +40,11 @@ actCat = errVal undefined . val2cat . actVal ---- undef
actAtom :: State -> Atom
actAtom = atomTree . actTree
actFun :: State -> Err Fun
actFun s = case actAtom s of
AtC f -> return f
t -> prtBad "active atom: expected function, found" t
actExp = tree2exp . actTree
-- current local bindings
@@ -319,10 +324,12 @@ changeFunHead gr f state = do
let state' = changeNode (changeAtom (const (atomC f))) state
reCheckState gr state' --- must be done because of constraints elsewhere
peelFunHead :: CGrammar -> Action
peelFunHead gr state = do
state' <- forgetNode state
reCheckState gr state' --- must be done because of constraints elsewhere
peelFunHead :: CGrammar -> (Fun,Int) -> Action
peelFunHead gr (f@(m,c),i) state = do
tree0 <- nthSubtree i $ actTree state
let tree = addBinds (actBinds state) $ tree0
state' <- replaceSubTree tree state
reCheckState gr state' --- must be unfortunately done. 20/11/2001
-- an expensive operation
reCheckState :: CGrammar -> State -> Err State
@@ -355,6 +362,20 @@ wrappingsState gr state
funs = funsOnType (possibleRefVal gr state) gr aval
aval = actVal state
peelingsState :: CGrammar -> State -> [(Fun,Int)]
peelingsState gr state
| actIsMeta state = []
| isRootState state =
err (const []) (\f -> [(f,i) | i <- [0 .. arityTree tree - 1]]) $ actFun state
| otherwise =
err (const [])
(\f -> [fi | (fi@(g,_),typ) <- funs,
possibleRefVal gr state aval typ,g==f]) $ actFun state
where
funs = funsOnType (possibleRefVal gr state) gr aval
aval = actVal state
tree = actTree state
headChangesState :: CGrammar -> State -> [Fun]
headChangesState gr state = errVal [] $ do
f@(m,c) <- funAtom (actAtom state)
@@ -362,12 +383,6 @@ headChangesState gr state = errVal [] $ do
return [fun | (fun,typ) <- funRulesOf gr, fun /= f, typ == typ0]
--- alpha-conv !
canPeelState :: CGrammar -> State -> Bool
canPeelState gr state = errVal False $ do
f@(m,c) <- funAtom (actAtom state)
typ <- lookupFunType gr m c
return $ isInOneType typ
possibleRefVal :: CGrammar -> State -> Val -> Type -> Bool
possibleRefVal gr state val typ = errVal True $ do --- was False
vtyp <- valType typ

12
src/GF/UseGrammar/Generate.hs
View File

@@ -22,8 +22,8 @@ import List
--- if type were shown more modules should be imported
-- generateTrees ::
-- GFCGrammar -> Cat -> Int -> Maybe Int -> Maybe Tree -> [Exp]
generateTrees gr cat n mn mt = map str2tr $ generate gr' cat' n mn mt'
-- GFCGrammar -> Bool -> Cat -> Int -> Maybe Int -> Maybe Tree -> [Exp]
generateTrees gr ifm cat n mn mt = map str2tr $ generate gr' ifm cat' n mn mt'
where
gr' = gr2sgr gr
cat' = prt $ snd cat
@@ -63,8 +63,8 @@ tr2str (Tr (N (_,at,val,_,_),ts)) = case (at,val) of
-- if the depth is large (more than 3)
-- If a tree is given as argument, generation concerns its metavariables.
generate :: SGrammar -> SCat -> Int -> Maybe Int -> Maybe STree -> [STree]
generate gr cat i mn mt = case mt of
generate :: SGrammar -> Bool -> SCat -> Int -> Maybe Int -> Maybe STree -> [STree]
generate gr ifm cat i mn mt = case mt of
Nothing -> [t | (c,t) <- gen 0 [], c == cat]
Just t -> genM t
@@ -77,10 +77,12 @@ generate gr cat i mn mt = case mt of
args :: [SCat] -> [(SCat,STree)] -> [[STree]]
args cs cts = combinations
[constr (SMeta c : [t | (k,t) <- cts, k == c]) | c <- cs]
[constr (ifmetas c [t | (k,t) <- cts, k == c]) | c <- cs]
constr = maybe id take mn
ifmetas c = if ifm then (SMeta c :) else id
genM t = case t of
SApp (f,ts) -> [SApp (f,ts') | ts' <- combinations (map genM ts)]
SMeta k -> [t | (c,t) <- gen 0 [], c == k]

4
src/HelpFile
View File

@@ -167,6 +167,8 @@ gt, generate_trees: gt Tree?
a small -alts is recommended. If a Tree argument is given, the
command completes the Tree with values to the metavariables in
the tree.
flags:
-nometas don't return trees that include metavariables
flags:
-depth generate to this depth (default 3)
-alts take this number of alternatives at each branch (default unlimited)
@@ -368,7 +370,7 @@ q, quit: q
-printer=cf context-free grammar
*-printer=happy source file for Happy parser generator
-printer=srg speech recognition grammar
*-printer=haskell abstract syntax in Haskell, with transl to/from GF
-printer=haskell abstract syntax in Haskell, with transl to/from GF
-printer=morpho full-form lexicon, long format
*-printer=latex LaTeX file (for the tg command)
-printer=fullform full-form lexicon, short format

4
src/HelpFile.hs
View File

@@ -181,6 +181,8 @@ txtHelpFile =
"\n command completes the Tree with values to the metavariables in" ++
"\n the tree." ++
"\n flags:" ++
"\n -nometas don't return trees that include metavariables" ++
"\n flags:" ++
"\n -depth generate to this depth (default 3)" ++
"\n -alts take this number of alternatives at each branch (default unlimited)" ++
"\n -cat generate in this category" ++
@@ -381,7 +383,7 @@ txtHelpFile =
"\n -printer=cf context-free grammar" ++
"\n *-printer=happy source file for Happy parser generator" ++
"\n -printer=srg speech recognition grammar" ++
"\n *-printer=haskell abstract syntax in Haskell, with transl to/from GF" ++
"\n -printer=haskell abstract syntax in Haskell, with transl to/from GF" ++
"\n -printer=morpho full-form lexicon, long format" ++
"\n *-printer=latex LaTeX file (for the tg command)" ++
"\n -printer=fullform full-form lexicon, short format" ++

2
src/Today.hs
View File

@@ -1 +1 @@
module Today where today = "Mon May 3 10:59:20 CEST 2004"
module Today where today = "Tue May 18 23:54:22 CEST 2004"