diff --git a/src/GF/API.hs b/src/GF/API.hs index d748a5517..42101706d 100644 --- a/src/GF/API.hs +++ b/src/GF/API.hs @@ -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 diff --git a/src/GF/API/GrammarToHaskell.hs b/src/GF/API/GrammarToHaskell.hs new file mode 100644 index 000000000..c7e3488ce --- /dev/null +++ b/src/GF/API/GrammarToHaskell.hs @@ -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 + diff --git a/src/GF/Data/Zipper.hs b/src/GF/Data/Zipper.hs index a696f1cae..e63743b06 100644 --- a/src/GF/Data/Zipper.hs +++ b/src/GF/Data/Zipper.hs @@ -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 \ No newline at end of file diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs index b74d02fd8..cdaea6734 100644 --- a/src/GF/Grammar/Macros.hs +++ b/src/GF/Grammar/Macros.hs @@ -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 diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs index 7e273025f..b2a5902cc 100644 --- a/src/GF/Infra/Option.hs +++ b/src/GF/Infra/Option.hs @@ -140,6 +140,7 @@ tableLin = iOpt "table" defaultLinOpts = [firstLin] useUTF8 = iOpt "utf8" showLang = iOpt "lang" +noMetas = iOpt "nometas" -- other beVerbose = iOpt "v" diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs index 61fa7ce1e..f5692a398 100644 --- a/src/GF/Shell.hs +++ b/src/GF/Shell.hs @@ -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 diff --git a/src/GF/Shell/CommandL.hs b/src/GF/Shell/CommandL.hs index 3fd64dd00..5945dd271 100644 --- a/src/GF/Shell/CommandL.hs +++ b/src/GF/Shell/CommandL.hs @@ -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 diff --git a/src/GF/Shell/Commands.hs b/src/GF/Shell/Commands.hs index 345e5cd02..25ef5607f 100644 --- a/src/GF/Shell/Commands.hs +++ b/src/GF/Shell/Commands.hs @@ -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) diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs index 71bbfab58..7770386ec 100644 --- a/src/GF/UseGrammar/Custom.hs +++ b/src/GF/UseGrammar/Custom.hs @@ -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 diff --git a/src/GF/UseGrammar/Editing.hs b/src/GF/UseGrammar/Editing.hs index 3c3567394..6f444efe8 100644 --- a/src/GF/UseGrammar/Editing.hs +++ b/src/GF/UseGrammar/Editing.hs @@ -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 diff --git a/src/GF/UseGrammar/Generate.hs b/src/GF/UseGrammar/Generate.hs index ad15287b9..85af4e8aa 100644 --- a/src/GF/UseGrammar/Generate.hs +++ b/src/GF/UseGrammar/Generate.hs @@ -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] diff --git a/src/HelpFile b/src/HelpFile index fa49f89ef..8184b4603 100644 --- a/src/HelpFile +++ b/src/HelpFile @@ -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 diff --git a/src/HelpFile.hs b/src/HelpFile.hs index b6a2eadf2..1dda915d7 100644 --- a/src/HelpFile.hs +++ b/src/HelpFile.hs @@ -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" ++ diff --git a/src/Today.hs b/src/Today.hs index 1175e0b6e..002cdf2bf 100644 --- a/src/Today.hs +++ b/src/Today.hs @@ -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"