summaryrefslogtreecommitdiff
path: root/src/GF/Compile/Flatten.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF/Compile/Flatten.hs')
-rw-r--r--src/GF/Compile/Flatten.hs92
1 files changed, 0 insertions, 92 deletions
diff --git a/src/GF/Compile/Flatten.hs b/src/GF/Compile/Flatten.hs
deleted file mode 100644
index 6b25edebb..000000000
--- a/src/GF/Compile/Flatten.hs
+++ /dev/null
@@ -1,92 +0,0 @@
-module Flatten where
-
-import Data.List
--- import GF.Data.Operations
-
--- (AR 15/3/2006)
---
--- A method for flattening grammars: create many flat rules instead of
--- a few deep ones. This is generally better for parsins.
--- The rules are obtained as follows:
--- 1. write a config file tellinq which constants are variables: format 'c : C'
--- 2. generate a list of trees with their types: format 't : T'
--- 3. for each such tree, form a fun rule 'fun fui : X -> Y -> T' and a lin
--- rule 'lin fui x y = t' where x:X,y:Y is the list of variables in t, as
--- found in the config file.
--- 4. You can go on and produce def or transfer rules similar to the lin rules
--- except for the keyword.
---
--- So far this module is used outside gf. You can e.g. generate a list of
--- trees by 'gt', write it in a file, and then in ghci call
--- flattenGrammar <Config> <Trees> <OutFile>
-
-type Ident = String ---
-type Term = String ---
-type Rule = String ---
-
-type Config = [(Ident,Ident)]
-
-flattenGrammar :: FilePath -> FilePath -> FilePath -> IO ()
-flattenGrammar conff tf out = do
- conf <- readFile conff >>= return . lines
- ts <- readFile tf >>= return . lines
- writeFile out $ mkFlatten conf ts
-
-mkFlatten :: [String] -> [String] -> String
-mkFlatten conff = unlines . concatMap getOne . zip [1..] where
- getOne (k,t) = let (x,y) = mkRules conf ("fu" ++ show k) t in [x,y]
- conf = getConfig conff
-
-mkRules :: Config -> Ident -> Term -> (Rule,Rule)
-mkRules conf f t = (fun f ty, lin f (takeWhile (/=':') t)) where
- args = mkArgs conf ts
- ty = concat [a ++ " -> " | a <- map snd args] ++ val
- (ts,val) = let tt = lexTerm t in (init tt,last tt)
---- f = mkIdent t
- fun c a = unwords [" fun", c, ":",a,";"]
- lin c a = unwords $ [" lin", c] ++ map fst args ++ ["=",a,";"]
-
-mkArgs :: Config -> [Ident] -> [(Ident,Ident)]
-mkArgs conf ids = [(x,ty) | x <- ids, Just ty <- [lookup x conf]]
-
-mkIdent :: Term -> Ident
-mkIdent = map mkChar where
- mkChar c = case c of
- '(' -> '6'
- ')' -> '9'
- ' ' -> '_'
- _ -> c
-
--- to get just the identifiers
-lexTerm :: String -> [String]
-lexTerm ss = case lex ss of
- [([c],ws)] | isSpec c -> lexTerm ws
- [(w@(_:_),ws)] -> w : lexTerm ws
- _ -> []
- where
- isSpec = flip elem "();:"
-
-
-getConfig :: [String] -> Config
-getConfig = map getOne . filter (not . null) where
- getOne line = case lexTerm line of
- v:c:_ -> (v,c)
-
-ex = putStrLn fs where
- fs =
- mkFlatten
- ["man_N : N",
- "sleep_V : V"
- ]
- ["PredVP (DefSg man_N) (UseV sleep_V) : Cl",
- "PredVP (DefPl man_N) (UseV sleep_V) : Cl"
- ]
-
-{-
--- result of ex
-
- fun fu1 : N -> V -> Cl ;
- lin fu1 man_N sleep_V = PredVP (DefSg man_N) (UseV sleep_V) ;
- fun fu2 : N -> V -> Cl ;
- lin fu2 man_N sleep_V = PredVP (DefPl man_N) (UseV sleep_V) ;
--}