cleanup the code of the PGF interpreter and polish the binary serialization to match the preliminary specification

10 files changed, 252 insertions, 218 deletions

diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs
index 85b661c3d..9bc5c6567 100644
--- a/src/runtime/haskell/PGF.hs
+++ b/src/runtime/haskell/PGF.hs
@@ -103,7 +103,7 @@ import PGF.VisualizeTree
 import PGF.Macros
 import PGF.Expr (Tree)
 import PGF.Morphology
-import PGF.Data hiding (functions)
+import PGF.Data
 import PGF.Binary
 import qualified PGF.Parse as Parse
 
@@ -252,10 +252,12 @@ generateAllDepth pgf cat = generate pgf cat
 
 abstractName pgf = absname pgf
 
-languages pgf = cncnames pgf
+languages pgf = Map.keys (concretes pgf)
 
 languageCode pgf lang = 
-    fmap (replace '_' '-') $ lookConcrFlag pgf lang (mkCId "language")
+    case lookConcrFlag pgf lang (mkCId "language") of
+      Just (LStr s) -> Just (replace '_' '-' s)
+      _             -> Nothing
 
 categories pgf = [c | (c,hs) <- Map.toList (cats (abstract pgf))]
 
diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs
index 66caef1da..bc46390f4 100644
--- a/src/runtime/haskell/PGF/Binary.hs
+++ b/src/runtime/haskell/PGF/Binary.hs
@@ -6,6 +6,7 @@ import PGF.Macros
 import Data.Binary

 import Data.Binary.Put

 import Data.Binary.Get

+import Data.Array.IArray

 import qualified Data.ByteString as BS

 import qualified Data.Map as Map

 import qualified Data.IntMap as IntMap

@@ -16,23 +17,20 @@ pgfMajorVersion, pgfMinorVersion :: Word16
 (pgfMajorVersion, pgfMinorVersion) = (1,0)

 

 instance Binary PGF where

-  put pgf = putWord16be pgfMajorVersion >>

-            putWord16be pgfMinorVersion >>

-            put ( absname pgf, cncnames pgf

-                , gflags pgf

-                , abstract pgf, concretes pgf

-                )

+  put pgf = do putWord16be pgfMajorVersion

+               putWord16be pgfMinorVersion

+               put (gflags pgf)

+               put (absname pgf, abstract pgf)

+               put (concretes pgf)

   get = do v1 <- getWord16be

            v2 <- getWord16be

-           absname <- get

-           cncnames <- get

            gflags <- get

-           abstract <- get

+           (absname,abstract) <- get

            concretes <- get

            return $ updateProductionIndices $

