Yay!! Direct generation of PMCFG from GF grammar

src/runtime/haskell/PGF/Check.hs

@@ -1,173 +0,0 @@
-module PGF.Check (checkPGF,checkLin) where
-
-import PGF.CId
-import PGF.Data
-import PGF.Macros
-import GF.Data.ErrM
-
-import qualified Data.Map as Map
-import Control.Monad
-import Data.Maybe(fromMaybe)
-import Debug.Trace
-
-checkPGF :: PGF -> Err (PGF,Bool)
-checkPGF pgf = return (pgf,True) {- do
-  (cs,bs) <- mapM (checkConcrete pgf) 
-               (Map.assocs (concretes pgf)) >>= return . unzip
-  return (pgf {concretes = Map.fromAscList cs}, and bs)
--}
-
--- errors are non-fatal; replace with 'fail' to change this
-msg s = trace s (return ())
-
-andMapM :: Monad m => (a -> m Bool) -> [a] -> m Bool
-andMapM f xs = mapM f xs >>= return . and
-
-labelBoolErr :: String -> Err (x,Bool) -> Err (x,Bool)
-labelBoolErr ms iob = do
-  (x,b) <- iob
-  if b then return (x,b) else (msg ms >> return (x,b))
-
-{-
-checkConcrete :: PGF -> (CId,Concr) -> Err ((CId,Concr),Bool)
-checkConcrete pgf (lang,cnc) = 
-  labelBoolErr ("happened in language " ++ showCId lang) $ do
-    (rs,bs) <- mapM checkl (Map.assocs (lins cnc)) >>= return . unzip
-    return ((lang,cnc{lins = Map.fromAscList rs}),and bs)
- where
-   checkl = checkLin pgf lang
--}
-
-type PGFSig = (Map.Map CId (Type,Int,Maybe [Equation]),Map.Map CId Term,Map.Map CId Term)
-
-checkLin :: PGFSig -> CId -> (CId,Term) -> Err ((CId,Term),Bool)
-checkLin pgf lang (f,t) = 
-  labelBoolErr ("happened in function " ++ showCId f) $ do
-    (t',b) <- checkTerm (lintype pgf lang f) t --- $ inline pgf lang t
-    return ((f,t'),b)
-
-inferTerm :: [CType] -> Term -> Err (Term,CType)
-inferTerm args trm = case trm of
-  K _ -> returnt str
-  C i -> returnt $ ints i
-  V i -> do
-    testErr (i < length args) ("too large index " ++ show i) 
-    returnt $ args !! i
-  S ts -> do
-    (ts',tys) <- mapM infer ts >>= return . unzip
-    let tys' = filter (/=str) tys
-    testErr (null tys')
-      ("expected Str in " ++ show trm ++ " not " ++ unwords (map show tys')) 
-    return (S ts',str)
-  R ts -> do
-    (ts',tys) <- mapM infer ts >>= return . unzip
-    return $ (R ts',tuple tys)
-  P t u -> do
-    (t',tt) <- infer t
-    (u',tu) <- infer u
-    case tt of
-      R tys -> case tu of
-        R vs -> infer $ foldl P t' [P u' (C i) | i <- [0 .. length vs - 1]]
-        --- R [v] -> infer $ P t v
-        --- R (v:vs) -> infer $ P (head tys) (R vs)
-        
-        C i -> do
-          testErr (i < length tys) 
-            ("required more than " ++ show i ++ " fields in " ++ show (R tys)) 
-          return (P t' u', tys !! i) -- record: index must be known
-        _ -> do
-          let typ = head tys
-          testErr (all (==typ) tys) ("different types in table " ++ show trm) 
-          return (P t' u', typ)      -- table: types must be same
-      _ -> Bad $ "projection from " ++ show t ++ " : " ++ show tt
-  FV [] -> returnt tm0 ----
-  FV (t:ts) -> do
-    (t',ty) <- infer t
-    (ts',tys) <- mapM infer ts >>= return . unzip
-    testErr (all (eqType True ty) tys) ("different types in variants " ++ show trm)
-    return (FV (t':ts'),ty)
-  W s r -> infer r
-  _ -> Bad ("no type inference for " ++ show trm)
- where
-   returnt ty = return (trm,ty)
-   infer = inferTerm args
-
-checkTerm :: LinType -> Term -> Err (Term,Bool)
-checkTerm (args,val) trm = case inferTerm args trm of
-  Ok (t,ty) -> if eqType False ty val 
-             then return (t,True) 
-             else do
-    msg ("term: " ++ show trm ++ 
-               "\nexpected type: " ++ show val ++
-               "\ninferred type: " ++ show ty)
-    return (t,False)
-  Bad s -> do
-    msg s
-    return (trm,False)
-
--- symmetry in (Ints m == Ints n) is all we can use in variants
-
-eqType :: Bool -> CType -> CType -> Bool
-eqType symm inf exp = case (inf,exp) of
-  (C k, C n)  -> if symm then True else k <= n -- only run-time corr.
-  (R rs,R ts) -> length rs == length ts && and [eqType symm r t | (r,t) <- zip rs ts]
-  (TM _,  _)  -> True ---- for variants [] ; not safe
-  _ -> inf == exp
-
--- should be in a generic module, but not in the run-time DataGFCC
-
-type CType = Term
-type LinType = ([CType],CType)
-
-tuple :: [CType] -> CType
-tuple = R
-
-ints :: Int -> CType
-ints = C
-
-str :: CType
-str = S []
-
-lintype :: PGFSig -> CId -> CId -> LinType
-lintype pgf lang fun = case typeSkeleton (lookFun pgf fun) of
-  (cs,c) -> (map vlinc cs, linc c) ---- HOAS
- where 
-   linc = lookLincat pgf lang
-   vlinc (0,c) = linc c
-   vlinc (i,c) = case linc c of
-     R ts -> R (ts ++ replicate i str)
-
-composOp :: Monad m => (Term -> m Term) -> Term -> m Term
-composOp f trm = case trm of
-  R  ts -> liftM R $ mapM f ts
-  S  ts -> liftM S $ mapM f ts
-  FV ts -> liftM FV $ mapM f ts
-  P t u -> liftM2 P (f t) (f u)
-  W s t -> liftM (W s) $ f t
-  _ -> return trm
-
-composSafeOp :: (Term -> Term) -> Term -> Term
-composSafeOp f = maybe undefined id . composOp (return . f)
-
--- from GF.Data.Oper
-
-maybeErr :: String -> Maybe a -> Err a
-maybeErr s = maybe (Bad s) Ok
-
-testErr :: Bool -> String -> Err ()
-testErr cond msg = if cond then return () else Bad msg
-
-errVal :: a -> Err a -> a
-errVal a = err (const a) id
-
-errIn :: String -> Err a -> Err a
-errIn msg = err (\s -> Bad (s ++ "\nOCCURRED IN\n" ++ msg)) return
-
-err :: (String -> b) -> (a -> b) -> Err a -> b 
-err d f e = case e of
-  Ok a -> f a
-  Bad s -> d s
-
-lookFun    (abs,lin,lincats)   f = (\(a,b,c) -> a) $ fromMaybe (error "No abs") (Map.lookup f abs)
-lookLincat (abs,lin,lincats) _ c = fromMaybe (error "No lincat") (Map.lookup c lincats)
-lookLin    (abs,lin,lincats) _ f = fromMaybe (error "No lin") (Map.lookup f lin)

src/runtime/haskell/PGF/Data.hs

@@ -68,22 +68,6 @@ data Alternative =
    Alt [String] [String]
   deriving (Eq,Ord,Show)
 
-data Term =
-   R [Term]
- | P Term Term
- | S [Term]
- | K Tokn
- | V Int
- | C Int
- | FV [Term]
- | W String Term
- | TM String
-  deriving (Eq,Ord,Show)
-
-data Tokn =
-   KS String
- | KP [String] [Alternative]
-  deriving (Eq,Ord,Show)
 
 -- merge two PGFs; fails is differens absnames; priority to second arg
 

src/runtime/haskell/PGF/Macros.hs

@@ -117,15 +117,6 @@ contextLength ty = case ty of
 showPrintName :: PGF -> Language -> CId -> String
 showPrintName pgf lang id = lookMap (showCId id) id $ printnames $ lookMap (error "no lang") lang $ concretes pgf
 
-term0 :: CId -> Term
-term0 = TM . showCId
-
-tm0 :: Term
-tm0 = TM "?"
-
-kks :: String -> Term
-kks = K . KS
-
 -- lookup with default value
 lookMap :: (Show i, Ord i) => a -> i -> Map.Map i a -> a 
 lookMap d c m = Map.findWithDefault d c m

src/runtime/haskell/PGF/VisualizeTree.hs

@@ -28,7 +28,8 @@ import PGF.CId (CId,showCId,ppCId,pCId,mkCId)
 import PGF.Data
 import PGF.Expr (showExpr, Tree)
 import PGF.Linearize
-import PGF.Macros (lookValCat, lookMap, _B, _V, BracketedString(..), flattenBracketedString)
+import PGF.Macros (lookValCat, lookMap, _B, _V,
+                   BracketedString(..), BracketedTokn(..), flattenBracketedString)
 
 import qualified Data.Map as Map
 import qualified Data.IntMap as IntMap
@@ -274,7 +275,7 @@ tag i
 --
 -- Uuuuugly!!! I hope that this code will be removed one day.
 
-type LinTable = Array LIndex [Tokn]
+type LinTable = Array LIndex [BracketedTokn]
 
 
 linTree :: PGF -> Language -> (Maybe CId -> [Int] -> LinTable -> LinTable) -> Expr -> [LinTable]
@@ -299,7 +300,7 @@ linTree pgf lang mark e = lin0 [] [] [] Nothing e
     lin path xs mb_fid (ETyped e _) es = lin path xs mb_fid e es
     lin path xs mb_fid (EImplArg e) es = lin path xs mb_fid e es
 
-    ss s = listArray (0,0) [[KS s]]
+    ss s = listArray (0,0) [[LeafKS [s]]]
 
     apply path xs mb_fid f es =
       case Map.lookup f lp of
@@ -332,15 +333,15 @@ linTree pgf lang mark e = lin0 [] [] [] Nothing e
 
             compute (SymCat d r)    = (args !! d) ! r
             compute (SymLit d r)    = (args !! d) ! r
-            compute (SymKS ts)      = map KS ts
-            compute (SymKP ts alts) = [KP ts alts]
+            compute (SymKS ts)      = [LeafKS ts]
+            compute (SymKP ts alts) = [LeafKP ts alts]
 
-untokn :: [Tokn] -> [String]
+untokn :: [BracketedTokn] -> [String]
 untokn ts = case ts of
-  KP d _  : [] -> d
-  KP d vs : ws -> let ss@(s:_) = untokn ws in sel d vs s ++ ss
-  KS s    : ws -> s : untokn ws
-  []           -> []
+  LeafKP d _  : [] -> d
+  LeafKP d vs : ws -> let ss@(s:_) = untokn ws in sel d vs s ++ ss
+  LeafKS s    : ws -> s ++ untokn ws
+  []               -> []
  where
    sel d vs w = case [v | Alt v cs <- vs, any (\c -> isPrefixOf c w) cs] of
      v:_ -> v
@@ -353,8 +354,8 @@ markLinearizes pgf lang = map (unwords . untokn . (! 0)) . linTree pgf lang mark
   where
     mark mb_f path lint = amap (bracket mb_f path) lint
 
-    bracket Nothing  path ts = [KS ("("++show (reverse path))] ++ ts ++ [KS ")"]
-    bracket (Just f) path ts = [KS ("(("++showCId f++","++show (reverse path)++")")] ++ ts ++ [KS ")"]
+    bracket Nothing  path ts = [LeafKS ["("++show (reverse path)]] ++ ts ++ [LeafKS [")"]]
+    bracket (Just f) path ts = [LeafKS ["(("++showCId f++","++show (reverse path)++")"]] ++ ts ++ [LeafKS [")"]]
 
 
 graphvizDependencyTree :: String -> Bool -> Maybe Labels -> Maybe String -> PGF -> CId -> Expr -> String