GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-22 11:19:32 -06:00
Code Issues Packages Projects Releases Wiki Activity

Yay!! Direct generation of PMCFG from GF grammar

Browse Source
This commit is contained in:
krasimir
2010-06-18 12:55:58 +00:00
parent 5dfc9bbc0b
commit 992a7ffb38
17 changed files with 500 additions and 996 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
src/compiler/GF/Command/Importing.hs
View File

@@ -4,13 +4,14 @@ import PGF
import PGF.Data import PGF.Data
import GF.Compile import GF.Compile
import GF.Grammar.Grammar (SourceGrammar) -- for cc command import GF.Grammar (identC, SourceGrammar) -- for cc command
import GF.Grammar.CF import GF.Grammar.CF
import GF.Infra.UseIO import GF.Infra.UseIO
import GF.Infra.Option import GF.Infra.Option
import GF.Data.ErrM import GF.Data.ErrM
import Data.List (nubBy) import Data.List (nubBy)
import qualified Data.ByteString.Char8 as BS
import System.FilePath import System.FilePath
-- import a grammar in an environment where it extends an existing grammar -- import a grammar in an environment where it extends an existing grammar
@@ -25,7 +26,7 @@ importGrammar pgf0 opts files =
Ok g -> return g Ok g -> return g
Bad s -> error s ---- Bad s -> error s ----
Ok gr <- appIOE $ compileSourceGrammar opts gf Ok gr <- appIOE $ compileSourceGrammar opts gf
epgf <- appIOE $ link opts (cnc ++ "Abs") gr epgf <- appIOE $ link opts (identC (BS.pack (cnc ++ "Abs"))) gr
case epgf of case epgf of
Ok pgf -> return pgf Ok pgf -> return pgf
Bad s -> error s ---- Bad s -> error s ----

17
src/compiler/GF/Compile.hs
View File

@@ -35,9 +35,9 @@ import qualified Data.Set as Set
import Data.List(nub) import Data.List(nub)
import Data.Maybe (isNothing) import Data.Maybe (isNothing)
import Data.Binary import Data.Binary
import qualified Data.ByteString.Char8 as BS
import Text.PrettyPrint import Text.PrettyPrint
import PGF.Check
import PGF.CId import PGF.CId
import PGF.Data import PGF.Data
import PGF.Macros import PGF.Macros
@@ -49,20 +49,15 @@ compileToPGF :: Options -> [FilePath] -> IOE PGF
compileToPGF opts fs = compileToPGF opts fs =
do gr <- batchCompile opts fs do gr <- batchCompile opts fs
let name = justModuleName (last fs) let name = justModuleName (last fs)
link opts name gr link opts (identC (BS.pack name)) gr
link :: Options -> String -> SourceGrammar -> IOE PGF link :: Options -> Ident -> SourceGrammar -> IOE PGF
link opts cnc gr = do link opts cnc gr = do
let isv = (verbAtLeast opts Normal) let isv = (verbAtLeast opts Normal)
putPointE Normal opts "linking ... " $ do putPointE Normal opts "linking ... " $ do
gc0 <- ioeIO (mkCanon2pgf opts cnc gr) gc <- ioeIO (mkCanon2pgf opts cnc gr)
case checkPGF gc0 of ioeIO $ putStrLn "OK"
Ok (gc,b) -> do case (isv,b) of return $ if flag optOptimizePGF opts then optimizePGF gc else gc
(True, True) -> ioeIO $ putStrLn "OK"
(False,True) -> return ()
_ -> ioeIO $ putStrLn $ "Corrupted PGF"
return $ if flag optOptimizePGF opts then optimizePGF gc else gc
Bad s -> fail s
batchCompile :: Options -> [FilePath] -> IOE SourceGrammar batchCompile :: Options -> [FilePath] -> IOE SourceGrammar
batchCompile opts files = do batchCompile opts files = do

2
src/compiler/GF/Compile/Abstract/TC.hs
View File

@@ -34,7 +34,7 @@ data AExp =
AVr Ident Val AVr Ident Val
| ACn QIdent Val | ACn QIdent Val
| AType | AType
| AInt Integer | AInt Int
| AFloat Double | AFloat Double
| AStr String | AStr String
| AMeta MetaId Val | AMeta MetaId Val

11
src/compiler/GF/Compile/Concrete/AppPredefined.hs
View File

@@ -73,17 +73,17 @@ appPredefined t = case t of
-- one-place functions -- one-place functions
Q (mod,f) | mod == cPredef -> Q (mod,f) | mod == cPredef ->
case x of case x of
(K s) | f == cLength -> retb $ EInt $ toInteger $ length s (K s) | f == cLength -> retb $ EInt $ length s
_ -> retb t _ -> retb t
-- two-place functions -- two-place functions
App (Q (mod,f)) z0 | mod == cPredef -> do App (Q (mod,f)) z0 | mod == cPredef -> do
(z,_) <- appPredefined z0 (z,_) <- appPredefined z0
case (norm z, norm x) of case (norm z, norm x) of
(EInt i, K s) | f == cDrop -> retb $ K (drop (fi i) s) (EInt i, K s) | f == cDrop -> retb $ K (drop i s)
(EInt i, K s) | f == cTake -> retb $ K (take (fi i) s) (EInt i, K s) | f == cTake -> retb $ K (take i s)
(EInt i, K s) | f == cTk -> retb $ K (take (max 0 (length s - fi i)) s) (EInt i, K s) | f == cTk -> retb $ K (take (max 0 (length s - i)) s)
(EInt i, K s) | f == cDp -> retb $ K (drop (max 0 (length s - fi i)) s) (EInt i, K s) | f == cDp -> retb $ K (drop (max 0 (length s - i)) s)
(K s, K t) | f == cEqStr -> retb $ if s == t then predefTrue else predefFalse (K s, K t) | f == cEqStr -> retb $ if s == t then predefTrue else predefFalse
(K s, K t) | f == cOccur -> retb $ if substring s t then predefTrue else predefFalse (K s, K t) | f == cOccur -> retb $ if substring s t then predefTrue else predefFalse
(K s, K t) | f == cOccurs -> retb $ if any (flip elem t) s then predefTrue else predefFalse (K s, K t) | f == cOccurs -> retb $ if any (flip elem t) s then predefTrue else predefFalse
@@ -119,7 +119,6 @@ appPredefined t = case t of
(K x,K y) -> K (x +++ y) (K x,K y) -> K (x +++ y)
_ -> t _ -> t
_ -> t _ -> t
fi = fromInteger
-- read makes variables into constants -- read makes variables into constants

640
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