-                      (PGF{ absname=absname, cncnames=cncnames

-                          , gflags=gflags

-                          , abstract=abstract, concretes=concretes

+                      (PGF{ gflags=gflags

+                          , absname=absname, abstract=abstract

+                          , concretes=concretes

                           })

 

 instance Binary CId where

@@ -44,35 +42,35 @@ instance Binary Abstr where
   get = do aflags <- get

            funs <- get

            cats <- get

-           let catfuns = Map.mapWithKey (\cat _ -> [f | (f, (DTyp _ c _,_,_)) <- Map.toList funs, c==cat]) cats

            return (Abstr{ aflags=aflags

                         , funs=funs, cats=cats

-                        , catfuns=catfuns

+                        , catfuns=Map.empty

                         })

   

 instance Binary Concr where

-  put cnc = put ( cflags cnc, printnames cnc

-                , functions cnc, sequences cnc

-                , productions cnc

-                , totalCats cnc, startCats cnc

-                )

+  put cnc = do put (cflags cnc)

+               put (printnames cnc)

+               putArray2 (sequences cnc)

+               putArray (cncfuns cnc)

+               put (productions cnc)

+               put (cnccats cnc)

+               put (totalCats cnc)

   get = do cflags      <- get

            printnames  <- get

-           functions   <- get

-           sequences   <- get

+           sequences   <- getArray2

+           cncfuns     <- getArray

            productions <- get

+           cnccats     <- get

            totalCats   <- get

-           startCats   <- get

            return (Concr{ cflags=cflags, printnames=printnames

-                        , functions=functions,sequences=sequences

-                        , productions = productions

+                        , sequences=sequences, cncfuns=cncfuns, productions=productions

                         , pproductions = IntMap.empty

                         , lproductions = Map.empty

-                        , totalCats=totalCats,startCats=startCats

+                        , cnccats=cnccats, totalCats=totalCats

                         })

 

 instance Binary Alternative where

-  put (Alt v x) = put v >> put x

+  put (Alt v x) = put (v,x)

   get = liftM2 Alt get get

 

 instance Binary Term where

@@ -106,41 +104,37 @@ instance Binary Term where
 instance Binary Expr where

   put (EAbs b x exp)  = putWord8 0 >> put (b,x,exp)

   put (EApp e1 e2)    = putWord8 1 >> put (e1,e2)

-  put (ELit (LStr s)) = putWord8 2 >> put s

-  put (ELit (LFlt d)) = putWord8 3 >> put d

-  put (ELit (LInt i)) = putWord8 4 >> put i

-  put (EMeta i)       = putWord8 5 >> put i

-  put (EFun  f)       = putWord8 6 >> put f

-  put (EVar  i)       = putWord8 7 >> put i

-  put (ETyped e ty)   = putWord8 8 >> put (e,ty)

+  put (ELit l)        = putWord8 2 >> put l

+  put (EMeta i)       = putWord8 3 >> put i

+  put (EFun  f)       = putWord8 4 >> put f

+  put (EVar  i)       = putWord8 5 >> put i

+  put (ETyped e ty)   = putWord8 6 >> put (e,ty)

+  put (EImplArg e)    = putWord8 7 >> put e

   get = do tag <- getWord8

            case tag of

              0 -> liftM3 EAbs get get get

              1 -> liftM2 EApp get get

-             2 -> liftM  (ELit . LStr) get

-             3 -> liftM  (ELit . LFlt) get

-             4 -> liftM  (ELit . LInt) get

-             5 -> liftM  EMeta get

-             6 -> liftM  EFun get

-             7 -> liftM  EVar get

-             8 -> liftM2 ETyped get get

+             2 -> liftM  ELit get

+             3 -> liftM  EMeta get

+             4 -> liftM  EFun get

+             5 -> liftM  EVar get

+             6 -> liftM2 ETyped get get

+             7 -> liftM  EImplArg get

              _ -> decodingError

 

 instance Binary Patt where

-  put (PApp f ps)     = putWord8 0 >> put (f,ps)

-  put (PVar   x)      = putWord8 1 >> put x

-  put PWild           = putWord8 2

-  put (PLit (LStr s)) = putWord8 3 >> put s

-  put (PLit (LFlt d)) = putWord8 4 >> put d

-  put (PLit (LInt i)) = putWord8 5 >> put i

+  put (PApp f ps)  = putWord8 0 >> put (f,ps)

+  put (PVar   x)   = putWord8 1 >> put x

+  put PWild        = putWord8 2

+  put (PLit l)     = putWord8 3 >> put l

+  put (PImplArg p) = putWord8 4 >> put p

   get = do tag <- getWord8

            case tag of

              0 -> liftM2 PApp get get

              1 -> liftM  PVar get

              2 -> return PWild

-             3 -> liftM  (PLit . LStr) get

-             4 -> liftM  (PLit . LFlt) get

-             5 -> liftM  (PLit . LInt) get

+             3 -> liftM  PLit get

+             4 -> liftM  PImplArg get

              _ -> decodingError

 

 instance Binary Equation where

@@ -160,30 +154,65 @@ instance Binary BindType where
              1 -> return Implicit

              _ -> decodingError

 

-instance Binary FFun where

-  put (FFun fun lins) = put (fun,lins)

-  get = liftM2 FFun get get

+instance Binary CncFun where

+  put (CncFun fun lins) = put fun >> putArray lins

+  get = liftM2 CncFun get getArray

 

-instance Binary FSymbol where

-  put (FSymCat n l)       = putWord8 0 >> put (n,l)

-  put (FSymLit n l)       = putWord8 1 >> put (n,l)

-  put (FSymKS ts)         = putWord8 2 >> put ts

-  put (FSymKP d vs)       = putWord8 3 >> put (d,vs)

+instance Binary CncCat where

+  put (CncCat s e labels) = do put (s,e)

+                               putArray labels

+  get = liftM3 CncCat get get getArray

+

+instance Binary Symbol where

+  put (SymCat n l)       = putWord8 0 >> put (n,l)

+  put (SymLit n l)       = putWord8 1 >> put (n,l)

+  put (SymKS ts)         = putWord8 2 >> put ts

+  put (SymKP d vs)       = putWord8 3 >> put (d,vs)

   get = do tag <- getWord8

            case tag of

-             0 -> liftM2 FSymCat get get

-             1 -> liftM2 FSymLit get get

-             2 -> liftM  FSymKS  get

-             3 -> liftM2 (\d vs -> FSymKP d vs) get get

+             0 -> liftM2 SymCat get get

+             1 -> liftM2 SymLit get get

+             2 -> liftM  SymKS  get

+             3 -> liftM2 (\d vs -> SymKP d vs) get get

              _ -> decodingError

 

 instance Binary Production where

-  put (FApply ruleid args) = putWord8 0 >> put (ruleid,args)

-  put (FCoerce fcat)       = putWord8 1 >> put fcat

+  put (PApply ruleid args) = putWord8 0 >> put (ruleid,args)

+  put (PCoerce fcat)       = putWord8 1 >> put fcat

+  get = do tag <- getWord8

+           case tag of

+             0 -> liftM2 PApply  get get

+             1 -> liftM  PCoerce get

+             _ -> decodingError

+

+instance Binary Literal where

+  put (LStr s) = putWord8 0 >> put s

+  put (LInt i) = putWord8 1 >> put i

+  put (LFlt d) = putWord8 2 >> put d

   get = do tag <- getWord8

            case tag of

-             0 -> liftM2 FApply  get get

-             1 -> liftM  FCoerce get

+             0 -> liftM  LStr get

+             1 -> liftM  LFlt get

+             2 -> liftM  LInt get

              _ -> decodingError

 

+

+putArray :: (Binary e, IArray a e) => a Int e -> Put

+putArray a = do put (rangeSize $ bounds a) -- write the length

+                mapM_ put (elems a)        -- now the elems.

+

+getArray :: (Binary e, IArray a e) => Get (a Int e)

+getArray = do n  <- get                  -- read the length

+              xs <- replicateM n get     -- now the elems.

+              return (listArray (0,n-1) xs)

+

+putArray2 :: (Binary e, IArray a1 (a2 Int e), IArray a2 e) => a1 Int (a2 Int e) -> Put

+putArray2 a = do put (rangeSize $ bounds a) -- write the length

+                 mapM_ putArray (elems a)        -- now the elems.

+

+getArray2 :: (Binary e, IArray a1 (a2 Int e), IArray a2 e) => Get (a1 Int (a2 Int e))

+getArray2 = do n  <- get                       -- read the length

+               xs <- replicateM n getArray     -- now the elems.

+               return (listArray (0,n-1) xs)

+

 decodingError = fail "This PGF file was compiled with different version of GF"

diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs
index 7b3f3435f..f2b4b913c 100644
--- a/src/runtime/haskell/PGF/Data.hs
+++ b/src/runtime/haskell/PGF/Data.hs
@@ -17,48 +17,48 @@ import Data.List
 -- | An abstract data type representing multilingual grammar
 -- in Portable Grammar Format.
 data PGF = PGF {
+  gflags    :: Map.Map CId Literal,   -- value of a global flag
   absname   :: CId ,
-  cncnames  :: [CId] ,
-  gflags    :: Map.Map CId String,   -- value of a global flag
   abstract  :: Abstr ,
   concretes :: Map.Map CId Concr
   }
 
 data Abstr = Abstr {
-  aflags  :: Map.Map CId String,      -- value of a flag
+  aflags  :: Map.Map CId Literal,     -- value of a flag
   funs    :: Map.Map CId (Type,Int,[Equation]), -- type, arrity and definition of function
   cats    :: Map.Map CId [Hypo],      -- context of a cat
   catfuns :: Map.Map CId [CId]        -- funs to a cat (redundant, for fast lookup)
   }
 
 data Concr = Concr {
-  cflags       :: Map.Map CId String,                                -- value of a flag
+  cflags       :: Map.Map CId Literal,                               -- value of a flag
   printnames   :: Map.Map CId String,                                -- printname of a cat or a fun
-  functions    :: Array FunId FFun,
-  sequences    :: Array SeqId FSeq,
+  cncfuns      :: Array FunId CncFun,
+  sequences    :: Array SeqId Sequence,
   productions  :: IntMap.IntMap (Set.Set Production),                -- the original productions loaded from the PGF file
   pproductions :: IntMap.IntMap (Set.Set Production),                -- productions needed for parsing
   lproductions :: Map.Map CId (IntMap.IntMap (Set.Set Production)),  -- productions needed for linearization
-  startCats    :: Map.Map CId (FCat,FCat,Array FIndex String),       -- for every category - start/end FCat and a list of label names
-  totalCats    :: {-# UNPACK #-} !FCat
+  cnccats      :: Map.Map CId CncCat,
+  totalCats    :: {-# UNPACK #-} !FId
   }
 
-type FCat      = Int
-type FIndex    = Int
-type FPointPos = Int
-data FSymbol
-  = FSymCat {-# UNPACK #-} !Int {-# UNPACK #-} !FIndex
-  | FSymLit {-# UNPACK #-} !Int {-# UNPACK #-} !FIndex
-  | FSymKS [String]
-  | FSymKP [String] [Alternative]
+type FId    = Int
+type LIndex = Int
+type DotPos = Int
+data Symbol
+  = SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
+  | SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
+  | SymKS [String]
+  | SymKP [String] [Alternative]
   deriving (Eq,Ord,Show)
 data Production
-  = FApply  {-# UNPACK #-} !FunId [FCat]
-  | FCoerce {-# UNPACK #-} !FCat
-  | FConst  Expr [String]
+  = PApply  {-# UNPACK #-} !FunId [FId]
+  | PCoerce {-# UNPACK #-} !FId
+  | PConst  Expr [String]
   deriving (Eq,Ord,Show)
-data FFun  = FFun CId {-# UNPACK #-} !(UArray FIndex SeqId) deriving (Eq,Ord,Show)
-type FSeq  = Array FPointPos FSymbol
+data CncCat = CncCat {-# UNPACK #-} !FId {-# UNPACK #-} !FId {-# UNPACK #-} !(Array LIndex String)
+data CncFun = CncFun CId {-# UNPACK #-} !(UArray LIndex SeqId) deriving (Eq,Ord,Show)
+type Sequence = Array DotPos Symbol
 type FunId = Int
 type SeqId = Int
 
@@ -91,16 +91,14 @@ unionPGF :: PGF -> PGF -> PGF
 unionPGF one two = case absname one of
   n | n == wildCId     -> two    -- extending empty grammar
     | n == absname two -> one {  -- extending grammar with same abstract
-      concretes = Map.union (concretes two) (concretes one),
-      cncnames  = union (cncnames one) (cncnames two)
+      concretes = Map.union (concretes two) (concretes one)
     }
   _ -> one   -- abstracts don't match ---- print error msg
 
 emptyPGF :: PGF
 emptyPGF = PGF {
-  absname   = wildCId,
-  cncnames  = [] ,
   gflags    = Map.empty,
+  absname   = wildCId,
   abstract  = error "empty grammar, no abstract",
   concretes = Map.empty
   }
@@ -126,5 +124,5 @@ fcatInt    = (-2)
 fcatFloat  = (-3)
 fcatVar    = (-4)
 
-isLiteralFCat :: FCat -> Bool
+isLiteralFCat :: FId -> Bool
 isLiteralFCat = (`elem` [fcatString, fcatInt, fcatFloat, fcatVar])
diff --git a/src/runtime/haskell/PGF/Expr.hs b/src/runtime/haskell/PGF/Expr.hs
index 2357026ab..674422217 100644
--- a/src/runtime/haskell/PGF/Expr.hs
+++ b/src/runtime/haskell/PGF/Expr.hs
@@ -31,7 +31,7 @@ import qualified Text.ParserCombinators.ReadP as RP
 

 data Literal = 

    LStr String                      -- ^ string constant

- | LInt Integer                     -- ^ integer constant

+ | LInt Int                         -- ^ integer constant

  | LFlt Double                      -- ^ floating point constant

  deriving (Eq,Ord,Show)

 

@@ -116,11 +116,11 @@ unStr (ELit (LStr s)) = Just s
 unStr _               = Nothing

 

 -- | Constructs an expression from integer literal

-mkInt :: Integer -> Expr

+mkInt :: Int -> Expr

 mkInt i = ELit (LInt i)

 

 -- | Decomposes an expression into integer literal

-unInt :: Expr -> Maybe Integer

+unInt :: Expr -> Maybe Int

 unInt (ELit (LInt i)) = Just i

 unInt _               = Nothing

 

@@ -236,7 +236,7 @@ ppBind Explicit x = ppCId x
 ppBind Implicit x = PP.braces (ppCId x)

 

 ppLit (LStr s) = PP.text (show s)

-ppLit (LInt n) = PP.integer n

+ppLit (LInt n) = PP.int n

 ppLit (LFlt d) = PP.double d

 

 ppMeta :: MetaId -> PP.Doc

diff --git a/src/runtime/haskell/PGF/Linearize.hs b/src/runtime/haskell/PGF/Linearize.hs
index 3d6624e28..3dadd1580 100644
--- a/src/runtime/haskell/PGF/Linearize.hs
+++ b/src/runtime/haskell/PGF/Linearize.hs
@@ -12,7 +12,7 @@ import qualified Data.Set as Set
 
 -- linearization and computation of concrete PGF Terms
 
-type LinTable = Array FIndex [Tokn]
+type LinTable = Array LIndex [Tokn]
 
 linearizes :: PGF -> CId -> Expr -> [String]
 linearizes pgf lang = map (unwords . untokn . (! 0)) . linTree pgf lang (\_ _ lint -> lint)
@@ -46,11 +46,11 @@ linTree pgf lang mark e = lin0 [] [] [] Nothing e
         Just prods -> case lookupProds mb_fid prods of
                         Just set -> do prod <- Set.toList set
                                        case prod of
-                                         FApply funid fids -> do guard (length fids == length es)
+                                         PApply funid fids -> do guard (length fids == length es)
                                                                  args <- sequence (zipWith3 (\i fid e -> lin0 (sub i path) [] xs (Just fid) e) [0..] fids es)
-                                                                 let (FFun _ lins) = functions cnc ! funid
+                                                                 let (CncFun _ lins) = cncfuns cnc ! funid
                                                                  return (listArray (bounds lins) [computeSeq seqid args | seqid <- elems lins])
-                                         FCoerce fid       -> apply path xs (Just fid) f es
+                                         PCoerce fid       -> apply path xs (Just fid) f es
                         Nothing  -> mzero
         Nothing    -> apply path xs mb_fid _V [ELit (LStr "?")]              -- function without linearization
       where
@@ -63,17 +63,17 @@ linTree pgf lang mark e = lin0 [] [] [] Nothing e
           | f == _B || f == _V =   path
           | otherwise          = i:path
 
-        isApp (FApply _ _) = True
+        isApp (PApply _ _) = True
         isApp _            = False
 
         computeSeq seqid args = concatMap compute (elems seq)
           where
             seq = sequences cnc ! seqid
 
-            compute (FSymCat d r)    = (args !! d) ! r
-            compute (FSymLit d r)    = (args !! d) ! r
-            compute (FSymKS ts)      = map KS ts
-            compute (FSymKP ts alts) = [KP ts alts]
+            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]
 
 untokn :: [Tokn] -> [String]
 untokn ts = case ts of
@@ -92,9 +92,9 @@ tabularLinearizes pgf lang e = map (zip lbls . map (unwords . untokn) . elems) (
   where
     lbls = case unApp e of
              Just (f,_) -> let cat = valCat (lookType pgf f)
-                           in case Map.lookup cat (startCats (lookConcr pgf lang)) of
-                                Just (_,_,lbls) -> elems lbls
-                                Nothing         -> error "No labels"
+                           in case Map.lookup cat (cnccats (lookConcr pgf lang)) of
+                                Just (CncCat _ _ lbls) -> elems lbls
+                                Nothing                -> error "No labels"
              Nothing    -> error "Not function application"
 
 
diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs
index de6436425..03c5d0fe4 100644
--- a/src/runtime/haskell/PGF/Macros.hs
+++ b/src/runtime/haskell/PGF/Macros.hs
@@ -37,22 +37,22 @@ lookValCat :: PGF -> CId -> CId
 lookValCat pgf = valCat . lookType pgf
 
 lookStartCat :: PGF -> CId
-lookStartCat pgf = mkCId $ fromMaybe "S" $ msum $ Data.List.map (Map.lookup (mkCId "startcat"))
-                                                        [gflags pgf, aflags (abstract pgf)]
+lookStartCat pgf = mkCId $
+  case msum $ Data.List.map (Map.lookup (mkCId "startcat")) [gflags pgf, aflags (abstract pgf)] of
+    Just (LStr s) -> s
+    _             -> "S"
 
-lookGlobalFlag :: PGF -> CId -> String
-lookGlobalFlag pgf f = 
-  lookMap "?" f (gflags pgf)
+lookGlobalFlag :: PGF -> CId -> Maybe Literal
+lookGlobalFlag pgf f = Map.lookup f (gflags pgf)
 
-lookAbsFlag :: PGF -> CId -> String
-lookAbsFlag pgf f = 
-  lookMap "?" f (aflags (abstract pgf))
+lookAbsFlag :: PGF -> CId -> Maybe Literal
+lookAbsFlag pgf f = Map.lookup f (aflags (abstract pgf))
 
 lookConcr :: PGF -> CId -> Concr
 lookConcr pgf cnc = 
     lookMap (error $ "Missing concrete syntax: " ++ showCId cnc) cnc $ concretes pgf
 
-lookConcrFlag :: PGF -> CId -> CId -> Maybe String
+lookConcrFlag :: PGF -> CId -> CId -> Maybe Literal
 lookConcrFlag pgf lang f = Map.lookup f $ cflags $ lookConcr pgf lang
 
 functionsToCat :: PGF -> CId -> [(CId,Type)]
@@ -142,8 +142,13 @@ _B = mkCId "__gfB"
 _V = mkCId "__gfV"
 
 updateProductionIndices :: PGF -> PGF
-updateProductionIndices pgf = pgf{concretes = fmap updateConcrete (concretes pgf)}
+updateProductionIndices pgf = pgf{ abstract  = updateAbstract (abstract pgf)
+                                 , concretes = fmap updateConcrete (concretes pgf)
+                                 }
   where
+    updateAbstract abs =
+      abs{catfuns = Map.mapWithKey (\cat _ -> [f | (f, (DTyp _ c _,_,_)) <- Map.toList (funs abs), c==cat]) (cats abs)}
+
     updateConcrete cnc = 
       let prods0    = filterProductions (productions cnc)
           p_prods   = parseIndex cnc prods0
@@ -162,8 +167,8 @@ updateProductionIndices pgf = pgf{concretes = fmap updateConcrete (concretes pgf
           where
             set = Set.filter (filterRule prods) set0
 
-        filterRule prods (FApply funid args) = all (\fcat -> isLiteralFCat fcat || IntMap.member fcat prods) args
-        filterRule prods (FCoerce fcat)      = isLiteralFCat fcat || IntMap.member fcat prods
+        filterRule prods (PApply funid args) = all (\fcat -> isLiteralFCat fcat || IntMap.member fcat prods) args
+        filterRule prods (PCoerce fcat)      = isLiteralFCat fcat || IntMap.member fcat prods
         filterRule prods _                   = True
 
     parseIndex pinfo = IntMap.mapMaybeWithKey filterProdSet
@@ -175,12 +180,12 @@ updateProductionIndices pgf = pgf{concretes = fmap updateConcrete (concretes pgf
                                                then Nothing
                                                else Just prods'
 
-        is_ho_prod (FApply _ [fid]) | fid == fcatVar = True
+        is_ho_prod (PApply _ [fid]) | fid == fcatVar = True
         is_ho_prod _                                 = False
 
         ho_fids :: IntSet.IntSet
         ho_fids = IntSet.fromList [fid | cat <- ho_cats
-                                       , fid <- maybe [] (\(s,e,_) -> [s..e]) (Map.lookup cat (startCats pinfo))]
+                                       , fid <- maybe [] (\(CncCat s e _) -> [s..e]) (Map.lookup cat (cnccats pinfo))]
 
         ho_cats :: [CId]
         ho_cats = sortNub [c | (ty,_,_) <- Map.elems (funs (abstract pgf))
@@ -194,7 +199,7 @@ updateProductionIndices pgf = pgf{concretes = fmap updateConcrete (concretes pgf
                                                                         , prod <- Set.toList prods
                                                                         , fun <- getFunctions prod]
       where
-        getFunctions (FApply funid args) = let FFun fun _ = functions pinfo Array.! funid in [fun]
-        getFunctions (FCoerce fid)       = case IntMap.lookup fid productions of
+        getFunctions (PApply funid args) = let CncFun fun _ = cncfuns pinfo Array.! funid in [fun]
+        getFunctions (PCoerce fid)       = case IntMap.lookup fid productions of
                                              Nothing    -> []
                                              Just prods -> [fun | prod <- Set.toList prods, fun <- getFunctions prod]
\ No newline at end of file
diff --git a/src/runtime/haskell/PGF/Morphology.hs b/src/runtime/haskell/PGF/Morphology.hs
index c77aa1735..f5c65b3ba 100644
--- a/src/runtime/haskell/PGF/Morphology.hs
+++ b/src/runtime/haskell/PGF/Morphology.hs
@@ -25,17 +25,17 @@ buildMorpho pgf lang = Morpho $
     Nothing    -> Map.empty
 
 collectWords pinfo = Map.fromListWith (++)
-  [(t, [(fun,lbls ! l)]) | (s,e,lbls) <- Map.elems (startCats pinfo)
+  [(t, [(fun,lbls ! l)]) | (CncCat s e lbls) <- Map.elems (cnccats pinfo)
                          , fid <- [s..e]
-                         , FApply funid _ <- maybe [] Set.toList (IntMap.lookup fid (pproductions pinfo))
-                         , let FFun fun lins = functions pinfo ! funid
+                         , PApply funid _ <- maybe [] Set.toList (IntMap.lookup fid (pproductions pinfo))
+                         , let CncFun fun lins = cncfuns pinfo ! funid
                          , (l,seqid) <- assocs lins
                          , sym <- elems (sequences pinfo ! seqid)
                          , t <- sym2tokns sym]
   where
-    sym2tokns (FSymKS ts)      = ts
-    sym2tokns (FSymKP ts alts) = ts ++ [t | Alt ts ps <- alts, t <- ts]
-    sym2tokns _                = []
+    sym2tokns (SymKS ts)      = ts
+    sym2tokns (SymKP ts alts) = ts ++ [t | Alt ts ps <- alts, t <- ts]
+    sym2tokns _               = []
 
 lookupMorpho :: Morpho -> String -> [(Lemma,Analysis)]
 lookupMorpho (Morpho mo) s = maybe [] id $ Map.lookup s mo
diff --git a/src/runtime/haskell/PGF/Parse.hs b/src/runtime/haskell/PGF/Parse.hs
index e02ccd9ca..61035bd92 100644
--- a/src/runtime/haskell/PGF/Parse.hs
+++ b/src/runtime/haskell/PGF/Parse.hs
@@ -56,14 +56,14 @@ parseWithRecovery pgf lang typ open_typs toks = accept (initState pgf lang typ)
 -- startup category.

 initState :: PGF -> Language -> Type -> ParseState

 initState pgf lang (DTyp _ start _) = 

-  let items = case Map.lookup start (startCats cnc) of

-                Just (s,e,labels) -> do cat <- range (s,e)

-                                        (funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args)

-                                                                   [] cat (pproductions cnc)

-                                        let FFun fn lins = functions cnc ! funid

-                                        (lbl,seqid) <- assocs lins

-                                        return (Active 0 0 funid seqid args (AK cat lbl))

-                Nothing           -> mzero

+  let items = case Map.lookup start (cnccats cnc) of

+                Just (CncCat s e labels) -> do cat <- range (s,e)

+                                               (funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args)

+                                                                          [] cat (pproductions cnc)

+                                               let CncFun fn lins = cncfuns cnc ! funid

+                                               (lbl,seqid) <- assocs lins

+                                               return (Active 0 0 funid seqid args (AK cat lbl))

+                Nothing                  -> mzero

 

       cnc = lookConcr pgf lang

 

@@ -82,7 +82,7 @@ nextState (PState pgf cnc chart items) t =
   let (mb_agenda,map_items) = TMap.decompose items

       agenda = maybe [] Set.toList mb_agenda

       acc    = fromMaybe TMap.empty (Map.lookup t map_items)

-      (acc1,chart1) = process (Just t) add (sequences cnc) (functions cnc) agenda acc chart

+      (acc1,chart1) = process (Just t) add (sequences cnc) (cncfuns cnc) agenda acc chart

       chart2 = chart1{ active =emptyAC

                      , actives=active chart1 : actives chart1

                      , passive=emptyPC

@@ -105,7 +105,7 @@ getCompletions (PState pgf cnc chart items) w =
   let (mb_agenda,map_items) = TMap.decompose items

       agenda = maybe [] Set.toList mb_agenda

       acc    = Map.filterWithKey (\tok _ -> isPrefixOf w tok) map_items

-      (acc',chart1) = process Nothing add (sequences cnc) (functions cnc) agenda acc chart

+      (acc',chart1) = process Nothing add (sequences cnc) (cncfuns cnc) agenda acc chart

       chart2 = chart1{ active =emptyAC

                      , actives=active chart1 : actives chart1

                      , passive=emptyPC

@@ -121,7 +121,7 @@ recoveryStates :: [Type] -> ErrorState -> (ParseState, Map.Map String ParseState
 recoveryStates open_types (EState pgf cnc chart) =

   let open_fcats = concatMap type2fcats open_types

       agenda = foldl (complete open_fcats) [] (actives chart)

-      (acc,chart1) = process Nothing add (sequences cnc) (functions cnc) agenda Map.empty chart

+      (acc,chart1) = process Nothing add (sequences cnc) (cncfuns cnc) agenda Map.empty chart

       chart2 = chart1{ active =emptyAC

                      , actives=active chart1 : actives chart1

                      , passive=emptyPC

@@ -129,9 +129,9 @@ recoveryStates open_types (EState pgf cnc chart) =
                      }

   in (PState pgf cnc chart (TMap.singleton [] (Set.fromList agenda)), fmap (PState pgf cnc chart2) acc)

   where

-    type2fcats (DTyp _ cat _) = case Map.lookup cat (startCats cnc) of

-                                  Just (s,e,labels) -> range (s,e)

-                                  Nothing           -> []

+    type2fcats (DTyp _ cat _) = case Map.lookup cat (cnccats cnc) of

+                                  Just (CncCat s e labels) -> range (s,e)

+                                  Nothing                  -> []

 

     complete open_fcats items ac = 

       foldl (Set.fold (\(Active j' ppos funid seqid args keyc) -> 

@@ -151,23 +151,23 @@ extractTrees (PState pgf cnc chart items) ty@(DTyp _ start _) =
   where

     (mb_agenda,acc) = TMap.decompose items

     agenda = maybe [] Set.toList mb_agenda

-    (_,st) = process Nothing (\_ _ -> id) (sequences cnc) (functions cnc) agenda () chart

+    (_,st) = process Nothing (\_ _ -> id) (sequences cnc) (cncfuns cnc) agenda () chart

 

     exps = 

-      case Map.lookup start (startCats cnc) of

-        Just (s,e,lbls) -> do cat <- range (s,e)

-                              lbl <- indices lbls

-                              Just fid <- [lookupPC (PK cat lbl 0) (passive st)]

-                              (fvs,tree) <- go Set.empty 0 (0,fid)

-                              guard (Set.null fvs)

-                              return tree

-        Nothing         -> mzero

+      case Map.lookup start (cnccats cnc) of

+        Just (CncCat s e lbls) -> do cat <- range (s,e)

+                                     lbl <- indices lbls

+                                     Just fid <- [lookupPC (PK cat lbl 0) (passive st)]

+                                     (fvs,tree) <- go Set.empty 0 (0,fid)

+                                     guard (Set.null fvs)

+                                     return tree

+        Nothing                -> mzero

 

     go rec fcat' (d,fcat)

       | fcat < totalCats cnc = return (Set.empty,EMeta (fcat'*10+d))   -- FIXME: here we assume that every rule has at most 10 arguments

       | Set.member fcat rec    = mzero

       | otherwise              = foldForest (\funid args trees -> 

-                                                  do let FFun fn lins = functions cnc ! funid

+                                                  do let CncFun fn lins = cncfuns cnc ! funid

                                                      args <- mapM (go (Set.insert fcat rec) fcat) (zip [0..] args)

                                                      check_ho_fun fn args

                                                   `mplus`

@@ -193,36 +193,36 @@ process mbt fn !seqs !funs []                                                 ac
 process mbt fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) acc chart

   | inRange (bounds lin) ppos =

       case unsafeAt lin ppos of

-        FSymCat d r -> let !fid = args !! d

-                           key  = AK fid r

+        SymCat d r -> let !fid = args !! d

+                          key  = AK fid r

                                 

-                           items2 = case lookupPC (mkPK key k) (passive chart) of

-                                      Nothing -> items

-                                      Just id -> (Active j (ppos+1) funid seqid (updateAt d id args) key0) : items

-                           items3 = foldForest (\funid args items -> Active k 0 funid (rhs funid r) args key : items)

-                                               (\_ _ items -> items)

-                                               items2 fid (forest chart)

-                       in case lookupAC key (active chart) of

-                            Nothing                        -> process mbt fn seqs funs items3 acc chart{active=insertAC key (Set.singleton item) (active chart)}

-                            Just set | Set.member item set -> process mbt fn seqs funs items  acc chart

-                                     | otherwise           -> process mbt fn seqs funs items2 acc chart{active=insertAC key (Set.insert item set) (active chart)}

-      	FSymKS toks -> let !acc' = fn toks (Active j (ppos+1) funid seqid args key0) acc

-                       in process mbt fn seqs funs items acc' chart

-      	FSymKP strs vars

-      	            -> let !acc' = foldl (\acc toks -> fn toks (Active j (ppos+1) funid seqid args key0) acc) acc

-      	                             (strs:[strs' | Alt strs' _ <- vars])

-                       in process mbt fn seqs funs items acc' chart

-        FSymLit d r -> let !fid = args !! d

-                       in case [ts | FConst _ ts <- maybe [] Set.toList (IntMap.lookup fid (forest chart))] of

-                            (toks:_) -> let !acc' = fn toks (Active j (ppos+1) funid seqid args key0) acc

-                                        in process mbt fn seqs funs items acc' chart

-                            []       -> case litCatMatch fid mbt of

-                                          Just (toks,lit) -> let fid'  = nextId chart

-                                                                 !acc' = fn toks (Active j (ppos+1) funid seqid (updateAt d fid' args) key0) acc

-                                                             in process mbt fn seqs funs items acc' chart{forest=IntMap.insert fid' (Set.singleton (FConst lit toks)) (forest chart)

-                                                                                                         ,nextId=nextId chart+1

-                                                                                                         }

-                                          Nothing         -> process mbt fn seqs funs items acc chart

+                          items2 = case lookupPC (mkPK key k) (passive chart) of

+                                     Nothing -> items

+                                     Just id -> (Active j (ppos+1) funid seqid (updateAt d id args) key0) : items

+                          items3 = foldForest (\funid args items -> Active k 0 funid (rhs funid r) args key : items)

+                                              (\_ _ items -> items)

+                                              items2 fid (forest chart)

+                      in case lookupAC key (active chart) of

+                           Nothing                        -> process mbt fn seqs funs items3 acc chart{active=insertAC key (Set.singleton item) (active chart)}

+                           Just set | Set.member item set -> process mbt fn seqs funs items  acc chart

+                                    | otherwise           -> process mbt fn seqs funs items2 acc chart{active=insertAC key (Set.insert item set) (active chart)}

+      	SymKS toks -> let !acc' = fn toks (Active j (ppos+1) funid seqid args key0) acc

+                      in process mbt fn seqs funs items acc' chart

+      	SymKP strs vars

+      	           -> let !acc' = foldl (\acc toks -> fn toks (Active j (ppos+1) funid seqid args key0) acc) acc

+                                   (strs:[strs' | Alt strs' _ <- vars])

+                      in process mbt fn seqs funs items acc' chart

+        SymLit d r -> let !fid = args !! d

+                      in case [ts | PConst _ ts <- maybe [] Set.toList (IntMap.lookup fid (forest chart))] of

+                           (toks:_) -> let !acc' = fn toks (Active j (ppos+1) funid seqid args key0) acc

+                                       in process mbt fn seqs funs items acc' chart

+                           []       -> case litCatMatch fid mbt of

+                                         Just (toks,lit) -> let fid'  = nextId chart

+                                                                !acc' = fn toks (Active j (ppos+1) funid seqid (updateAt d fid' args) key0) acc

+                                                            in process mbt fn seqs funs items acc' chart{forest=IntMap.insert fid' (Set.singleton (PConst lit toks)) (forest chart)

+                                                                                                        ,nextId=nextId chart+1

+                                                                                                        }

+                                         Nothing         -> process mbt fn seqs funs items acc chart

   | otherwise =

       case lookupPC (mkPK key0 j) (passive chart) of

         Nothing -> let fid = nextId chart

@@ -230,14 +230,14 @@ process mbt fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) ac
                        items2 = case lookupAC key0 ((active chart:actives chart) !! (k-j)) of

                                   Nothing  -> items

                                   Just set -> Set.fold (\(Active j' ppos funid seqid args keyc) -> 

-                                                            let FSymCat d _ = unsafeAt (unsafeAt seqs seqid) ppos

+                                                            let SymCat d _ = unsafeAt (unsafeAt seqs seqid) ppos

                                                             in (:) (Active j' (ppos+1) funid seqid (updateAt d fid args) keyc)) items set

                    in process mbt fn seqs funs items2 acc chart{passive=insertPC (mkPK key0 j) fid (passive chart)

-                                                               ,forest =IntMap.insert fid (Set.singleton (FApply funid args)) (forest chart)

+                                                               ,forest =IntMap.insert fid (Set.singleton (PApply funid args)) (forest chart)

                                                                ,nextId =nextId chart+1

                                                                }

         Just id -> let items2 = [Active k 0 funid (rhs funid r) args (AK id r) | r <- labelsAC id (active chart)] ++ items

-                   in process mbt fn seqs funs items2 acc chart{forest = IntMap.insertWith Set.union id (Set.singleton (FApply funid args)) (forest chart)}

+                   in process mbt fn seqs funs items2 acc chart{forest = IntMap.insertWith Set.union id (Set.singleton (PApply funid args)) (forest chart)}

   where

     !lin = unsafeAt seqs seqid

     !k   = offset chart

@@ -246,7 +246,7 @@ process mbt fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) ac
     

     rhs funid lbl = unsafeAt lins lbl

       where

-        FFun _ lins = unsafeAt funs funid

+        CncFun _ lins = unsafeAt funs funid

 

 

 updateAt :: Int -> a -> [a] -> [a]

@@ -268,15 +268,15 @@ litCatMatch _    _     = Nothing
 

 data Active

   = Active {-# UNPACK #-} !Int

-           {-# UNPACK #-} !FPointPos

+           {-# UNPACK #-} !DotPos

            {-# UNPACK #-} !FunId

            {-# UNPACK #-} !SeqId

-                           [FCat]

+                           [FId]

            {-# UNPACK #-} !ActiveKey

   deriving (Eq,Show,Ord)

 data ActiveKey

-  = AK {-# UNPACK #-} !FCat

-       {-# UNPACK #-} !FIndex

+  = AK {-# UNPACK #-} !FId

+       {-# UNPACK #-} !LIndex

   deriving (Eq,Ord,Show)

 type ActiveChart  = IntMap.IntMap (IntMap.IntMap (Set.Set Active))

 

@@ -286,13 +286,13 @@ emptyAC = IntMap.empty
 lookupAC :: ActiveKey -> ActiveChart -> Maybe (Set.Set Active)

 lookupAC (AK fcat l) chart = IntMap.lookup fcat chart >>= IntMap.lookup l

 

-lookupACByFCat :: FCat -> ActiveChart -> [Set.Set Active]

+lookupACByFCat :: FId -> ActiveChart -> [Set.Set Active]

 lookupACByFCat fcat chart =

   case IntMap.lookup fcat chart of

     Nothing  -> []

     Just map -> IntMap.elems map

 

-labelsAC :: FCat -> ActiveChart -> [FIndex]

+labelsAC :: FId -> ActiveChart -> [LIndex]

 labelsAC fcat chart = 

   case IntMap.lookup fcat chart of

     Nothing  -> []

@@ -307,20 +307,20 @@ insertAC (AK fcat l) set chart = IntMap.insertWith IntMap.union fcat (IntMap.sin
 ----------------------------------------------------------------

 

 data PassiveKey

-  = PK {-# UNPACK #-} !FCat

-       {-# UNPACK #-} !FIndex

+  = PK {-# UNPACK #-} !FId

+       {-# UNPACK #-} !LIndex

        {-# UNPACK #-} !Int

   deriving (Eq,Ord,Show)

 

-type PassiveChart = Map.Map PassiveKey FCat 

+type PassiveChart = Map.Map PassiveKey FId 

 

 emptyPC :: PassiveChart

 emptyPC = Map.empty

 

-lookupPC :: PassiveKey -> PassiveChart -> Maybe FCat

+lookupPC :: PassiveKey -> PassiveChart -> Maybe FId

 lookupPC key chart = Map.lookup key chart

 

-insertPC :: PassiveKey -> FCat -> PassiveChart -> PassiveChart

+insertPC :: PassiveKey -> FId -> PassiveChart -> PassiveChart

 insertPC key fcat chart = Map.insert key fcat chart

 

 

@@ -328,15 +328,15 @@ insertPC key fcat chart = Map.insert key fcat chart
 -- Forest

 ----------------------------------------------------------------

 

-foldForest :: (FunId -> [FCat] -> b -> b) -> (Expr -> [String] -> b -> b) -> b -> FCat -> IntMap.IntMap (Set.Set Production) -> b

+foldForest :: (FunId -> [FId] -> b -> b) -> (Expr -> [String] -> b -> b) -> b -> FId -> IntMap.IntMap (Set.Set Production) -> b

 foldForest f g b fcat forest =

   case IntMap.lookup fcat forest of

     Nothing  -> b

     Just set -> Set.fold foldProd b set

   where

-    foldProd (FCoerce fcat)      b = foldForest f g b fcat forest

-    foldProd (FApply funid args) b = f funid args b

-    foldProd (FConst const toks) b = g const toks b

+    foldProd (PCoerce fcat)      b = foldForest f g b fcat forest

+    foldProd (PApply funid args) b = f funid args b

+    foldProd (PConst const toks) b = g const toks b

 

 

 ----------------------------------------------------------------

@@ -353,7 +353,7 @@ data Chart
       , actives :: [ActiveChart]

       , passive :: PassiveChart

       , forest  :: IntMap.IntMap (Set.Set Production)

-      , nextId  :: {-# UNPACK #-} !FCat

+      , nextId  :: {-# UNPACK #-} !FId

       , offset  :: {-# UNPACK #-} !Int

       }

       deriving Show

diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs
index 2f92dd8e0..ee0fd4070 100644
--- a/src/runtime/haskell/PGF/Printer.hs
+++ b/src/runtime/haskell/PGF/Printer.hs
@@ -40,34 +40,34 @@ ppCnc name cnc =
   nest 2 (text "productions" $$
           nest 2 (vcat [ppProduction (fcat,prod) | (fcat,set) <- IntMap.toList (productions cnc), prod <- Set.toList set]) $$
           text "functions" $$
-          nest 2 (vcat (map ppFFun (assocs (functions cnc)))) $$
+          nest 2 (vcat (map ppCncFun (assocs (cncfuns cnc)))) $$
           text "sequences" $$
           nest 2 (vcat (map ppSeq (assocs (sequences cnc)))) $$
-          text "startcats" $$
-          nest 2 (vcat (map ppStartCat (Map.toList (startCats cnc))))) $$
+          text "categories" $$
+          nest 2 (vcat (map ppCncCat (Map.toList (cnccats cnc))))) $$
   char '}'
 
-ppProduction (fcat,FApply funid args) =
+ppProduction (fcat,PApply funid args) =
   ppFCat fcat <+> text "->" <+> ppFunId funid <> brackets (hcat (punctuate comma (map ppFCat args)))
-ppProduction (fcat,FCoerce arg) =
+ppProduction (fcat,PCoerce arg) =
   ppFCat fcat <+> text "->" <+> char '_' <> brackets (ppFCat arg)
-ppProduction (fcat,FConst _ ss) =
+ppProduction (fcat,PConst _ ss) =
   ppFCat fcat <+> text "->" <+> ppStrs ss
 
-ppFFun (funid,FFun fun arr) =
+ppCncFun (funid,CncFun fun arr) =
   ppFunId funid <+> text ":=" <+> parens (hcat (punctuate comma (map ppSeqId (elems arr)))) <+> brackets (ppCId fun)
 
 ppSeq (seqid,seq) = 
   ppSeqId seqid <+> text ":=" <+> hsep (map ppSymbol (elems seq))
 
-ppStartCat (id,(start,end,labels)) =
+ppCncCat (id,(CncCat start end labels)) =
   ppCId id <+> text ":=" <+> (text "range " <+> brackets (ppFCat start <+> text ".." <+> ppFCat end) $$
                               text "labels" <+> brackets (vcat (map (text . show) (elems labels))))
 
-ppSymbol (FSymCat d r) = char '<' <> int d <> comma <> int r <> char '>'
-ppSymbol (FSymLit d r) = char '<' <> int d <> comma <> int r <> char '>'
-ppSymbol (FSymKS ts)   = ppStrs ts
-ppSymbol (FSymKP ts alts) = text "pre" <+> braces (hsep (punctuate semi (ppStrs ts : map ppAlt alts)))
+ppSymbol (SymCat d r) = char '<' <> int d <> comma <> int r <> char '>'
+ppSymbol (SymLit d r) = char '<' <> int d <> comma <> int r <> char '>'
+ppSymbol (SymKS ts)   = ppStrs ts
+ppSymbol (SymKP ts alts) = text "pre" <+> braces (hsep (punctuate semi (ppStrs ts : map ppAlt alts)))
 
 ppAlt (Alt ts ps) = ppStrs ts <+> char '/' <+> hsep (map (doubleQuotes . text) ps)
 
diff --git a/src/runtime/haskell/PGF/VisualizeTree.hs b/src/runtime/haskell/PGF/VisualizeTree.hs
index 8e9b28740..d42484e0b 100644
--- a/src/runtime/haskell/PGF/VisualizeTree.hs
+++ b/src/runtime/haskell/PGF/VisualizeTree.hs
@@ -238,7 +238,7 @@ mtag = tag . ('n':) . uncommas
 
 graphvizAlignment :: PGF -> Expr -> String
 graphvizAlignment pgf = prGraph True . lin2graph . linsMark  where
-  linsMark t = [concat (take 1 (markLinearizes pgf la t)) | la <- cncnames pgf]
+  linsMark t = [concat (take 1 (markLinearizes pgf la t)) | la <- Map.keys (concretes pgf)]
 
 lin2graph :: [String] -> [String]
 lin2graph ss = trace (show ss) $ prelude ++ nodes ++ links