@@ -1,4 +1,4 @@
{-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses #-} {-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- | -- |
-- Maintainer : Krasimir Angelov -- Maintainer : Krasimir Angelov
@@ -13,11 +13,15 @@ module GF.Compile.GeneratePMCFG
(convertConcrete) where (convertConcrete) where
import PGF.CId import PGF.CId
import PGF.Data import PGF.Data hiding (Type)
import PGF.Macros
import GF.Infra.Option import GF.Infra.Option
import GF.Grammar hiding (Env, mkRecord, mkTable)
import qualified GF.Infra.Modules as M
import GF.Grammar.Lookup
import GF.Grammar.Predef
import GF.Data.BacktrackM import GF.Data.BacktrackM
import GF.Data.Operations
import GF.Data.Utilities (updateNthM, updateNth, sortNub) import GF.Data.Utilities (updateNthM, updateNth, sortNub)
import System.IO import System.IO
@@ -26,36 +30,52 @@ import qualified Data.Set as Set
import qualified Data.List as List import qualified Data.List as List
import qualified Data.IntMap as IntMap import qualified Data.IntMap as IntMap
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import Text.PrettyPrint hiding (Str)
import Data.Array.IArray import Data.Array.IArray
import Data.Maybe import Data.Maybe
import Data.Char (isDigit)
import Control.Monad import Control.Monad
import Control.Monad.Identity
import Control.Exception import Control.Exception
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- main conversion function -- main conversion function
--convertConcrete :: Options -> Abstr -> CId -> Concr -> IO Concr convertConcrete :: Options -> SourceGrammar -> SourceModule -> SourceModule -> IO Concr
convertConcrete opts lang flags printnames abs_defs cnc_defs lincats params lin_defs = do convertConcrete opts gr am cm = do
let env0 = emptyGrammarEnv cat_defs params let env0 = emptyGrammarEnv gr cm
when (flag optProf opts) $ do when (flag optProf opts) $ do
profileGrammar lang env0 pfrules profileGrammar cm env0 pfrules
env1 <- expandHOAS opts abs_defs cat_defs lin_defs env0 env1 <- expandHOAS opts cm env0
env2 <- foldM (convertRule opts) env1 pfrules env2 <- foldM (convertRule gr opts) env1 pfrules
return $ getParserInfo flags printnames env2 return $ getConcr flags printnames env2
where where
cat_defs = Map.insert cidVar (S []) lincats (m,mo) = cm
pfrules = [ pfrules = [
(PFRule id args (0,res) (map findLinType args) (findLinType (0,res)) term) | (PFRule id args (0,res) (map (\(_,_,ty) -> ty) cont) val term) |
(id, (ty,_,_)) <- Map.toList abs_defs, let (args,res) = typeSkeleton ty, (id,GF.Grammar.CncFun (Just (cat,cont,val)) (Just (L _ term)) _) <- Map.toList (M.jments mo),
term <- maybeToList (Map.lookup id cnc_defs)] let (args,res) = err error typeSkeleton (lookupFunType gr (fst am) id)]
findLinType (_,id) = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs)
profileGrammar lang (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) pfrules = do flags = Map.fromList [(mkCId f,LStr x) | (f,x) <- optionsPGF (M.flags mo)]
printnames = Map.fromAscList [(i2i id, name) | (id,info) <- Map.toList (M.jments mo), name <- prn info]
where
prn (GF.Grammar.CncFun _ _ (Just (L _ tr))) = [flatten tr]
prn (GF.Grammar.CncCat _ _ (Just (L _ tr))) = [flatten tr]
prn _ = []
flatten (K s) = s
flatten (Alts x _) = flatten x
flatten (C x y) = flatten x +++ flatten y
i2i :: Ident -> CId
i2i = CId . ident2bs
profileGrammar (m,mo) env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) pfrules = do
hPutStrLn stderr "" hPutStrLn stderr ""
hPutStrLn stderr ("Language: " ++ show lang) hPutStrLn stderr ("Language: " ++ showIdent m)
hPutStrLn stderr "" hPutStrLn stderr ""
hPutStrLn stderr "Categories Count" hPutStrLn stderr "Categories Count"
hPutStrLn stderr "--------------------------------" hPutStrLn stderr "--------------------------------"
@@ -69,22 +89,52 @@ profileGrammar lang (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) pfr
mapM_ profileRule pfrules mapM_ profileRule pfrules
hPutStrLn stderr "--------------------------------" hPutStrLn stderr "--------------------------------"
where where
profileCat (cid,(fcat1,fcat2,_,_)) = do profileCat (cid,(fcat1,fcat2,_)) = do
hPutStrLn stderr (lformat 23 cid ++ rformat 9 (fcat2-fcat1+1)) hPutStrLn stderr (lformat 23 (showIdent cid) ++ rformat 9 (show (fcat2-fcat1+1)))
profileRule (PFRule fun args res ctypes ctype term) = do profileRule (PFRule fun args res ctypes ctype term) = do
let pargs = zipWith protoFCat args ctypes let pargs = map (protoFCat env) args
hPutStrLn stderr (lformat 23 fun ++ rformat 9 (product [length xs | PFCat _ _ _ tcs <- pargs, (_,xs) <- tcs])) hPutStrLn stderr (lformat 23 (showIdent fun) ++ rformat 9 (show (product (map (catFactor env) args))))
lformat :: Show a => Int -> a -> String
lformat n x = s ++ replicate (n-length s) ' '
where where
s = show x catFactor (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (n,(_,cat)) =
case IntMap.lookup n catSet >>= Map.lookup cat of
Just (s,e,_) -> e-s+1
Nothing -> 0
rformat :: Show a => Int -> a -> String lformat :: Int -> String -> String
rformat n x = replicate (n-length s) ' ' ++ s lformat n s = s ++ replicate (n-length s) ' '
where
s = show x rformat :: Int -> String -> String
rformat n s = replicate (n-length s) ' ' ++ s
data ProtoFRule = PFRule Ident {- function -}
[(Int,Cat)] {- argument types: context size and category -}
(Int,Cat) {- result type : context size (always 0) and category -}
[Type] {- argument lin-types representation -}
Type {- result lin-type representation -}
Term {- body -}
convertRule :: SourceGrammar -> Options -> GrammarEnv -> ProtoFRule -> IO GrammarEnv
convertRule gr opts grammarEnv (PFRule fun args res ctypes ctype term) = do
let pres = protoFCat grammarEnv res
pargs = map (protoFCat grammarEnv) args
b = runCnvMonad gr (unfactor term >>= convertTerm CNil ctype) (pargs,[])
(grammarEnv1,b1) = addSequencesB grammarEnv b
grammarEnv2 = brk (\grammarEnv -> foldBM addRule
grammarEnv
(goB b1 CNil [])
(pres,pargs) ) grammarEnv1
when (verbAtLeast opts Verbose) $ hPutStrLn stderr ("+ "++showIdent fun)
return $! grammarEnv2
where
addRule lins (newCat', newArgs') env0 =
let [newCat] = getFCatsX env0 newCat'
(env1, newArgs) = List.mapAccumL (\env -> addFCoercion env . getFCats env) env0 newArgs'
(env2,funid) = addCncFun env1 (PGF.Data.CncFun (i2i fun) (mkArray lins))
in addProduction env2 newCat (PApply funid newArgs)
brk :: (GrammarEnv -> GrammarEnv) -> (GrammarEnv -> GrammarEnv) brk :: (GrammarEnv -> GrammarEnv) -> (GrammarEnv -> GrammarEnv)
brk f (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) = brk f (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) =
@@ -103,141 +153,245 @@ brk f (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) =
count = length xs count = length xs
ys = foldr (zipWith Set.insert) (repeat Set.empty) xs ys = foldr (zipWith Set.insert) (repeat Set.empty) xs
convertRule :: Options -> GrammarEnv -> ProtoFRule -> IO GrammarEnv unfactor :: Term -> CnvMonad Term
convertRule opts grammarEnv (PFRule fun args res ctypes ctype term) = do unfactor t = CM (\gr c -> c (unfac gr t))
let pres = protoFCat res ctype
pargs = zipWith protoFCat args ctypes
b = runBranchM (convertTerm [] ctype term) (pargs,[])
(grammarEnv1,b1) = addSequences' grammarEnv b
grammarEnv2 = brk (\grammarEnv -> foldBM addRule
grammarEnv
(go' b1 [] [])
(pres,pargs) ) grammarEnv1
when (verbAtLeast opts Verbose) $ hPutStrLn stderr ("+ "++showCId fun)
return $! grammarEnv2
where where
addRule lins (newCat', newArgs') env0 = unfac gr t =
let [newCat] = getFCats env0 newCat' case t of
(env1, newArgs) = List.mapAccumL (\env -> addFCoercion env . getFCats env) env0 newArgs' T (TTyped ty) [(PV x,u)] -> V ty [restore x v (unfac gr u) | v <- err error id (allParamValues gr ty)]
_ -> composSafeOp (unfac gr) t
(env2,funid) = addCncFun env1 (CncFun fun (mkArray lins)) where
restore x u t = case t of
in addProduction env2 newCat (PApply funid newArgs) Vr y | y == x -> u
_ -> composSafeOp (restore x u) t
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- Branch monad -- CnvMonad monad
--
-- The branching monad provides backtracking together with
-- recording of the choices made. We have two cases
-- when we have alternative choices:
--
-- * when we have parameter type, then
-- we have to try all possible values
-- * when we have variants we have to try all alternatives
--
-- The conversion monad keeps track of the choices and they are
-- returned as 'Branch' data type.
newtype BranchM a = BM (forall b . (a -> ([ProtoFCat],[Symbol]) -> Branch b) -> ([ProtoFCat],[Symbol]) -> Branch b) data Branch a
= Case Int Path [(Term,Branch a)]
| Variant [Branch a]
| Return a
instance Monad BranchM where newtype CnvMonad a = CM {unCM :: SourceGrammar
return a = BM (\c s -> c a s) -> forall b . (a -> ([ProtoFCat],[Symbol]) -> Branch b)
BM m >>= k = BM (\c s -> m (\a s -> unBM (k a) c s) s) -> ([ProtoFCat],[Symbol])
where unBM (BM m) = m -> Branch b}
instance MonadState ([ProtoFCat],[Symbol]) BranchM where instance Monad CnvMonad where
get = BM (\c s -> c s s) return a = CM (\gr c s -> c a s)
put s = BM (\c _ -> c () s) CM m >>= k = CM (\gr c s -> m gr (\a s -> unCM (k a) gr c s) s)
instance Functor BranchM where instance MonadState ([ProtoFCat],[Symbol]) CnvMonad where
fmap f (BM m) = BM (\c s -> m (c . f) s) get = CM (\gr c s -> c s s)
put s = CM (\gr c _ -> c () s)
runBranchM :: BranchM (Value a) -> ([ProtoFCat],[Symbol]) -> Branch a instance Functor CnvMonad where
runBranchM (BM m) s = m (\v s -> Return v) s fmap f (CM m) = CM (\gr c s -> m gr (c . f) s)
variants :: [a] -> BranchM a runCnvMonad :: SourceGrammar -> CnvMonad a -> ([ProtoFCat],[Symbol]) -> Branch a
variants xs = BM (\c s -> Variant [c x s | x <- xs]) runCnvMonad gr (CM m) s = m gr (\v s -> Return v) s
choices :: Int -> FPath -> BranchM LIndex -- | backtracking for all variants
choices nr path = BM (\c s -> let (args,_) = s variants :: [a] -> CnvMonad a
PFCat _ _ _ tcs = args !! nr variants xs = CM (\gr c s -> Variant [c x s | x <- xs])
in case fromMaybe (error "evalTerm: wrong path") (lookup path tcs) of
[index] -> c index s
indices -> Case nr path [c i (updateEnv i s) | i <- indices])
where
updateEnv index (args,seq) = (updateNth (restrictArg path index) nr args,seq)
restrictArg path index (PFCat n cat rcs tcs) = PFCat n cat rcs (addConstraint path index tcs) -- | backtracking for all parameter values that a variable could take
choices :: Int -> Path -> CnvMonad Term
choices nr path = do (args,_) <- get
let PFCat _ _ schema = args !! nr
descend schema path CNil
where
descend (CRec rs) (CProj lbl path) rpath = case lookup lbl rs of
Just (Identity t) -> descend t path (CProj lbl rpath)
descend (CRec rs) CNil rpath = do rs <- mapM (\(lbl,Identity t) -> fmap (assign lbl) (descend t CNil (CProj lbl rpath))) rs
return (R rs)
descend (CTbl pt cs) (CSel trm path) rpath = case lookup trm cs of
Just (Identity t) -> descend t path (CSel trm rpath)
descend (CTbl pt cs) CNil rpath = do cs <- mapM (\(trm,Identity t) -> descend t CNil (CSel trm rpath)) cs
return (V pt cs)
descend (CPar (m,vs)) CNil rpath = case vs of
[(value,index)] -> return value
values -> let path = reversePath rpath
in CM (\gr c s -> Case nr path [(value, updateEnv path value gr c s)
| (value,index) <- values])
addConstraint path0 index0 [] = error "restrictProtoFCat: unknown path" updateEnv path value gr c (args,seq) =
addConstraint path0 index0 (c@(path,indices) : tcs) case updateNthM (restrictProtoFCat path value) nr args of
| path0 == path = ((path,[index0]) : tcs) Just args -> c value (args,seq)
| otherwise = c : addConstraint path0 index0 tcs Nothing -> error "conflict in updateEnv"
mkRecord :: [BranchM (Value a)] -> BranchM (Value a) -- | the argument should be a parameter type and then
mkRecord xs = BM (\c -> foldl (\c (BM m) bs s -> c (m (\v s -> Return v) s : bs) s) (c . Rec) xs []) -- the function returns all possible values.
getAllParamValues :: Type -> CnvMonad [Term]
getAllParamValues ty = CM (\gr c -> c (err error id (allParamValues gr ty)))
mkRecord :: [(Label,CnvMonad (Schema Branch s c))] -> CnvMonad (Schema Branch s c)
mkRecord xs = CM (\gr c -> foldl (\c (lbl,CM m) bs s -> c ((lbl,m gr (\v s -> Return v) s) : bs) s) (c . CRec) xs [])
mkTable :: Type -> [(Term ,CnvMonad (Schema Branch s c))] -> CnvMonad (Schema Branch s c)
mkTable pt xs = CM (\gr c -> foldl (\c (trm,CM m) bs s -> c ((trm,m gr (\v s -> Return v) s) : bs) s) (c . CTbl pt) xs [])
----------------------------------------------------------------------
-- Term Schema
--
-- The term schema is a term-like structure, with records, tables,
-- strings and parameters values, but in addition we could add
-- annotations of arbitrary types
-- | Term schema
data Schema b s c
= CRec [(Label,b (Schema b s c))]
| CTbl Type [(Term, b (Schema b s c))]
| CStr s
| CPar c
-- | Path into a term or term schema
data Path
= CProj Label Path
| CSel Term Path
| CNil
deriving (Eq,Show)
-- | The ProtoFCat represents a linearization type as term schema.
-- The annotations are as follows: the strings are annotated with
-- their index in the PMCFG tuple, the parameters are annotated
-- with their value both as term and as index.
data ProtoFCat = PFCat Int Ident (Schema Identity Int (Int,[(Term,Int)]))
type Env = (ProtoFCat, [ProtoFCat])
protoFCat :: GrammarEnv -> (Int,Cat) -> ProtoFCat
protoFCat (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (n,(_,cat)) =
case IntMap.lookup n catSet >>= Map.lookup cat of
Just (_,_,pfcat) -> pfcat
Nothing -> error "unknown category"
ppPath (CProj lbl path) = ppLabel lbl <+> ppPath path
ppPath (CSel trm path) = ppTerm Unqualified 5 trm <+> ppPath path
ppPath CNil = empty
reversePath path = rev CNil path
where
rev path0 CNil = path0
rev path0 (CProj lbl path) = rev (CProj lbl path0) path
rev path0 (CSel trm path) = rev (CSel trm path0) path
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- term conversion -- term conversion
type CnvMonad a = BranchM a type Value a = Schema Branch a Term
type FPath = [LIndex] convertTerm :: Path -> Type -> Term -> CnvMonad (Value [Symbol])
data ProtoFCat = PFCat Int CId [FPath] [(FPath,[LIndex])] convertTerm sel ctype (Vr x) = convertArg ctype (getVarIndex x) (reversePath sel)
type Env = (ProtoFCat, [ProtoFCat]) convertTerm sel ctype (Abs _ _ t) = convertTerm sel ctype t -- there are only top-level abstractions and we ignore them !!!
data ProtoFRule = PFRule CId {- function -} convertTerm sel ctype (R record) = convertRec sel ctype record
[(Int,CId)] {- argument types: context size and category -} convertTerm sel ctype (P term l) = convertTerm (CProj l sel) ctype term
(Int,CId) {- result type : context size (always 0) and category -} convertTerm sel ctype (V pt ts) = convertTbl sel ctype pt ts
[Term] {- argument lin-types representation -} convertTerm sel ctype (S term p) = do v <- evalTerm CNil p
Term {- result lin-type representation -} convertTerm (CSel v sel) ctype term
Term {- body -} convertTerm sel ctype (FV vars) = do term <- variants vars
type TermMap = Map.Map CId Term convertTerm sel ctype term
convertTerm sel ctype (C t1 t2) = do v1 <- convertTerm sel ctype t1
v2 <- convertTerm sel ctype t2
return (CStr (concat [s | CStr s <- [v1,v2]]))
convertTerm sel ctype (K t) = return (CStr [SymKS [t]])
convertTerm sel ctype Empty = return (CStr [])
convertTerm sel ctype (Alts s alts)
= return (CStr [SymKP (strings s) [Alt (strings u) (strings v) | (u,v) <- alts]])
where
strings (K s) = [s]
strings (C u v) = strings u ++ strings v
strings (Strs ss) = concatMap strings ss
convertTerm CNil ctype t = do v <- evalTerm CNil t
return (CPar v)
convertTerm _ _ t = error (render (text "convertTerm" <+> parens (ppTerm Unqualified 0 t)))
convertArg :: Term -> Int -> Path -> CnvMonad (Value [Symbol])
protoFCat :: (Int,CId) -> Term -> ProtoFCat convertArg (RecType rs) nr path =
protoFCat (n,cat) ctype = mkRecord (map (\(lbl,ctype) -> (lbl,convertArg ctype nr (CProj lbl path))) rs)
let (rcs,tcs) = loop [] [] [] ctype' convertArg (Table pt vt) nr path = do
in PFCat n cat rcs tcs vs <- getAllParamValues pt
mkTable pt (map (\v -> (v,convertArg vt nr (CSel v path))) vs)
convertArg (Sort _) nr path = do
(args,_) <- get
let PFCat _ cat schema = args !! nr
l = index (reversePath path) schema
sym | isLiteralCat cat = SymLit nr l
| otherwise = SymCat nr l
return (CStr [sym])
where where
ctype' -- extend the high-order linearization type index (CProj lbl path) (CRec rs) = case lookup lbl rs of
| n > 0 = case ctype of Just (Identity t) -> index path t
R xs -> R (xs ++ replicate n (S [])) index (CSel trm path) (CTbl _ rs) = case lookup trm rs of
_ -> error $ "Not a record: " ++ show ctype Just (Identity t) -> index path t
| otherwise = ctype index CNil (CStr idx) = idx
convertArg ty nr path = do
loop path rcs tcs (R record) = List.foldr (\(index,term) (rcs,tcs) -> loop (index:path) rcs tcs term) (rcs,tcs) (zip [0..] record) value <- choices nr (reversePath path)
loop path rcs tcs (C i) = ( rcs,(path,[0..i]):tcs) return (CPar value)
loop path rcs tcs (S _) = (path:rcs, tcs)
data Branch a convertRec CNil (RecType rs) record =
= Case Int FPath [Branch a] mkRecord (map (\(lbl,ctype) -> (lbl,convertTerm CNil ctype (projectRec lbl record))) rs)
| Variant [Branch a] convertRec (CProj lbl path) ctype record =
| Return (Value a) convertTerm path ctype (projectRec lbl record)
convertRec _ ctype _ = error ("convertRec: "++show ctype)
data Value a convertTbl CNil (Table _ vt) pt ts = do
= Rec [Branch a] vs <- getAllParamValues pt
| Str a mkTable pt (zipWith (\v t -> (v,convertTerm CNil vt t)) vs ts)
| Con LIndex convertTbl (CSel v sub_sel) ctype pt ts = do
vs <- getAllParamValues pt
case lookup v (zip vs ts) of
Just t -> convertTerm sub_sel ctype t
Nothing -> error (render (text "convertTbl:" <+> (text "missing value" <+> ppTerm Unqualified 0 v $$
text "among" <+> vcat (map (ppTerm Unqualified 0) vs))))
convertTbl _ ctype _ _ = error ("convertTbl: "++show ctype)
go' :: Branch SeqId -> FPath -> [SeqId] -> BacktrackM Env [SeqId] goB :: Branch (Value SeqId) -> Path -> [SeqId] -> BacktrackM Env [SeqId]
go' (Case nr path_ bs) path ss = do (index,b) <- member (zip [0..] bs) goB (Case nr path bs) rpath ss = do (value,b) <- member bs
restrictArg nr path_ index restrictArg nr path value
go' b path ss goB b rpath ss
go' (Variant bs) path ss = do b <- member bs goB (Variant bs) rpath ss = do b <- member bs
go' b path ss goB b rpath ss
go' (Return v) path ss = go v path ss goB (Return v) rpath ss = goV v rpath ss
go :: Value SeqId -> FPath -> [SeqId] -> BacktrackM Env [SeqId] goV :: Value SeqId -> Path -> [SeqId] -> BacktrackM Env [SeqId]
go (Rec xs) path ss = foldM (\ss (lbl,b) -> go' b (lbl:path) ss) ss (reverse (zip [0..] xs)) goV (CRec xs) rpath ss = foldM (\ss (lbl,b) -> goB b (CProj lbl rpath) ss) ss (reverse xs)
go (Str seqid) path ss = return (seqid : ss) goV (CTbl _ xs) rpath ss = foldM (\ss (trm,b) -> goB b (CSel trm rpath) ss) ss (reverse xs)
go (Con i) path ss = restrictHead path i >> return ss goV (CStr seqid) rpath ss = return (seqid : ss)
goV (CPar t) rpath ss = restrictHead (reversePath rpath) t >> return ss
addSequences' :: GrammarEnv -> Branch [Symbol] -> (GrammarEnv, Branch SeqId) addSequencesB :: GrammarEnv -> Branch (Value [Symbol]) -> (GrammarEnv, Branch (Value SeqId))
addSequences' env (Case nr path bs) = let (env1,bs1) = List.mapAccumL addSequences' env bs addSequencesB env (Case nr path bs) = let (env1,bs1) = List.mapAccumL (\env (trm,b) -> let (env',b') = addSequencesB env b
in (env',(trm,b'))) env bs
in (env1,Case nr path bs1) in (env1,Case nr path bs1)
addSequences' env (Variant bs) = let (env1,bs1) = List.mapAccumL addSequences' env bs addSequencesB env (Variant bs) = let (env1,bs1) = List.mapAccumL addSequencesB env bs
in (env1,Variant bs1) in (env1,Variant bs1)
addSequences' env (Return v) = let (env1,v1) = addSequences env v addSequencesB env (Return v) = let (env1,v1) = addSequencesV env v
in (env1,Return v1) in (env1,Return v1)
addSequences :: GrammarEnv -> Value [Symbol] -> (GrammarEnv, Value SeqId) addSequencesV :: GrammarEnv -> Value [Symbol] -> (GrammarEnv, Value SeqId)
addSequences env (Rec vs) = let (env1,vs1) = List.mapAccumL addSequences' env vs addSequencesV env (CRec vs) = let (env1,vs1) = List.mapAccumL (\env (lbl,b) -> let (env',b') = addSequencesB env b
in (env1,Rec vs1) in (env',(lbl,b'))) env vs
addSequences env (Str lin) = let (env1,seqid) = addFSeq env (optimizeLin lin) in (env1,CRec vs1)
in (env1,Str seqid) addSequencesV env (CTbl pt vs)=let (env1,vs1) = List.mapAccumL (\env (trm,b) -> let (env',b') = addSequencesB env b
addSequences env (Con i) = (env,Con i) in (env',(trm,b'))) env vs
in (env1,CTbl pt vs1)
addSequencesV env (CStr lin) = let (env1,seqid) = addFSeq env (optimizeLin lin)
in (env1,CStr seqid)
addSequencesV env (CPar i) = (env,CPar i)
optimizeLin [] = [] optimizeLin [] = []
@@ -251,98 +405,76 @@ optimizeLin lin@(SymKS _ : _) =
optimizeLin (sym : lin) = sym : optimizeLin lin optimizeLin (sym : lin) = sym : optimizeLin lin
convertTerm :: FPath -> Term -> Term -> CnvMonad (Value [Symbol])
convertTerm sel ctype (V nr) = convertArg ctype nr (reverse sel)
convertTerm sel ctype (C nr) = convertCon ctype nr (reverse sel)
convertTerm sel ctype (R record) = convertRec sel ctype record
convertTerm sel ctype (P term p) = do nr <- evalTerm [] p
convertTerm (nr:sel) ctype term
convertTerm sel ctype (FV vars) = do term <- variants vars
convertTerm sel ctype term
convertTerm sel ctype (S ts) = do vs <- mapM (convertTerm sel ctype) ts
return (Str (concat [s | Str s <- vs]))
convertTerm sel ctype (K (KS t)) = return (Str [SymKS [t]])
convertTerm sel ctype (K (KP s v))=return (Str [SymKP s v])
convertTerm sel ctype (W s t) = do
ss <- case t of
R ss -> return ss
convertRec sel ctype [K (KS (s ++ s1)) | K (KS s1) <- ss]
convertTerm sel ctype x = error ("convertTerm ("++show x++")")
convertArg :: Term -> Int -> FPath -> CnvMonad (Value [Symbol])
convertArg (R ctypes) nr path = do
mkRecord (zipWith (\lbl ctype -> convertArg ctype nr (lbl:path)) [0..] ctypes)
convertArg (C max) nr path = do
index <- choices nr path
return (Con index)
convertArg (S _) nr path = do
(args,_) <- get
let PFCat _ cat rcs tcs = args !! nr
l = index path rcs 0
sym | isLiteralCat cat = SymLit nr l
| otherwise = SymCat nr l
return (Str [sym])
where
index lbl' (lbl:lbls) idx
| lbl' == lbl = idx
| otherwise = index lbl' lbls $! (idx+1)
convertCon (C max) index [] = return (Con index)
convertCon x _ _ = fail $ "SimpleToFCFG.convertCon: " ++ show x
convertRec [] (R ctypes) record = do
mkRecord (zipWith (convertTerm []) ctypes record)
convertRec (index:sub_sel) ctype record =
convertTerm sub_sel ctype (record !! index)
------------------------------------------------------------ ------------------------------------------------------------
-- eval a term to ground terms -- eval a term to ground terms
evalTerm :: FPath -> Term -> CnvMonad LIndex evalTerm :: Path -> Term -> CnvMonad Term
evalTerm path (V nr) = choices nr (reverse path) evalTerm CNil (QC f) = return (QC f)
evalTerm path (C nr) = return nr evalTerm CNil (App x y) = do x <- evalTerm CNil x
evalTerm path (R record) = case path of y <- evalTerm CNil y
(index:path) -> evalTerm path (record !! index) return (App x y)
evalTerm path (P term sel) = do index <- evalTerm [] sel evalTerm path (Vr x) = choices (getVarIndex x) path
evalTerm (index:path) term evalTerm path (R rs) = case path of
(CProj lbl path) -> evalTerm path (projectRec lbl rs)
CNil -> do rs <- mapM (\(lbl,(_,t)) -> do t <- evalTerm path t
return (assign lbl t)) rs
return (R rs)
evalTerm path (P term lbl) = evalTerm (CProj lbl path) term
evalTerm path (V pt ts) = case path of
(CSel trm path) -> do vs <- getAllParamValues pt
case lookup trm (zip vs ts) of
Just t -> evalTerm path t
Nothing -> error "evalTerm: missing value"
CNil -> do ts <- mapM (evalTerm path) ts
return (V pt ts)
evalTerm path (S term sel) = do v <- evalTerm CNil sel
evalTerm (CSel v path) term
evalTerm path (FV terms) = variants terms >>= evalTerm path evalTerm path (FV terms) = variants terms >>= evalTerm path
evalTerm path x = error ("evalTerm ("++show x++")") evalTerm path t = error (render (text "evalTerm" <+> parens (ppTerm Unqualified 0 t)))
getVarIndex (IA _ i) = i
getVarIndex (IAV _ _ i) = i
getVarIndex (IC s) | isDigit (BS.last s) = (read . BS.unpack . snd . BS.spanEnd isDigit) s
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- GrammarEnv -- GrammarEnv
data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int CatSet SeqSet FunSet CoerceSet (IntMap.IntMap (Set.Set Production)) data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int CatSet SeqSet FunSet CoerceSet (IntMap.IntMap (Set.Set Production))
type CatSet = IntMap.IntMap (Map.Map CId (FId,FId,[Int],Array LIndex String)) type CatSet = IntMap.IntMap (Map.Map Ident (FId,FId,ProtoFCat))
type SeqSet = Map.Map Sequence SeqId type SeqSet = Map.Map Sequence SeqId
type FunSet = Map.Map CncFun FunId type FunSet = Map.Map CncFun FunId
type CoerceSet= Map.Map [FId] FId type CoerceSet= Map.Map [FId] FId
emptyGrammarEnv lincats params = emptyGrammarEnv gr (m,mo) =
let (last_id,catSet) = Map.mapAccumWithKey computeCatRange 0 lincats let (last_id,catSet) = Map.mapAccumWithKey computeCatRange 0 lincats
in GrammarEnv last_id (IntMap.singleton 0 catSet) Map.empty Map.empty Map.empty IntMap.empty in GrammarEnv last_id (IntMap.singleton 0 catSet) Map.empty Map.empty Map.empty IntMap.empty
where where
computeCatRange index cat ctype computeCatRange index cat ctype =
| cat == cidString = (index, (fcatString,fcatString,[],listArray (0,0) ["s"])) (index+size,(index,index+size-1,PFCat 0 cat schema))
| cat == cidInt = (index, (fcatInt, fcatInt, [],listArray (0,0) ["s"]))
| cat == cidFloat = (index, (fcatFloat, fcatFloat, [],listArray (0,0) ["s"]))
| cat == cidVar = (index, (fcatVar, fcatVar, [],listArray (0,0) ["s"]))
| otherwise = (index+size,(index,index+size-1, poly,maybe (error "missing params") (mkArray . getLabels []) (Map.lookup cat params)))
where where
(size,poly) = getMultipliers 1 [] ctype ((_,size),schema) = compute (0,1) ctype
getMultipliers m ms (R record) = foldr (\t (m,ms) -> getMultipliers m ms t) (m,ms) record compute st (RecType rs) = let (st',rs') = List.mapAccumL (\st (lbl,t) -> let (st',t') = compute st t
getMultipliers m ms (S _) = (m,ms) in (st',(lbl,Identity t'))) st rs
getMultipliers m ms (C max_index) = (m*(max_index+1),m : ms) in (st',CRec rs')
compute st (Table pt vt) = let vs = err error id (allParamValues gr pt)
(st',cs') = List.mapAccumL (\st v -> let (st',vt') = compute st vt
in (st',(v,Identity vt'))) st vs
in (st',CTbl pt cs')
compute st (Sort s)
| s == cStr = let (index,m) = st
in ((index+1,m),CStr index)
compute st t = let vs = err error id (allParamValues gr t)
(index,m) = st
in ((index,m*length vs),CPar (m,zip vs [0..]))
getLabels ls (R record) = concat [getLabels (l:ls) t | P (K (KS l)) t <- record] lincats =
getLabels ls (S [FV ps,t]) = concat [getLabels (l:ls) t | K (KS l) <- ps] Map.insert cVar (Sort cStr) $
getLabels ls (S []) = [unwords (reverse ls)] Map.fromAscList
getLabels ls (FV _) = [] [(c, ty) | (c,GF.Grammar.CncCat (Just (L _ ty)) _ _) <- Map.toList (M.jments mo)]
getLabels _ t = error (show t)
expandHOAS opts abs_defs lincats lindefs env =
expandHOAS opts (m,mo) env = return env {-
foldM add_varFun (foldl (\env ncat -> add_hoFun (add_hoCat env ncat) ncat) env hoTypes) (Map.keys lincats) foldM add_varFun (foldl (\env ncat -> add_hoFun (add_hoCat env ncat) ncat) env hoTypes) (Map.keys lincats)
where where
hoTypes :: [(Int,CId)] hoTypes :: [(Int,CId)]
@@ -379,10 +511,10 @@ expandHOAS opts abs_defs lincats lindefs env =
add_varFun env cat = add_varFun env cat =
case Map.lookup cat lindefs of case Map.lookup cat lindefs of
Nothing -> return env Nothing -> return env
Just lindef -> convertRule opts env (PFRule _V [(0,cidVar)] (0,cat) [arg] res lindef) Just lindef -> convertRule opts env (PFRule _V [(0,cVar)] (0,cat) [arg] res lindef)
where where
arg = arg =
case Map.lookup cidVar lincats of case Map.lookup cVar lincats of
Nothing -> error $ "No lincat for " ++ showCId cat Nothing -> error $ "No lincat for " ++ showCId cat
Just ctype -> ctype Just ctype -> ctype
@@ -390,7 +522,7 @@ expandHOAS opts abs_defs lincats lindefs env =
case Map.lookup cat lincats of case Map.lookup cat lincats of
Nothing -> error $ "No lincat for " ++ showCId cat Nothing -> error $ "No lincat for " ++ showCId cat
Just ctype -> ctype Just ctype -> ctype
-}
addProduction :: GrammarEnv -> FId -> Production -> GrammarEnv addProduction :: GrammarEnv -> FId -> Production -> GrammarEnv
addProduction (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) cat p = addProduction (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) cat p =
GrammarEnv last_id catSet seqSet funSet crcSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet) GrammarEnv last_id catSet seqSet funSet crcSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet)
@@ -420,57 +552,87 @@ addFCoercion env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) sub_fc
Nothing -> let !fcat = last_id+1 Nothing -> let !fcat = last_id+1
in (GrammarEnv fcat catSet seqSet funSet (Map.insert sub_fcats fcat crcSet) prodSet,fcat) in (GrammarEnv fcat catSet seqSet funSet (Map.insert sub_fcats fcat crcSet) prodSet,fcat)
getParserInfo :: Map.Map CId Literal -> Map.Map CId String -> GrammarEnv -> Concr getConcr :: Map.Map CId Literal -> Map.Map CId String -> GrammarEnv -> Concr
getParserInfo flags printnames (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) = getConcr flags printnames (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) =
Concr { cflags = flags Concr { cflags = flags
, printnames = printnames , printnames = printnames
, cncfuns = mkArray funSet , cncfuns = mkSetArray funSet
, sequences = mkArray seqSet , sequences = mkSetArray seqSet
, productions = IntMap.union prodSet coercions , productions = IntMap.union prodSet coercions
, pproductions = IntMap.empty , pproductions = IntMap.empty
, lproductions = Map.empty , lproductions = Map.empty
, cnccats = maybe Map.empty (Map.map (\(start,end,_,lbls) -> (CncCat start end lbls))) (IntMap.lookup 0 catSet) , cnccats = Map.fromList [(i2i cat,PGF.Data.CncCat start end (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath) (getStrPaths schema))))
| (cat,(start,end,PFCat _ _ schema)) <- maybe [] Map.toList (IntMap.lookup 0 catSet)]
, totalCats = last_id+1 , totalCats = last_id+1
} }
where where
mkArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map] mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
coercions = IntMap.fromList [(fcat,Set.fromList (map PCoerce sub_fcats)) | (sub_fcats,fcat) <- Map.toList crcSet] coercions = IntMap.fromList [(fcat,Set.fromList (map PCoerce sub_fcats)) | (sub_fcats,fcat) <- Map.toList crcSet]
getFCats :: GrammarEnv -> ProtoFCat -> [FId] getStrPaths :: Schema Identity s c -> [Path]
getFCats (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (PFCat n cat rcs tcs) = getStrPaths = collect CNil []
case IntMap.lookup n catSet >>= Map.lookup cat of where
Just (start,end,ms,_) -> reverse (solutions (variants ms tcs start) ()) collect path paths (CRec rs) = foldr (\(lbl,Identity t) paths -> collect (CProj lbl path) paths t) paths rs
where collect path paths (CTbl _ cs) = foldr (\(trm,Identity t) paths -> collect (CSel trm path) paths t) paths cs
variants _ [] fcat = return fcat collect path paths (CStr _) = reversePath path : paths
variants (m:ms) ((_,indices) : tcs) fcat = do index <- member indices collect path paths (CPar _) = paths
variants ms tcs ((m*index) + fcat)
getFCats :: GrammarEnv -> ProtoFCat -> [FId]
getFCats (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (PFCat n cat schema) =
case IntMap.lookup n catSet >>= Map.lookup cat of
Just (start,end,_) -> reverse (solutions (fmap (start +) $ variants schema) ())
where
variants (CRec rs) = fmap sum $ mapM (\(lbl,Identity t) -> variants t) rs
variants (CTbl _ cs) = fmap sum $ mapM (\(trm,Identity t) -> variants t) cs
variants (CStr _) = return 0
variants (CPar (m,values)) = do (value,index) <- member values
return (m*index)
getFCatsX :: GrammarEnv -> ProtoFCat -> [FId]
getFCatsX (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (PFCat n cat schema) =
case IntMap.lookup n catSet >>= Map.lookup cat of
Just (start,end,_) -> reverse (solutions (fmap (start +) $ variants schema) ())
where
variants (CRec rs) = fmap sum $ mapM (\(lbl,Identity t) -> variants t) rs
variants (CTbl _ cs) = fmap sum $ mapM (\(trm,Identity t) -> variants t) cs
variants (CStr _) = return 0
variants (CPar (m,values)) = do (value,index) <- member values
return (m*index)
------------------------------------------------------------ ------------------------------------------------------------
-- updating the MCF rule -- updating the MCF rule
restrictArg :: LIndex -> FPath -> LIndex -> BacktrackM Env () restrictArg :: LIndex -> Path -> Term -> BacktrackM Env ()
restrictArg nr path index = do restrictArg nr path index = do
(head, args) <- get (head, args) <- get
args' <- updateNthM (restrictProtoFCat path index) nr args args <- updateNthM (restrictProtoFCat path index) nr args
put (head, args') put (head, args)
restrictHead :: FPath -> LIndex -> BacktrackM Env () restrictHead :: Path -> Term -> BacktrackM Env ()
restrictHead path term restrictHead path term = do
= do (head, args) <- get (head, args) <- get
head' <- restrictProtoFCat path term head head <- restrictProtoFCat path term head
put (head', args) put (head, args)
restrictProtoFCat :: FPath -> LIndex -> ProtoFCat -> BacktrackM Env ProtoFCat restrictProtoFCat :: (Functor m, MonadPlus m) => Path -> Term -> ProtoFCat -> m ProtoFCat
restrictProtoFCat path0 index0 (PFCat n cat rcs tcs) = do restrictProtoFCat path v (PFCat n cat schema) = do
tcs <- addConstraint tcs schema <- addConstraint path v schema
return (PFCat n cat rcs tcs) return (PFCat n cat schema)
where where
addConstraint [] = error "restrictProtoFCat: unknown path" addConstraint (CProj lbl path) v (CRec rs) = fmap CRec $ update lbl (addConstraint path v) rs
addConstraint (c@(path,indices) : tcs) addConstraint (CSel trm path) v (CTbl pt cs) = fmap (CTbl pt) $ update trm (addConstraint path v) cs
| path0 == path = guard (index0 `elem` indices) >> addConstraint CNil v (CPar (m,vs)) = case lookup v vs of
return ((path,[index0]) : tcs) Just index -> return (CPar (m,[(v,index)]))
| otherwise = liftM (c:) (addConstraint tcs) Nothing -> mzero
addConstraint CNil v (CStr _) = error "restrictProtoFCat: string path"
update k0 f [] = return []
update k0 f (x@(k,Identity v):xs)
| k0 == k = do v <- f v
return ((k,Identity v):xs)
| otherwise = do xs <- update k0 f xs
return (x:xs)
mkArray lst = listArray (0,length lst-1) lst mkArray lst = listArray (0,length lst-1) lst

559
src/compiler/GF/Compile/GrammarToPGF.hs
View File

@@ -6,7 +6,6 @@ import GF.Compile.GeneratePMCFG
import PGF.CId import PGF.CId
import PGF.Optimize(updateProductionIndices) import PGF.Optimize(updateProductionIndices)
import PGF.Check(checkLin)
import qualified PGF.Macros as CM import qualified PGF.Macros as CM
import qualified PGF.Data as C import qualified PGF.Data as C
import qualified PGF.Data as D import qualified PGF.Data as D
@@ -38,76 +37,39 @@ traceD s t = t
-- the main function: generate PGF from GF. -- the main function: generate PGF from GF.
mkCanon2pgf :: Options -> String -> SourceGrammar -> IO D.PGF mkCanon2pgf :: Options -> Ident -> SourceGrammar -> IO D.PGF
mkCanon2pgf opts cnc gr = (canon2pgf opts pars . reorder abs . canon2canon opts abs) gr mkCanon2pgf opts cnc gr = (canon2pgf opts gr . reorder abs) gr
where where
abs = err (const c) id $ M.abstractOfConcrete gr c where c = identC (BS.pack cnc) abs = err (const cnc) id $ M.abstractOfConcrete gr cnc
pars = mkParamLincat gr
-- Generate PGF from GFCM. -- Generate PGF from grammar.
-- this assumes a grammar translated by canon2canon
canon2pgf :: Options -> (Ident -> Ident -> C.Term) -> SourceGrammar -> IO D.PGF canon2pgf :: Options -> SourceGrammar -> SourceGrammar -> IO D.PGF
canon2pgf opts pars cgr@(M.MGrammar ((a,abm):cms)) = do canon2pgf opts gr cgr@(M.MGrammar (am:cms)) = do
if dump opts DumpCanon if dump opts DumpCanon
then putStrLn (render (vcat (map (ppModule Qualified) (M.modules cgr)))) then putStrLn (render (vcat (map (ppModule Qualified) (M.modules cgr))))
else return () else return ()
cncs <- sequence [mkConcr lang (i2i lang) mo | (lang,mo) <- cms] (an,abs) <- mkAbstr am
return $ updateProductionIndices (D.PGF gflags an abs (Map.fromList cncs)) cncs <- mapM (mkConcr am) cms
where return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs))
-- abstract where
an = (i2i a) mkAbstr (a,abm) = return (i2i a, D.Abstr flags funs cats)
abs = D.Abstr aflags funs cats where
gflags = Map.empty flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF (M.flags abm)]
aflags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF (M.flags abm)]
funs = Map.fromAscList [(i2i f, (mkType [] ty, mkArrity ma, mkDef pty)) |
(f,AbsFun (Just (L _ ty)) ma pty) <- Map.toAscList (M.jments abm)]
cats = Map.fromAscList [(i2i c, (snd (mkContext [] cont),catfuns c)) |
(c,AbsCat (Just (L _ cont))) <- Map.toAscList (M.jments abm)]
mkDef (Just eqs) = Just [C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps] catfuns cat =
mkDef Nothing = Nothing (map snd . sortBy (compare `on` fst))
[(loc,i2i f) | (f,AbsFun (Just (L loc ty)) _ _) <- tree2list (M.jments abm), snd (GM.valCat ty) == cat]
mkArrity (Just a) = a mkConcr am cm@(lang,mo) = do
mkArrity Nothing = 0 cnc <- convertConcrete opts gr am cm
return (i2i lang, cnc)
-- concretes
lfuns = [(f', (mkType [] ty, mkArrity ma, mkDef pty)) |
(f,AbsFun (Just (L _ ty)) ma pty) <- tree2list (M.jments abm), let f' = i2i f]
funs = Map.fromAscList lfuns
lcats = [(i2i c, (snd (mkContext [] cont),catfuns c)) |
(c,AbsCat (Just (L _ cont))) <- tree2list (M.jments abm)]
cats = Map.fromAscList lcats
catfuns cat =
(map snd . sortBy (compare `on` fst))
[(loc,i2i f) | (f,AbsFun (Just (L loc ty)) _ _) <- tree2list (M.jments abm), snd (GM.valCat ty) == cat]
mkConcr lang0 lang mo = do
lins' <- case mapM (checkLin (funs,lins,lincats) lang) (Map.toList lins) of
Ok x -> return x
Bad msg -> fail msg
cnc <- convertConcrete opts lang flags printnames funs (Map.fromList (map fst lins')) lincats params lindefs
return (lang, cnc)
where
js = tree2list (M.jments mo)
flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF (M.flags mo)]
utf = id -- trace (show lang0 +++ show flags) $
-- if moduleFlag optEncoding (moduleOptions (M.flags mo)) == UTF_8
-- then id else id
---- then (trace "decode" D.convertStringsInTerm decodeUTF8) else id
umkTerm = utf . mkTerm
lins = Map.fromAscList
[(f', umkTerm tr) | (f,CncFun _ (Just (L _ tr)) _) <- js,
let f' = i2i f, exists f'] -- eliminating lins without fun
-- needed even here because of restricted inheritance
lincats = Map.fromAscList
[(i2i c, mkCType ty) | (c,CncCat (Just (L _ ty)) _ _) <- js]
lindefs = Map.fromAscList
[(i2i c, umkTerm tr) | (c,CncCat _ (Just (L _ tr)) _) <- js]
printnames = Map.union
(Map.fromAscList [(i2i f, realize (umkTerm tr)) | (f,CncFun _ _ (Just (L _ tr))) <- js])
(Map.fromAscList [(i2i f, realize (umkTerm tr)) | (f,CncCat _ _ (Just (L _ tr))) <- js])
params = Map.fromAscList
[(i2i c, pars lang0 c) | (c,CncCat (Just ty) _ _) <- js]
fcfg = Nothing
exists f = Map.member f funs
i2i :: Ident -> CId i2i :: Ident -> CId
i2i = CId . ident2bs i2i = CId . ident2bs
@@ -153,465 +115,40 @@ mkPatt scope p =
in (scope',C.PImplArg p') in (scope',C.PImplArg p')
A.PTilde t -> ( scope,C.PTilde (mkExp scope t)) A.PTilde t -> ( scope,C.PTilde (mkExp scope t))
mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo]) mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo])
mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
in if x == identW in if x == identW
then ( scope,(b2b bt,i2i x,ty')) then ( scope,(b2b bt,i2i x,ty'))
else (x:scope,(b2b bt,i2i x,ty'))) scope hyps else (x:scope,(b2b bt,i2i x,ty'))) scope hyps
mkTerm :: Term -> C.Term mkDef (Just eqs) = Just [C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
mkTerm tr = case tr of mkDef Nothing = Nothing
Vr (IA _ i) -> C.V i
Vr (IAV _ _ i) -> C.V i
Vr (IC s) | isDigit (BS.last s) ->
C.V ((read . BS.unpack . snd . BS.spanEnd isDigit) s)
---- from gf parser of gfc
EInt i -> C.C $ fromInteger i
R rs -> C.R [mkTerm t | (_, (_,t)) <- rs]
P t l -> C.P (mkTerm t) (C.C (mkLab l))
T _ cs -> C.R [mkTerm t | (_,t) <- cs] ------
V _ cs -> C.R [mkTerm t | t <- cs]
S t p -> C.P (mkTerm t) (mkTerm p)
C s t -> C.S $ concatMap flats [mkTerm x | x <- [s,t]]
FV ts -> C.FV [mkTerm t | t <- ts]
K s -> C.K (C.KS s)
----- K (KP ss _) -> C.K (C.KP ss []) ---- TODO: prefix variants
Empty -> C.S []
App _ _ -> prtTrace tr $ C.C 66661 ---- for debugging
Abs _ _ t -> mkTerm t ---- only on toplevel
Alts td tvs ->
C.K (C.KP (strings td) [C.Alt (strings u) (strings v) | (u,v) <- tvs])
_ -> prtTrace tr $ C.S [C.K (C.KS (render (A.ppTerm Unqualified 0 tr <+> int 66662)))] ---- for debugging
where
mkLab (LIdent l) = case BS.unpack l of
'_':ds -> (read ds) :: Int
_ -> prtTrace tr $ 66663
strings t = case t of
K s -> [s]
C u v -> strings u ++ strings v
Strs ss -> concatMap strings ss
_ -> prtTrace tr $ ["66660"]
flats t = case t of
C.S ts -> concatMap flats ts
_ -> [t]
-- encoding PGF-internal lincats as terms mkArrity (Just a) = a
mkCType :: Type -> C.Term mkArrity Nothing = 0
mkCType t = case t of
EInt i -> C.C $ fromInteger i
RecType rs -> C.R [mkCType t | (_, t) <- rs]
Table pt vt -> case pt of
EInt i -> C.R $ replicate (1 + fromInteger i) $ mkCType vt
RecType rs -> mkCType $ foldr Table vt (map snd rs)
_ | Just i <- GM.isTypeInts pt -> C.R $ replicate (fromInteger i) $ mkCType vt
Sort s | s == cStr -> C.S [] --- Str only
_ | Just i <- GM.isTypeInts t -> C.C $ fromInteger i
_ -> error $ "mkCType " ++ show t
-- encoding showable lincats (as in source gf) as terms
mkParamLincat :: SourceGrammar -> Ident -> Ident -> C.Term
mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do
typ <- Look.lookupLincat sgr lang cat
mkPType typ
where
mkPType typ = case typ of
RecType lts -> do
ts <- mapM (mkPType . snd) lts
return $ C.R [ C.P (kks $ showIdent (label2ident l)) t | ((l,_),t) <- zip lts ts]
Table (RecType lts) v -> do
ps <- mapM (mkPType . snd) lts
v' <- mkPType v
return $ foldr (\p v -> C.S [p,v]) v' ps
Table p v -> do
p' <- mkPType p
v' <- mkPType v
return $ C.S [p',v']
Sort s | s == cStr -> return $ C.S []
_ -> return $
C.FV $ map (kks . renderStyle style{mode=OneLineMode} . ppTerm Unqualified 6) $
errVal [] $ Look.allParamValues sgr typ
kks = C.K . C.KS
-- return just one module per language -- return just one module per language
reorder :: Ident -> SourceGrammar -> SourceGrammar reorder :: Ident -> SourceGrammar -> SourceGrammar
reorder abs cg = M.MGrammar $ reorder abs cg =
(abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs): M.MGrammar $
[(c, M.ModInfo (M.MTConcrete abs) M.MSComplete fs [] Nothing [] [] (sorted2tree js)) (abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs):
| (c,(fs,js)) <- cncs] [(cnc, M.ModInfo (M.MTConcrete abs) M.MSComplete cflags [] Nothing [] [] cdefs)
where | cnc <- M.allConcretes cg abs, let (cflags,cdefs) = concr cnc]
mos = M.modules cg where
adefs = sorted2tree $ sortIds $ aflags =
predefADefs ++ Look.allOrigInfos cg abs concatOptions [M.flags mo | (_,mo) <- M.modules cg, M.isModAbs mo]
predefADefs =
[(c, AbsCat (Just (L (0,0) []))) | c <- [cFloat,cInt,cString]]
aflags =
concatOptions [M.flags mo | (_,mo) <- M.modules cg, M.isModAbs mo]
cncs = sortIds [(lang, concr lang) | lang <- M.allConcretes cg abs] adefs =
concr la = (flags, Map.fromList (predefADefs ++ Look.allOrigInfos cg abs)
sortIds (predefCDefs ++ jments)) where
jments = Look.allOrigInfos cg la
flags = concatOptions
[M.flags mo |
(i,mo) <- mos, M.isModCnc mo,
Just r <- [lookup i (M.allExtendSpecs cg la)]]
predefCDefs =
[(c, CncCat (Just (L (0,0) GM.defLinType)) Nothing Nothing) | c <- [cInt,cFloat,cString]]
sortIds = sortBy (\ (f,_) (g,_) -> compare f g)
-- one grammar per language - needed for symtab generation
repartition :: Ident -> SourceGrammar -> [SourceGrammar]
repartition abs cg =
[M.partOfGrammar cg (lang,mo) |
let mos = M.modules cg,
lang <- case M.allConcretes cg abs of
[] -> [abs] -- to make pgf nonempty even when there are no concretes
cncs -> cncs,
let mo = errVal
(error (render (text "no module found for" <+> A.ppIdent lang))) $ M.lookupModule cg lang
]
-- translate tables and records to arrays, parameters and labels to indices
canon2canon :: Options -> Ident -> SourceGrammar -> SourceGrammar
canon2canon opts abs cg0 =
(recollect . map cl2cl . repartition abs . purgeGrammar abs) cg0
where
recollect = M.MGrammar . nubBy (\ (i,_) (j,_) -> i==j) . concatMap M.modules
cl2cl = M.MGrammar . js2js . map (c2c p2p) . M.modules
js2js ms = map (c2c (j2j (M.MGrammar ms))) ms
c2c f2 (c,mo) = (c, M.replaceJudgements mo $ mapTree f2 (M.jments mo))
j2j cg (f,j) =
let debug = if verbAtLeast opts Verbose then trace ("+ " ++ showIdent f) else id in
case j of
CncFun x (Just (L loc tr)) z -> CncFun x (Just (L loc (debug (t2t (unfactor cg0 tr))))) z
CncCat (Just (L locty ty)) (Just (L locx x)) y -> CncCat (Just (L locty (ty2ty ty))) (Just (L locx (t2t (unfactor cg0 x)))) y
_ -> j
where
cg1 = cg
t2t = term2term f cg1 pv
ty2ty = type2type cg1 pv
pv@(labels,untyps,typs) = trs $ paramValues cg1
unfactor :: SourceGrammar -> Term -> Term
unfactor gr t = case t of
T (TTyped ty) [(PV x,u)] -> V ty [restore x v (unfac u) | v <- vals ty]
_ -> GM.composSafeOp unfac t
where
unfac = unfactor gr
vals = err error id . Look.allParamValues gr
restore x u t = case t of
Vr y | y == x -> u
_ -> GM.composSafeOp (restore x u) t
-- flatten record arguments of param constructors
p2p (f,j) = case j of
ResParam (Just ps) (Just vs) ->
ResParam (Just [L loc (c,concatMap unRec cont) | L loc (c,cont) <- ps]) (Just (map unrec vs))
_ -> j
unRec (bt,x,ty) = case ty of
RecType fs -> [ity | (_,typ) <- fs, ity <- unRec (Explicit,identW,typ)]
_ -> [(bt,x,ty)]
unrec t = case t of
App f (R fs) -> GM.mkApp (unrec f) [unrec u | (_,(_,u)) <- fs]
_ -> GM.composSafeOp unrec t
----
trs v = traceD (render (tr v)) v
tr (labels,untyps,typs) =
(text "LABELS:" <+>
vcat [A.ppIdent c <> char '.' <> hsep (map A.ppLabel l) <+> char '=' <+> text (show i) | ((c,l),i) <- Map.toList labels]) $$
(text "UNTYPS:" <+>
vcat [A.ppTerm Unqualified 0 t <+> char '=' <+> text (show i) | (t,i) <- Map.toList untyps]) $$
(text "TYPS: " <+>
vcat [A.ppTerm Unqualified 0 t <+> char '=' <+> text (show (Map.assocs i)) | (t,i) <- Map.toList typs])
----
purgeGrammar :: Ident -> SourceGrammar -> SourceGrammar
purgeGrammar abstr gr =
(M.MGrammar . list . filter complete . purge . M.modules) gr
where
list ms = traceD (render (text "MODULES" <+> hsep (punctuate comma (map (ppIdent . fst) ms)))) ms
purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst)
needed = nub $ concatMap (requiredCanModules isSingle gr) acncs
acncs = abstr : M.allConcretes gr abstr
isSingle = True
complete (i,m) = M.isCompleteModule m --- not . isIncompleteCanon
type ParamEnv =
(Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels
Map.Map Term Integer, -- untyped terms to values
Map.Map Type (Map.Map Term Integer)) -- types to their terms to values
--- gathers those param types that are actually used in lincats and lin terms
paramValues :: SourceGrammar -> ParamEnv
paramValues cgr = (labels,untyps,typs) where
partyps = nub $
--- [App (Q (IC "Predef") (IC "Ints")) (EInt i) | i <- [1,9]] ---linTypeInt
[ty |
(_,(_,CncCat (Just (L _ ty0)) _ _)) <- jments,
ty <- typsFrom ty0
] ++ [
Q (m,ty) |
(m,(ty,ResParam _ _)) <- jments
] ++ [ty |
(_,(_,CncFun _ (Just (L _ tr)) _)) <- jments,
ty <- err (const []) snd $ appSTM (typsFromTrm tr) []
]
params = [(ty, errVal (traceD ("UNKNOWN PARAM TYPE" +++ show ty) []) $
Look.allParamValues cgr ty) | ty <- partyps]
typsFrom ty = (if isParam ty then (ty:) else id) $ case ty of
Table p t -> typsFrom p ++ typsFrom t
RecType ls -> concat [typsFrom t | (_, t) <- ls]
_ -> []
isParam ty = case ty of
Q _ -> True
QC _ -> True
RecType rs -> all isParam (map snd rs)
_ -> False
typsFromTrm :: Term -> STM [Type] Term
typsFromTrm tr = case tr of
R fs -> mapM_ (typsFromField . snd) fs >> return tr
where where
typsFromField (mty, t) = case mty of predefADefs =
Just x -> updateSTM (x:) >> typsFromTrm t [(c, AbsCat (Just (L (0,0) []))) | c <- [cFloat,cInt,cString]]
_ -> typsFromTrm t
V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr
T (TTyped ty) cs ->
updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
T (TComp ty) cs ->
updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
_ -> GM.composOp typsFromTrm tr
mods = traceD (render (hsep (map (ppIdent . fst) ms))) ms where ms = M.modules cgr concr la = (flags, Map.fromList (predefCDefs ++ jments))
where
jments = flags = concatOptions [M.flags mo | (i,mo) <- M.modules cg, M.isModCnc mo,
[(m,j) | (m,mo) <- mods, j <- tree2list $ M.jments mo] Just r <- [lookup i (M.allExtendSpecs cg la)]]
typs = jments = Look.allOrigInfos cg la
Map.fromList [(ci,Map.fromList (zip vs [0..])) | (ci,vs) <- params] predefCDefs =
untyps = [(c, CncCat (Just (L (0,0) GM.defLinType)) Nothing Nothing) | c <- [cInt,cFloat,cString]]
Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs]
lincats =
[(cat,[f | let RecType fs = GM.defLinType, f <- fs]) | cat <- [cInt,cFloat, cString]] ++
reverse ---- TODO: really those lincats that are reached
---- reverse is enough to expel overshadowed ones...
[(cat,ls) | (_,(cat,CncCat (Just (L _ ty)) _ _)) <- jments,
RecType ls <- [unlockTy ty]]
labels = Map.fromList $ concat
[((cat,[lab]),(typ,i)):
[((cat,[LVar v]),(typ,toInteger (mx + v))) | v <- [0,1]] ++ ---- 1 or 2 vars
[((cat,[lab,lab2]),(ty,j)) |
rs <- getRec typ, ((lab2, ty),j) <- zip rs [0..]]
++
---- one more level, but: ...
[((cat,[lab,lab2,lab3]),(ty,j)) |
rss <- getRec typ, ((lab2, ty0),j0) <- zip rss [0..],
(_,ty2) <- rss,
rs <- getRec ty2, ((lab3, ty),j) <- zip rs [0..]]
|
(cat,ls) <- lincats, ((lab, typ),i) <- zip ls [0..], let mx = length ls]
-- go to tables recursively
---- ... TODO: go to deeper records
where
getRec typ = case typ of
RecType rs -> [rs] ---- [unlockTyp rs] -- (sort (unlockTyp ls))
Table _ t -> getRec t
_ -> []
type2type :: SourceGrammar -> ParamEnv -> Type -> Type
type2type cgr env@(labels,untyps,typs) ty = case ty of
RecType rs ->
RecType [(mkLab i, t2t t) | (i,(l, t)) <- zip [0..] (unlockTyp rs)]
Table pt vt -> Table (t2t pt) (t2t vt)
QC _ -> look ty
_ -> ty
where
t2t = type2type cgr env
look ty = EInt $ (+ (-1)) $ toInteger $ case Map.lookup ty typs of
Just vs -> length $ Map.assocs vs
_ -> trace ("unknown partype " ++ show ty) 66669
term2term :: Ident -> SourceGrammar -> ParamEnv -> Term -> Term
term2term fun cgr env@(labels,untyps,typs) tr = case tr of
App _ _ -> mkValCase (unrec tr)
QC _ -> mkValCase tr
R rs -> R [(mkLab i, (Nothing, t2t t)) |
(i,(l,(_,t))) <- zip [0..] (GM.sortRec (unlock rs))]
P t l -> r2r tr
T (TWild _) _ -> error $ (render (text "wild" <+> ppTerm Qualified 0 tr))
T (TComp ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
T (TTyped ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
V ty ts -> mkCurry $ V ty [t2t t | t <- ts]
S t p -> mkCurrySel (t2t t) (t2t p)
_ -> GM.composSafeOp t2t tr
where
t2t = term2term fun cgr env
unrec t = case t of
App f (R fs) -> GM.mkApp (unrec f) [unrec u | (_,(_,u)) <- fs]
_ -> GM.composSafeOp unrec t
mkValCase tr = case appSTM (doVar tr) [] of
Ok (tr', st@(_:_)) -> t2t $ comp $ foldr mkCase tr' st
_ -> valNum $ comp tr
--- this is mainly needed for parameter record projections
---- was:
comp t = errVal t $ Compute.computeConcreteRec cgr t
doVar :: Term -> STM [((Type,[Term]),(Term,Term))] Term
doVar tr = case getLab tr of
Ok (cat, lab) -> do
k <- readSTM >>= return . length
let tr' = Vr $ identC $ (BS.pack (show k)) -----
let tyvs = case Map.lookup (cat,lab) labels of
Just (ty,_) -> case Map.lookup ty typs of
Just vs -> (ty,[t |
(t,_) <- sortBy (\x y -> compare (snd x) (snd y))
(Map.assocs vs)])
_ -> error $ render (text "doVar1" <+> A.ppTerm Unqualified 0 ty)
_ -> error $ render (text "doVar2" <+> A.ppTerm Unqualified 0 tr <+> text (show (cat,lab))) ---- debug
updateSTM ((tyvs, (tr', tr)):)
return tr'
_ -> GM.composOp doVar tr
r2r tr@(P (S (V ty ts) v) l) = t2t $ S (V ty [comp (P t l) | t <- ts]) v
r2r tr@(P p _) = case getLab tr of
Ok (cat,labs) -> P (t2t p) . mkLab $
maybe (prtTrace tr $ 66664) snd $
Map.lookup (cat,labs) labels
_ -> K (render (A.ppTerm Unqualified 0 tr <+> prtTrace tr (int 66665)))
-- this goes recursively into tables (ignored) and records (accumulated)
getLab tr = case tr of
Vr (IA cat _) -> return (identC cat,[])
Vr (IAV cat _ _) -> return (identC cat,[])
Vr (IC s) -> return (identC cat,[]) where
cat = BS.takeWhile (/='_') s ---- also to match IAVs; no _ in a cat tolerated
---- init (reverse (dropWhile (/='_') (reverse s))) ---- from gf parser
---- Vr _ -> error $ "getLab " ++ show tr
P p lab2 -> do
(cat,labs) <- getLab p
return (cat,labs++[lab2])
S p _ -> getLab p
_ -> Bad "getLab"
mkCase ((ty,vs),(x,p)) tr =
S (V ty [mkBranch x v tr | v <- vs]) p
mkBranch x t tr = case tr of
_ | tr == x -> t
_ -> GM.composSafeOp (mkBranch x t) tr
valNum tr = maybe (valNumFV $ tryFV tr) EInt $ Map.lookup tr untyps
where
tryFV tr = case GM.appForm tr of
(c@(QC _), ts) -> [GM.mkApp c ts' | ts' <- combinations (map tryFV ts)]
(FV ts,_) -> ts
_ -> [tr]
valNumFV ts = case ts of
[tr] -> let msg = render (text "DEBUG" <+> ppIdent fun <> text ": error in valNum" <+> ppTerm Qualified 0 tr) in
trace msg $ error (showIdent fun)
_ -> FV $ map valNum ts
mkCurry trm = case trm of
V (RecType [(_,ty)]) ts -> V ty ts
V (RecType ((_,ty):ltys)) ts ->
V ty [mkCurry (V (RecType ltys) cs) |
cs <- chop (product (map (lengthtyp . snd) ltys)) ts]
_ -> trm
lengthtyp ty = case Map.lookup ty typs of
Just m -> length (Map.assocs m)
_ -> error $ "length of type " ++ show ty
chop i xs = case splitAt i xs of
(xs1,[]) -> [xs1]
(xs1,xs2) -> xs1:chop i xs2
mkCurrySel t p = S t p -- done properly in CheckGFCC
mkLab k = LIdent (BS.pack ("_" ++ show k))
-- remove lock fields; in fact, any empty records and record types
unlock = filter notlock where
notlock (l,(_, t)) = case t of --- need not look at l
R [] -> False
RecType [] -> False
_ -> True
unlockTyp = filter notlock
notlock (l, t) = case t of --- need not look at l
RecType [] -> False
_ -> True
unlockTy ty = case ty of
RecType ls -> RecType $ GM.sortRec [(l, unlockTy t) | (l,t) <- ls, notlock (l,t)]
_ -> GM.composSafeOp unlockTy ty
prtTrace tr n =
trace (render (text "-- INTERNAL COMPILER ERROR" <+> A.ppTerm Unqualified 0 tr $$ text (show n))) n
prTrace tr n = trace (render (text "-- OBSERVE" <+> A.ppTerm Unqualified 0 tr <+> text (show n) <+> text (show tr))) n
-- | this function finds out what modules are really needed in the canonical gr.
-- its argument is typically a concrete module name
requiredCanModules :: Bool -> M.MGrammar a -> Ident -> [Ident]
requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where
exts = M.allExtends gr c
ops = if isSingle
then map fst (M.modules gr)
else iterFix (concatMap more) $ exts
more i = errVal [] $ do
m <- M.lookupModule gr i
return $ M.extends m ++ [o | o <- map M.openedModule (M.opens m)]
notReuse i = errVal True $ do
m <- M.lookupModule gr i
return $ M.isModRes m -- to exclude reused Cnc and Abs from required
realize :: C.Term -> String
realize = concat . take 1 . realizes
realizes :: C.Term -> [String]
realizes = map (unwords . untokn) . realizest
realizest :: C.Term -> [[C.Tokn]]
realizest trm = case trm of
C.R ts -> realizest (ts !! 0)
C.S ss -> map concat $ combinations $ map realizest ss
C.K t -> [[t]]
C.W s t -> [[C.KS (s ++ r)] | [C.KS r] <- realizest t]
C.FV ts -> concatMap realizest ts
C.TM s -> [[C.KS s]]
_ -> [[C.KS $ "REALIZE_ERROR " ++ show trm]] ---- debug
untokn :: [C.Tokn] -> [String]
untokn ts = case ts of
C.KP d _ : [] -> d
C.KP d vs : ws -> let ss@(s:_) = untokn ws in sel d vs s ++ ss
C.KS s : ws -> s : untokn ws
[] -> []
where
sel d vs w = case [v | C.Alt v cs <- vs, any (\c -> isPrefixOf c w) cs] of
v:_ -> v
_ -> d

5
src/compiler/GF/Compile/PGFtoProlog.hs
View File

@@ -127,11 +127,6 @@ instance PLPrint Literal where
plp (LInt n) = plp (show n) plp (LInt n) = plp (show n)
plp (LFlt f) = plp (show f) plp (LFlt f) = plp (show f)
instance PLPrint Tokn where
plp (KS tokn) = plp tokn
plp (KP strs alts) = plTerm "kp" [plp strs, plList [plOper "/" (plp ss1) (plp ss2) |
Alt ss1 ss2 <- alts]]
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- basic prolog-printing -- basic prolog-printing

4
src/compiler/GF/Grammar/Grammar.hs
View File

@@ -119,7 +119,7 @@ data Term =
| Cn Ident -- ^ constant | Cn Ident -- ^ constant
| Con Ident -- ^ constructor | Con Ident -- ^ constructor
| Sort Ident -- ^ basic type | Sort Ident -- ^ basic type
| EInt Integer -- ^ integer literal | EInt Int -- ^ integer literal
| EFloat Double -- ^ floating point literal | EFloat Double -- ^ floating point literal
| K String -- ^ string literal or token: @\"foo\"@ | K String -- ^ string literal or token: @\"foo\"@
| Empty -- ^ the empty string @[]@ | Empty -- ^ the empty string @[]@
@@ -171,7 +171,7 @@ data Patt =
| PW -- ^ wild card pattern: @_@ | PW -- ^ wild card pattern: @_@
| PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@ -- only concrete | PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@ -- only concrete
| PString String -- ^ string literal pattern: @\"foo\"@ -- only abstract | PString String -- ^ string literal pattern: @\"foo\"@ -- only abstract
| PInt Integer -- ^ integer literal pattern: @12@ -- only abstract | PInt Int -- ^ integer literal pattern: @12@ -- only abstract
| PFloat Double -- ^ float literal pattern: @1.2@ -- only abstract | PFloat Double -- ^ float literal pattern: @1.2@ -- only abstract
| PT Type Patt -- ^ type-annotated pattern | PT Type Patt -- ^ type-annotated pattern

2
src/compiler/GF/Grammar/Lexer.x
View File

@@ -112,7 +112,7 @@ data Token
| T_where | T_where
| T_with | T_with
| T_String String -- string literals | T_String String -- string literals
| T_Integer Integer -- integer literals | T_Integer Int -- integer literals
| T_Double Double -- double precision float literals | T_Double Double -- double precision float literals
| T_LString String | T_LString String
| T_Ident Ident | T_Ident Ident

12
src/compiler/GF/Grammar/Macros.hs
View File

@@ -166,6 +166,12 @@ unzipR r = (ls, map snd ts) where (ls,ts) = unzip r
mkAssign :: [(Label,Term)] -> [Assign] mkAssign :: [(Label,Term)] -> [Assign]
mkAssign lts = [assign l t | (l,t) <- lts] mkAssign lts = [assign l t | (l,t) <- lts]
projectRec :: Label -> [Assign] -> Term
projectRec l rs =
case lookup l rs of
Just (_,t) -> t
Nothing -> error (render (text "no value for label" <+> ppLabel l))
zipAssign :: [Label] -> [Term] -> [Assign] zipAssign :: [Label] -> [Term] -> [Assign]
zipAssign ls ts = [assign l t | (l,t) <- zip ls ts] zipAssign ls ts = [assign l t | (l,t) <- zip ls ts]
@@ -199,7 +205,7 @@ typeTok = Sort cTok
typeStrs = Sort cStrs typeStrs = Sort cStrs
typeString, typeFloat, typeInt :: Term typeString, typeFloat, typeInt :: Term
typeInts :: Integer -> Term typeInts :: Int -> Term
typePBool :: Term typePBool :: Term
typeError :: Term typeError :: Term
@@ -210,7 +216,7 @@ typeInts i = App (cnPredef cInts) (EInt i)
typePBool = cnPredef cPBool typePBool = cnPredef cPBool
typeError = cnPredef cErrorType typeError = cnPredef cErrorType
isTypeInts :: Term -> Maybe Integer isTypeInts :: Term -> Maybe Int
isTypeInts (App c (EInt i)) | c == cnPredef cInts = Just i isTypeInts (App c (EInt i)) | c == cnPredef cInts = Just i
isTypeInts _ = Nothing isTypeInts _ = Nothing
@@ -299,7 +305,7 @@ freshAsTerm s = Vr (varX (readIntArg s))
string2term :: String -> Term string2term :: String -> Term
string2term = K string2term = K
int2term :: Integer -> Term int2term :: Int -> Term
int2term = EInt int2term = EInt
float2term :: Double -> Term float2term :: Double -> Term

6
src/compiler/GF/Grammar/Predef.hs
View File

@@ -19,6 +19,7 @@ module GF.Grammar.Predef
, cInt , cInt
, cFloat , cFloat
, cString , cString
, cVar
, cInts , cInts
, cPBool , cPBool
, cErrorType , cErrorType
@@ -73,6 +74,9 @@ cFloat = identC (BS.pack "Float")
cString :: Ident cString :: Ident
cString = identC (BS.pack "String") cString = identC (BS.pack "String")
cVar :: Ident
cVar = identC (BS.pack "__gfVar")
cInts :: Ident cInts :: Ident
cInts = identC (BS.pack "Ints") cInts = identC (BS.pack "Ints")
@@ -89,7 +93,7 @@ cUndefinedType :: Ident
cUndefinedType = identC (BS.pack "UndefinedType") cUndefinedType = identC (BS.pack "UndefinedType")
isLiteralCat :: Ident -> Bool isLiteralCat :: Ident -> Bool
isLiteralCat c = elem c [cInt,cString,cFloat] isLiteralCat c = elem c [cInt,cString,cFloat,cVar]
cPTrue :: Ident cPTrue :: Ident
cPTrue = identC (BS.pack "PTrue") cPTrue = identC (BS.pack "PTrue")

4
src/compiler/GF/Grammar/Printer.hs
View File

@@ -171,7 +171,7 @@ ppTerm q d (Q id) = ppQIdent q id
ppTerm q d (QC id) = ppQIdent q id ppTerm q d (QC id) = ppQIdent q id
ppTerm q d (Sort id) = ppIdent id ppTerm q d (Sort id) = ppIdent id
ppTerm q d (K s) = str s ppTerm q d (K s) = str s
ppTerm q d (EInt n) = integer n ppTerm q d (EInt n) = int n
ppTerm q d (EFloat f) = double f ppTerm q d (EFloat f) = double f
ppTerm q d (Meta _) = char '?' ppTerm q d (Meta _) = char '?'
ppTerm q d (Empty) = text "[]" ppTerm q d (Empty) = text "[]"
@@ -204,7 +204,7 @@ ppPatt q d (PMacro id) = char '#' <> ppIdent id
ppPatt q d (PM id) = char '#' <> ppQIdent q id ppPatt q d (PM id) = char '#' <> ppQIdent q id
ppPatt q d PW = char '_' ppPatt q d PW = char '_'
ppPatt q d (PV id) = ppIdent id ppPatt q d (PV id) = ppIdent id
ppPatt q d (PInt n) = integer n ppPatt q d (PInt n) = int n
ppPatt q d (PFloat f) = double f ppPatt q d (PFloat f) = double f
ppPatt q d (PString s) = str s ppPatt q d (PString s) = str s
ppPatt q d (PR xs) = braces (hsep (punctuate semi [ppLabel l <+> equals <+> ppPatt q 0 e | (l,e) <- xs])) ppPatt q d (PR xs) = braces (hsep (punctuate semi [ppLabel l <+> equals <+> ppPatt q 0 e | (l,e) <- xs]))

6
src/compiler/GFC.hs
View File

@@ -9,6 +9,7 @@ import GF.Compile
import GF.Compile.Export import GF.Compile.Export
import GF.Grammar.CF ---- should this be on a deeper level? AR 15/10/2008 import GF.Grammar.CF ---- should this be on a deeper level? AR 15/10/2008
import GF.Grammar (identC)
import GF.Infra.UseIO import GF.Infra.UseIO
import GF.Infra.Option import GF.Infra.Option
@@ -16,6 +17,7 @@ import GF.Data.ErrM
import Data.Maybe import Data.Maybe
import Data.Binary import Data.Binary
import qualified Data.ByteString.Char8 as BS
import System.FilePath import System.FilePath
import System.IO import System.IO
import Control.Exception import Control.Exception
@@ -37,7 +39,7 @@ compileSourceFiles opts fs =
let cnc = justModuleName (last fs) let cnc = justModuleName (last fs)
if flag optStopAfterPhase opts == Compile if flag optStopAfterPhase opts == Compile
then return () then return ()
else do pgf <- link opts cnc gr else do pgf <- link opts (identC (BS.pack cnc)) gr
writePGF opts pgf writePGF opts pgf
writeOutputs opts pgf writeOutputs opts pgf
@@ -49,7 +51,7 @@ compileCFFiles opts fs =
gr <- compileSourceGrammar opts gf gr <- compileSourceGrammar opts gf
if flag optStopAfterPhase opts == Compile if flag optStopAfterPhase opts == Compile
then return () then return ()
else do pgf <- link opts cnc gr else do pgf <- link opts (identC (BS.pack cnc)) gr
writePGF opts pgf writePGF opts pgf
writeOutputs opts pgf writeOutputs opts pgf

173
src/runtime/haskell/PGF/Check.hs
View File

@@ -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)

16
src/runtime/haskell/PGF/Data.hs
View File

@@ -68,22 +68,6 @@ data Alternative =
Alt [String] [String] Alt [String] [String]
deriving (Eq,Ord,Show) 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 -- merge two PGFs; fails is differens absnames; priority to second arg

9
src/runtime/haskell/PGF/Macros.hs
View File

@@ -117,15 +117,6 @@ contextLength ty = case ty of
showPrintName :: PGF -> Language -> CId -> String showPrintName :: PGF -> Language -> CId -> String
showPrintName pgf lang id = lookMap (showCId id) id $ printnames $ lookMap (error "no lang") lang $ concretes pgf 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 -- lookup with default value
lookMap :: (Show i, Ord i) => a -> i -> Map.Map i a -> a lookMap :: (Show i, Ord i) => a -> i -> Map.Map i a -> a
lookMap d c m = Map.findWithDefault d c m lookMap d c m = Map.findWithDefault d c m

25
src/runtime/haskell/PGF/VisualizeTree.hs
View File

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