forked from GitHub/gf-core
Yay!! Direct generation of PMCFG from GF grammar
This commit is contained in:
krasimir
@@ -4,13 +4,14 @@ import PGF
|
||||
import PGF.Data
|
||||
|
||||
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.Infra.UseIO
|
||||
import GF.Infra.Option
|
||||
import GF.Data.ErrM
|
||||
|
||||
import Data.List (nubBy)
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import System.FilePath
|
||||
|
||||
-- import a grammar in an environment where it extends an existing grammar
|
||||
@@ -25,7 +26,7 @@ importGrammar pgf0 opts files =
|
||||
Ok g -> return g
|
||||
Bad s -> error s ----
|
||||
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
|
||||
Ok pgf -> return pgf
|
||||
Bad s -> error s ----
|
||||
|
||||
@@ -35,9 +35,9 @@ import qualified Data.Set as Set
|
||||
import Data.List(nub)
|
||||
import Data.Maybe (isNothing)
|
||||
import Data.Binary
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Text.PrettyPrint
|
||||
|
||||
import PGF.Check
|
||||
import PGF.CId
|
||||
import PGF.Data
|
||||
import PGF.Macros
|
||||
@@ -49,20 +49,15 @@ compileToPGF :: Options -> [FilePath] -> IOE PGF
|
||||
compileToPGF opts fs =
|
||||
do gr <- batchCompile opts 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
|
||||
let isv = (verbAtLeast opts Normal)
|
||||
putPointE Normal opts "linking ... " $ do
|
||||
gc0 <- ioeIO (mkCanon2pgf opts cnc gr)
|
||||
case checkPGF gc0 of
|
||||
Ok (gc,b) -> do case (isv,b) of
|
||||
(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
|
||||
gc <- ioeIO (mkCanon2pgf opts cnc gr)
|
||||
ioeIO $ putStrLn "OK"
|
||||
return $ if flag optOptimizePGF opts then optimizePGF gc else gc
|
||||
|
||||
batchCompile :: Options -> [FilePath] -> IOE SourceGrammar
|
||||
batchCompile opts files = do
|
||||
|
||||
@@ -34,7 +34,7 @@ data AExp =
|
||||
AVr Ident Val
|
||||
| ACn QIdent Val
|
||||
| AType
|
||||
| AInt Integer
|
||||
| AInt Int
|
||||
| AFloat Double
|
||||
| AStr String
|
||||
| AMeta MetaId Val
|
||||
|
||||
@@ -73,17 +73,17 @@ appPredefined t = case t of
|
||||
-- one-place functions
|
||||
Q (mod,f) | mod == cPredef ->
|
||||
case x of
|
||||
(K s) | f == cLength -> retb $ EInt $ toInteger $ length s
|
||||
(K s) | f == cLength -> retb $ EInt $ length s
|
||||
_ -> retb t
|
||||
|
||||
-- two-place functions
|
||||
App (Q (mod,f)) z0 | mod == cPredef -> do
|
||||
(z,_) <- appPredefined z0
|
||||
case (norm z, norm x) of
|
||||
(EInt i, K s) | f == cDrop -> retb $ K (drop (fi i) s)
|
||||
(EInt i, K s) | f == cTake -> retb $ K (take (fi i) s)
|
||||
(EInt i, K s) | f == cTk -> retb $ K (take (max 0 (length s - fi i)) s)
|
||||
(EInt i, K s) | f == cDp -> retb $ K (drop (max 0 (length s - fi i)) s)
|
||||
(EInt i, K s) | f == cDrop -> retb $ K (drop 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 - 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 == 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
|
||||
@@ -119,7 +119,6 @@ appPredefined t = case t of
|
||||
(K x,K y) -> K (x +++ y)
|
||||
_ -> t
|
||||
_ -> t
|
||||
fi = fromInteger
|
||||
|
||||
-- read makes variables into constants
|
||||
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : Krasimir Angelov
|
||||
@@ -13,11 +13,15 @@ module GF.Compile.GeneratePMCFG
|
||||
(convertConcrete) where
|
||||
|
||||
import PGF.CId
|
||||
import PGF.Data
|
||||
import PGF.Macros
|
||||
import PGF.Data hiding (Type)
|
||||
|
||||
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.Operations
|
||||
import GF.Data.Utilities (updateNthM, updateNth, sortNub)
|
||||
|
||||
import System.IO
|
||||
@@ -26,36 +30,52 @@ import qualified Data.Set as Set
|
||||
import qualified Data.List as List
|
||||
import qualified Data.IntMap as IntMap
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Text.PrettyPrint hiding (Str)
|
||||
import Data.Array.IArray
|
||||
import Data.Maybe
|
||||
import Data.Char (isDigit)
|
||||
import Control.Monad
|
||||
import Control.Monad.Identity
|
||||
import Control.Exception
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- main conversion function
|
||||
|
||||
|
||||
--convertConcrete :: Options -> Abstr -> CId -> Concr -> IO Concr
|
||||
convertConcrete opts lang flags printnames abs_defs cnc_defs lincats params lin_defs = do
|
||||
let env0 = emptyGrammarEnv cat_defs params
|
||||
convertConcrete :: Options -> SourceGrammar -> SourceModule -> SourceModule -> IO Concr
|
||||
convertConcrete opts gr am cm = do
|
||||
let env0 = emptyGrammarEnv gr cm
|
||||
when (flag optProf opts) $ do
|
||||
profileGrammar lang env0 pfrules
|
||||
env1 <- expandHOAS opts abs_defs cat_defs lin_defs env0
|
||||
env2 <- foldM (convertRule opts) env1 pfrules
|
||||
return $ getParserInfo flags printnames env2
|
||||
profileGrammar cm env0 pfrules
|
||||
env1 <- expandHOAS opts cm env0
|
||||
env2 <- foldM (convertRule gr opts) env1 pfrules
|
||||
return $ getConcr flags printnames env2
|
||||
where
|
||||
cat_defs = Map.insert cidVar (S []) lincats
|
||||
(m,mo) = cm
|
||||
|
||||
pfrules = [
|
||||
(PFRule id args (0,res) (map findLinType args) (findLinType (0,res)) term) |
|
||||
(id, (ty,_,_)) <- Map.toList abs_defs, let (args,res) = typeSkeleton ty,
|
||||
term <- maybeToList (Map.lookup id cnc_defs)]
|
||||
|
||||
findLinType (_,id) = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs)
|
||||
(PFRule id args (0,res) (map (\(_,_,ty) -> ty) cont) val term) |
|
||||
(id,GF.Grammar.CncFun (Just (cat,cont,val)) (Just (L _ term)) _) <- Map.toList (M.jments mo),
|
||||
let (args,res) = err error typeSkeleton (lookupFunType gr (fst am) id)]
|
||||
|
||||
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 ("Language: " ++ show lang)
|
||||
hPutStrLn stderr ("Language: " ++ showIdent m)
|
||||
hPutStrLn stderr ""
|
||||
hPutStrLn stderr "Categories Count"
|
||||
hPutStrLn stderr "--------------------------------"
|
||||
@@ -69,22 +89,52 @@ profileGrammar lang (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) pfr
|
||||
mapM_ profileRule pfrules
|
||||
hPutStrLn stderr "--------------------------------"
|
||||
where
|
||||
profileCat (cid,(fcat1,fcat2,_,_)) = do
|
||||
hPutStrLn stderr (lformat 23 cid ++ rformat 9 (fcat2-fcat1+1))
|
||||
profileCat (cid,(fcat1,fcat2,_)) = do
|
||||
hPutStrLn stderr (lformat 23 (showIdent cid) ++ rformat 9 (show (fcat2-fcat1+1)))
|
||||
|
||||
profileRule (PFRule fun args res ctypes ctype term) = do
|
||||
let pargs = zipWith protoFCat args ctypes
|
||||
hPutStrLn stderr (lformat 23 fun ++ rformat 9 (product [length xs | PFCat _ _ _ tcs <- pargs, (_,xs) <- tcs]))
|
||||
|
||||
lformat :: Show a => Int -> a -> String
|
||||
lformat n x = s ++ replicate (n-length s) ' '
|
||||
let pargs = map (protoFCat env) args
|
||||
hPutStrLn stderr (lformat 23 (showIdent fun) ++ rformat 9 (show (product (map (catFactor env) args))))
|
||||
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
|
||||
rformat n x = replicate (n-length s) ' ' ++ s
|
||||
where
|
||||
s = show x
|
||||
lformat :: Int -> String -> String
|
||||
lformat n s = s ++ replicate (n-length s) ' '
|
||||
|
||||
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 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
|
||||
ys = foldr (zipWith Set.insert) (repeat Set.empty) xs
|
||||
|
||||
convertRule :: Options -> GrammarEnv -> ProtoFRule -> IO GrammarEnv
|
||||
convertRule opts grammarEnv (PFRule fun args res ctypes ctype term) = do
|
||||
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
|
||||
unfactor :: Term -> CnvMonad Term
|
||||
unfactor t = CM (\gr c -> c (unfac gr t))
|
||||
where
|
||||
addRule lins (newCat', newArgs') env0 =
|
||||
let [newCat] = getFCats env0 newCat'
|
||||
(env1, newArgs) = List.mapAccumL (\env -> addFCoercion env . getFCats env) env0 newArgs'
|
||||
|
||||
(env2,funid) = addCncFun env1 (CncFun fun (mkArray lins))
|
||||
|
||||
in addProduction env2 newCat (PApply funid newArgs)
|
||||
unfac gr t =
|
||||
case t of
|
||||
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
|
||||
where
|
||||
restore x u t = case t of
|
||||
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
|
||||
return a = BM (\c s -> c a s)
|
||||
BM m >>= k = BM (\c s -> m (\a s -> unBM (k a) c s) s)
|
||||
where unBM (BM m) = m
|
||||
newtype CnvMonad a = CM {unCM :: SourceGrammar
|
||||
-> forall b . (a -> ([ProtoFCat],[Symbol]) -> Branch b)
|
||||
-> ([ProtoFCat],[Symbol])
|
||||
-> Branch b}
|
||||
|
||||
instance MonadState ([ProtoFCat],[Symbol]) BranchM where
|
||||
get = BM (\c s -> c s s)
|
||||
put s = BM (\c _ -> c () s)
|
||||
instance Monad CnvMonad where
|
||||
return a = CM (\gr c s -> c a s)
|
||||
CM m >>= k = CM (\gr c s -> m gr (\a s -> unCM (k a) gr c s) s)
|
||||
|
||||
instance Functor BranchM where
|
||||
fmap f (BM m) = BM (\c s -> m (c . f) s)
|
||||
instance MonadState ([ProtoFCat],[Symbol]) CnvMonad where
|
||||
get = CM (\gr c s -> c s s)
|
||||
put s = CM (\gr c _ -> c () s)
|
||||
|
||||
runBranchM :: BranchM (Value a) -> ([ProtoFCat],[Symbol]) -> Branch a
|
||||
runBranchM (BM m) s = m (\v s -> Return v) s
|
||||
instance Functor CnvMonad where
|
||||
fmap f (CM m) = CM (\gr c s -> m gr (c . f) s)
|
||||
|
||||
variants :: [a] -> BranchM a
|
||||
variants xs = BM (\c s -> Variant [c x s | x <- xs])
|
||||
runCnvMonad :: SourceGrammar -> CnvMonad a -> ([ProtoFCat],[Symbol]) -> Branch a
|
||||
runCnvMonad gr (CM m) s = m gr (\v s -> Return v) s
|
||||
|
||||
choices :: Int -> FPath -> BranchM LIndex
|
||||
choices nr path = BM (\c s -> let (args,_) = s
|
||||
PFCat _ _ _ tcs = args !! nr
|
||||
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)
|
||||
-- | backtracking for all variants
|
||||
variants :: [a] -> CnvMonad a
|
||||
variants xs = CM (\gr c s -> Variant [c x s | x <- xs])
|
||||
|
||||
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"
|
||||
addConstraint path0 index0 (c@(path,indices) : tcs)
|
||||
| path0 == path = ((path,[index0]) : tcs)
|
||||
| otherwise = c : addConstraint path0 index0 tcs
|
||||
updateEnv path value gr c (args,seq) =
|
||||
case updateNthM (restrictProtoFCat path value) nr args of
|
||||
Just args -> c value (args,seq)
|
||||
Nothing -> error "conflict in updateEnv"
|
||||
|
||||
mkRecord :: [BranchM (Value a)] -> BranchM (Value a)
|
||||
mkRecord xs = BM (\c -> foldl (\c (BM m) bs s -> c (m (\v s -> Return v) s : bs) s) (c . Rec) xs [])
|
||||
-- | the argument should be a parameter type and then
|
||||
-- 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
|
||||
|
||||
type CnvMonad a = BranchM a
|
||||
type Value a = Schema Branch a Term
|
||||
|
||||
type FPath = [LIndex]
|
||||
data ProtoFCat = PFCat Int CId [FPath] [(FPath,[LIndex])]
|
||||
type Env = (ProtoFCat, [ProtoFCat])
|
||||
data ProtoFRule = PFRule CId {- function -}
|
||||
[(Int,CId)] {- argument types: context size and category -}
|
||||
(Int,CId) {- result type : context size (always 0) and category -}
|
||||
[Term] {- argument lin-types representation -}
|
||||
Term {- result lin-type representation -}
|
||||
Term {- body -}
|
||||
type TermMap = Map.Map CId Term
|
||||
convertTerm :: Path -> Type -> Term -> CnvMonad (Value [Symbol])
|
||||
convertTerm sel ctype (Vr x) = convertArg ctype (getVarIndex x) (reversePath sel)
|
||||
convertTerm sel ctype (Abs _ _ t) = convertTerm sel ctype t -- there are only top-level abstractions and we ignore them !!!
|
||||
convertTerm sel ctype (R record) = convertRec sel ctype record
|
||||
convertTerm sel ctype (P term l) = convertTerm (CProj l sel) ctype term
|
||||
convertTerm sel ctype (V pt ts) = convertTbl sel ctype pt ts
|
||||
convertTerm sel ctype (S term p) = do v <- evalTerm CNil p
|
||||
convertTerm (CSel v sel) ctype term
|
||||
convertTerm sel ctype (FV vars) = do term <- variants vars
|
||||
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)))
|
||||
|
||||
|
||||
protoFCat :: (Int,CId) -> Term -> ProtoFCat
|
||||
protoFCat (n,cat) ctype =
|
||||
let (rcs,tcs) = loop [] [] [] ctype'
|
||||
in PFCat n cat rcs tcs
|
||||
convertArg :: Term -> Int -> Path -> CnvMonad (Value [Symbol])
|
||||
convertArg (RecType rs) nr path =
|
||||
mkRecord (map (\(lbl,ctype) -> (lbl,convertArg ctype nr (CProj lbl path))) rs)
|
||||
convertArg (Table pt vt) nr path = do
|
||||
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
|
||||
ctype' -- extend the high-order linearization type
|
||||
| n > 0 = case ctype of
|
||||
R xs -> R (xs ++ replicate n (S []))
|
||||
_ -> error $ "Not a record: " ++ show ctype
|
||||
| otherwise = ctype
|
||||
|
||||
loop path rcs tcs (R record) = List.foldr (\(index,term) (rcs,tcs) -> loop (index:path) rcs tcs term) (rcs,tcs) (zip [0..] record)
|
||||
loop path rcs tcs (C i) = ( rcs,(path,[0..i]):tcs)
|
||||
loop path rcs tcs (S _) = (path:rcs, tcs)
|
||||
index (CProj lbl path) (CRec rs) = case lookup lbl rs of
|
||||
Just (Identity t) -> index path t
|
||||
index (CSel trm path) (CTbl _ rs) = case lookup trm rs of
|
||||
Just (Identity t) -> index path t
|
||||
index CNil (CStr idx) = idx
|
||||
convertArg ty nr path = do
|
||||
value <- choices nr (reversePath path)
|
||||
return (CPar value)
|
||||
|
||||
data Branch a
|
||||
= Case Int FPath [Branch a]
|
||||
| Variant [Branch a]
|
||||
| Return (Value a)
|
||||
convertRec CNil (RecType rs) record =
|
||||
mkRecord (map (\(lbl,ctype) -> (lbl,convertTerm CNil ctype (projectRec lbl record))) rs)
|
||||
convertRec (CProj lbl path) ctype record =
|
||||
convertTerm path ctype (projectRec lbl record)
|
||||
convertRec _ ctype _ = error ("convertRec: "++show ctype)
|
||||
|
||||
data Value a
|
||||
= Rec [Branch a]
|
||||
| Str a
|
||||
| Con LIndex
|
||||
convertTbl CNil (Table _ vt) pt ts = do
|
||||
vs <- getAllParamValues pt
|
||||
mkTable pt (zipWith (\v t -> (v,convertTerm CNil vt t)) vs ts)
|
||||
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]
|
||||
go' (Case nr path_ bs) path ss = do (index,b) <- member (zip [0..] bs)
|
||||
restrictArg nr path_ index
|
||||
go' b path ss
|
||||
go' (Variant bs) path ss = do b <- member bs
|
||||
go' b path ss
|
||||
go' (Return v) path ss = go v path ss
|
||||
goB :: Branch (Value SeqId) -> Path -> [SeqId] -> BacktrackM Env [SeqId]
|
||||
goB (Case nr path bs) rpath ss = do (value,b) <- member bs
|
||||
restrictArg nr path value
|
||||
goB b rpath ss
|
||||
goB (Variant bs) rpath ss = do b <- member bs
|
||||
goB b rpath ss
|
||||
goB (Return v) rpath ss = goV v rpath ss
|
||||
|
||||
go :: Value SeqId -> FPath -> [SeqId] -> BacktrackM Env [SeqId]
|
||||
go (Rec xs) path ss = foldM (\ss (lbl,b) -> go' b (lbl:path) ss) ss (reverse (zip [0..] xs))
|
||||
go (Str seqid) path ss = return (seqid : ss)
|
||||
go (Con i) path ss = restrictHead path i >> return ss
|
||||
goV :: Value SeqId -> Path -> [SeqId] -> BacktrackM Env [SeqId]
|
||||
goV (CRec xs) rpath ss = foldM (\ss (lbl,b) -> goB b (CProj lbl rpath) ss) ss (reverse xs)
|
||||
goV (CTbl _ xs) rpath ss = foldM (\ss (trm,b) -> goB b (CSel trm rpath) ss) ss (reverse xs)
|
||||
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)
|
||||
addSequences' env (Case nr path bs) = let (env1,bs1) = List.mapAccumL addSequences' env bs
|
||||
addSequencesB :: GrammarEnv -> Branch (Value [Symbol]) -> (GrammarEnv, Branch (Value SeqId))
|
||||
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)
|
||||
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)
|
||||
addSequences' env (Return v) = let (env1,v1) = addSequences env v
|
||||
addSequencesB env (Return v) = let (env1,v1) = addSequencesV env v
|
||||
in (env1,Return v1)
|
||||
|
||||
addSequences :: GrammarEnv -> Value [Symbol] -> (GrammarEnv, Value SeqId)
|
||||
addSequences env (Rec vs) = let (env1,vs1) = List.mapAccumL addSequences' env vs
|
||||
in (env1,Rec vs1)
|
||||
addSequences env (Str lin) = let (env1,seqid) = addFSeq env (optimizeLin lin)
|
||||
in (env1,Str seqid)
|
||||
addSequences env (Con i) = (env,Con i)
|
||||
addSequencesV :: GrammarEnv -> Value [Symbol] -> (GrammarEnv, Value SeqId)
|
||||
addSequencesV env (CRec vs) = let (env1,vs1) = List.mapAccumL (\env (lbl,b) -> let (env',b') = addSequencesB env b
|
||||
in (env',(lbl,b'))) env vs
|
||||
in (env1,CRec vs1)
|
||||
addSequencesV env (CTbl pt vs)=let (env1,vs1) = List.mapAccumL (\env (trm,b) -> let (env',b') = addSequencesB env b
|
||||
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 [] = []
|
||||
@@ -251,98 +405,76 @@ optimizeLin lin@(SymKS _ : _) =
|
||||
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
|
||||
|
||||
evalTerm :: FPath -> Term -> CnvMonad LIndex
|
||||
evalTerm path (V nr) = choices nr (reverse path)
|
||||
evalTerm path (C nr) = return nr
|
||||
evalTerm path (R record) = case path of
|
||||
(index:path) -> evalTerm path (record !! index)
|
||||
evalTerm path (P term sel) = do index <- evalTerm [] sel
|
||||
evalTerm (index:path) term
|
||||
evalTerm :: Path -> Term -> CnvMonad Term
|
||||
evalTerm CNil (QC f) = return (QC f)
|
||||
evalTerm CNil (App x y) = do x <- evalTerm CNil x
|
||||
y <- evalTerm CNil y
|
||||
return (App x y)
|
||||
evalTerm path (Vr x) = choices (getVarIndex x) path
|
||||
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 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
|
||||
|
||||
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 FunSet = Map.Map CncFun FunId
|
||||
type CoerceSet= Map.Map [FId] FId
|
||||
|
||||
emptyGrammarEnv lincats params =
|
||||
emptyGrammarEnv gr (m,mo) =
|
||||
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
|
||||
where
|
||||
computeCatRange index cat ctype
|
||||
| cat == cidString = (index, (fcatString,fcatString,[],listArray (0,0) ["s"]))
|
||||
| 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)))
|
||||
computeCatRange index cat ctype =
|
||||
(index+size,(index,index+size-1,PFCat 0 cat schema))
|
||||
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
|
||||
getMultipliers m ms (S _) = (m,ms)
|
||||
getMultipliers m ms (C max_index) = (m*(max_index+1),m : ms)
|
||||
compute st (RecType rs) = let (st',rs') = List.mapAccumL (\st (lbl,t) -> let (st',t') = compute st t
|
||||
in (st',(lbl,Identity t'))) st rs
|
||||
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]
|
||||
getLabels ls (S [FV ps,t]) = concat [getLabels (l:ls) t | K (KS l) <- ps]
|
||||
getLabels ls (S []) = [unwords (reverse ls)]
|
||||
getLabels ls (FV _) = []
|
||||
getLabels _ t = error (show t)
|
||||
lincats =
|
||||
Map.insert cVar (Sort cStr) $
|
||||
Map.fromAscList
|
||||
[(c, ty) | (c,GF.Grammar.CncCat (Just (L _ ty)) _ _) <- Map.toList (M.jments mo)]
|
||||
|
||||
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)
|
||||
where
|
||||
hoTypes :: [(Int,CId)]
|
||||
@@ -379,10 +511,10 @@ expandHOAS opts abs_defs lincats lindefs env =
|
||||
add_varFun env cat =
|
||||
case Map.lookup cat lindefs of
|
||||
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
|
||||
arg =
|
||||
case Map.lookup cidVar lincats of
|
||||
case Map.lookup cVar lincats of
|
||||
Nothing -> error $ "No lincat for " ++ showCId cat
|
||||
Just ctype -> ctype
|
||||
|
||||
@@ -390,7 +522,7 @@ expandHOAS opts abs_defs lincats lindefs env =
|
||||
case Map.lookup cat lincats of
|
||||
Nothing -> error $ "No lincat for " ++ showCId cat
|
||||
Just ctype -> ctype
|
||||
|
||||
-}
|
||||
addProduction :: GrammarEnv -> FId -> Production -> GrammarEnv
|
||||
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)
|
||||
@@ -420,57 +552,87 @@ addFCoercion env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) sub_fc
|
||||
Nothing -> let !fcat = last_id+1
|
||||
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
|
||||
getParserInfo flags printnames (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) =
|
||||
getConcr :: Map.Map CId Literal -> Map.Map CId String -> GrammarEnv -> Concr
|
||||
getConcr flags printnames (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) =
|
||||
Concr { cflags = flags
|
||||
, printnames = printnames
|
||||
, cncfuns = mkArray funSet
|
||||
, sequences = mkArray seqSet
|
||||
, cncfuns = mkSetArray funSet
|
||||
, sequences = mkSetArray seqSet
|
||||
, productions = IntMap.union prodSet coercions
|
||||
, pproductions = IntMap.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
|
||||
}
|
||||
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]
|
||||
|
||||
getFCats :: GrammarEnv -> ProtoFCat -> [FId]
|
||||
getFCats (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (PFCat n cat rcs tcs) =
|
||||
case IntMap.lookup n catSet >>= Map.lookup cat of
|
||||
Just (start,end,ms,_) -> reverse (solutions (variants ms tcs start) ())
|
||||
where
|
||||
variants _ [] fcat = return fcat
|
||||
variants (m:ms) ((_,indices) : tcs) fcat = do index <- member indices
|
||||
variants ms tcs ((m*index) + fcat)
|
||||
getStrPaths :: Schema Identity s c -> [Path]
|
||||
getStrPaths = collect CNil []
|
||||
where
|
||||
collect path paths (CRec rs) = foldr (\(lbl,Identity t) paths -> collect (CProj lbl path) paths t) paths rs
|
||||
collect path paths (CTbl _ cs) = foldr (\(trm,Identity t) paths -> collect (CSel trm path) paths t) paths cs
|
||||
collect path paths (CStr _) = reversePath path : paths
|
||||
collect path paths (CPar _) = paths
|
||||
|
||||
|
||||
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
|
||||
|
||||
restrictArg :: LIndex -> FPath -> LIndex -> BacktrackM Env ()
|
||||
restrictArg :: LIndex -> Path -> Term -> BacktrackM Env ()
|
||||
restrictArg nr path index = do
|
||||
(head, args) <- get
|
||||
args' <- updateNthM (restrictProtoFCat path index) nr args
|
||||
put (head, args')
|
||||
args <- updateNthM (restrictProtoFCat path index) nr args
|
||||
put (head, args)
|
||||
|
||||
restrictHead :: FPath -> LIndex -> BacktrackM Env ()
|
||||
restrictHead path term
|
||||
= do (head, args) <- get
|
||||
head' <- restrictProtoFCat path term head
|
||||
put (head', args)
|
||||
restrictHead :: Path -> Term -> BacktrackM Env ()
|
||||
restrictHead path term = do
|
||||
(head, args) <- get
|
||||
head <- restrictProtoFCat path term head
|
||||
put (head, args)
|
||||
|
||||
restrictProtoFCat :: FPath -> LIndex -> ProtoFCat -> BacktrackM Env ProtoFCat
|
||||
restrictProtoFCat path0 index0 (PFCat n cat rcs tcs) = do
|
||||
tcs <- addConstraint tcs
|
||||
return (PFCat n cat rcs tcs)
|
||||
restrictProtoFCat :: (Functor m, MonadPlus m) => Path -> Term -> ProtoFCat -> m ProtoFCat
|
||||
restrictProtoFCat path v (PFCat n cat schema) = do
|
||||
schema <- addConstraint path v schema
|
||||
return (PFCat n cat schema)
|
||||
where
|
||||
addConstraint [] = error "restrictProtoFCat: unknown path"
|
||||
addConstraint (c@(path,indices) : tcs)
|
||||
| path0 == path = guard (index0 `elem` indices) >>
|
||||
return ((path,[index0]) : tcs)
|
||||
| otherwise = liftM (c:) (addConstraint tcs)
|
||||
addConstraint (CProj lbl path) v (CRec rs) = fmap CRec $ update lbl (addConstraint path v) rs
|
||||
addConstraint (CSel trm path) v (CTbl pt cs) = fmap (CTbl pt) $ update trm (addConstraint path v) cs
|
||||
addConstraint CNil v (CPar (m,vs)) = case lookup v vs of
|
||||
Just index -> return (CPar (m,[(v,index)]))
|
||||
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
|
||||
|
||||
@@ -6,7 +6,6 @@ import GF.Compile.GeneratePMCFG
|
||||
|
||||
import PGF.CId
|
||||
import PGF.Optimize(updateProductionIndices)
|
||||
import PGF.Check(checkLin)
|
||||
import qualified PGF.Macros as CM
|
||||
import qualified PGF.Data as C
|
||||
import qualified PGF.Data as D
|
||||
@@ -38,76 +37,39 @@ traceD s t = t
|
||||
|
||||
|
||||
-- the main function: generate PGF from GF.
|
||||
mkCanon2pgf :: Options -> String -> SourceGrammar -> IO D.PGF
|
||||
mkCanon2pgf opts cnc gr = (canon2pgf opts pars . reorder abs . canon2canon opts abs) gr
|
||||
mkCanon2pgf :: Options -> Ident -> SourceGrammar -> IO D.PGF
|
||||
mkCanon2pgf opts cnc gr = (canon2pgf opts gr . reorder abs) gr
|
||||
where
|
||||
abs = err (const c) id $ M.abstractOfConcrete gr c where c = identC (BS.pack cnc)
|
||||
pars = mkParamLincat gr
|
||||
abs = err (const cnc) id $ M.abstractOfConcrete gr cnc
|
||||
|
||||
-- Generate PGF from GFCM.
|
||||
-- this assumes a grammar translated by canon2canon
|
||||
-- Generate PGF from grammar.
|
||||
|
||||
canon2pgf :: Options -> (Ident -> Ident -> C.Term) -> SourceGrammar -> IO D.PGF
|
||||
canon2pgf opts pars cgr@(M.MGrammar ((a,abm):cms)) = do
|
||||
canon2pgf :: Options -> SourceGrammar -> SourceGrammar -> IO D.PGF
|
||||
canon2pgf opts gr cgr@(M.MGrammar (am:cms)) = do
|
||||
if dump opts DumpCanon
|
||||
then putStrLn (render (vcat (map (ppModule Qualified) (M.modules cgr))))
|
||||
else return ()
|
||||
cncs <- sequence [mkConcr lang (i2i lang) mo | (lang,mo) <- cms]
|
||||
return $ updateProductionIndices (D.PGF gflags an abs (Map.fromList cncs))
|
||||
where
|
||||
-- abstract
|
||||
an = (i2i a)
|
||||
abs = D.Abstr aflags funs cats
|
||||
gflags = Map.empty
|
||||
aflags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF (M.flags abm)]
|
||||
(an,abs) <- mkAbstr am
|
||||
cncs <- mapM (mkConcr am) cms
|
||||
return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs))
|
||||
where
|
||||
mkAbstr (a,abm) = return (i2i a, D.Abstr flags funs cats)
|
||||
where
|
||||
flags = 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]
|
||||
mkDef Nothing = Nothing
|
||||
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]
|
||||
|
||||
mkArrity (Just a) = a
|
||||
mkArrity Nothing = 0
|
||||
|
||||
-- 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
|
||||
mkConcr am cm@(lang,mo) = do
|
||||
cnc <- convertConcrete opts gr am cm
|
||||
return (i2i lang, cnc)
|
||||
|
||||
i2i :: Ident -> CId
|
||||
i2i = CId . ident2bs
|
||||
@@ -153,465 +115,40 @@ mkPatt scope p =
|
||||
in (scope',C.PImplArg p')
|
||||
A.PTilde t -> ( scope,C.PTilde (mkExp scope t))
|
||||
|
||||
|
||||
mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo])
|
||||
mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
|
||||
in if x == identW
|
||||
then ( scope,(b2b bt,i2i x,ty'))
|
||||
else (x:scope,(b2b bt,i2i x,ty'))) scope hyps
|
||||
|
||||
mkTerm :: Term -> C.Term
|
||||
mkTerm tr = case tr of
|
||||
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]
|
||||
mkDef (Just eqs) = Just [C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
|
||||
mkDef Nothing = Nothing
|
||||
|
||||
-- encoding PGF-internal lincats as terms
|
||||
mkCType :: Type -> C.Term
|
||||
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
|
||||
mkArrity (Just a) = a
|
||||
mkArrity Nothing = 0
|
||||
|
||||
-- return just one module per language
|
||||
|
||||
reorder :: Ident -> SourceGrammar -> SourceGrammar
|
||||
reorder abs cg = M.MGrammar $
|
||||
(abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs):
|
||||
[(c, M.ModInfo (M.MTConcrete abs) M.MSComplete fs [] Nothing [] [] (sorted2tree js))
|
||||
| (c,(fs,js)) <- cncs]
|
||||
where
|
||||
mos = M.modules cg
|
||||
adefs = sorted2tree $ sortIds $
|
||||
predefADefs ++ Look.allOrigInfos cg abs
|
||||
predefADefs =
|
||||
[(c, AbsCat (Just (L (0,0) []))) | c <- [cFloat,cInt,cString]]
|
||||
aflags =
|
||||
concatOptions [M.flags mo | (_,mo) <- M.modules cg, M.isModAbs mo]
|
||||
reorder abs cg =
|
||||
M.MGrammar $
|
||||
(abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs):
|
||||
[(cnc, M.ModInfo (M.MTConcrete abs) M.MSComplete cflags [] Nothing [] [] cdefs)
|
||||
| cnc <- M.allConcretes cg abs, let (cflags,cdefs) = concr cnc]
|
||||
where
|
||||
aflags =
|
||||
concatOptions [M.flags mo | (_,mo) <- M.modules cg, M.isModAbs mo]
|
||||
|
||||
cncs = sortIds [(lang, concr lang) | lang <- M.allConcretes cg abs]
|
||||
concr la = (flags,
|
||||
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
|
||||
adefs =
|
||||
Map.fromList (predefADefs ++ Look.allOrigInfos cg abs)
|
||||
where
|
||||
typsFromField (mty, t) = case mty of
|
||||
Just x -> updateSTM (x:) >> typsFromTrm t
|
||||
_ -> 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
|
||||
predefADefs =
|
||||
[(c, AbsCat (Just (L (0,0) []))) | c <- [cFloat,cInt,cString]]
|
||||
|
||||
mods = traceD (render (hsep (map (ppIdent . fst) ms))) ms where ms = M.modules cgr
|
||||
|
||||
jments =
|
||||
[(m,j) | (m,mo) <- mods, j <- tree2list $ M.jments mo]
|
||||
typs =
|
||||
Map.fromList [(ci,Map.fromList (zip vs [0..])) | (ci,vs) <- params]
|
||||
untyps =
|
||||
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
|
||||
concr la = (flags, Map.fromList (predefCDefs ++ jments))
|
||||
where
|
||||
flags = concatOptions [M.flags mo | (i,mo) <- M.modules cg, M.isModCnc mo,
|
||||
Just r <- [lookup i (M.allExtendSpecs cg la)]]
|
||||
jments = Look.allOrigInfos cg la
|
||||
predefCDefs =
|
||||
[(c, CncCat (Just (L (0,0) GM.defLinType)) Nothing Nothing) | c <- [cInt,cFloat,cString]]
|
||||
|
||||
@@ -127,11 +127,6 @@ instance PLPrint Literal where
|
||||
plp (LInt n) = plp (show n)
|
||||
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
|
||||
|
||||
|
||||
@@ -119,7 +119,7 @@ data Term =
|
||||
| Cn Ident -- ^ constant
|
||||
| Con Ident -- ^ constructor
|
||||
| Sort Ident -- ^ basic type
|
||||
| EInt Integer -- ^ integer literal
|
||||
| EInt Int -- ^ integer literal
|
||||
| EFloat Double -- ^ floating point literal
|
||||
| K String -- ^ string literal or token: @\"foo\"@
|
||||
| Empty -- ^ the empty string @[]@
|
||||
@@ -171,7 +171,7 @@ data Patt =
|
||||
| PW -- ^ wild card pattern: @_@
|
||||
| PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@ -- only concrete
|
||||
| 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
|
||||
| PT Type Patt -- ^ type-annotated pattern
|
||||
|
||||
|
||||
@@ -112,7 +112,7 @@ data Token
|
||||
| T_where
|
||||
| T_with
|
||||
| T_String String -- string literals
|
||||
| T_Integer Integer -- integer literals
|
||||
| T_Integer Int -- integer literals
|
||||
| T_Double Double -- double precision float literals
|
||||
| T_LString String
|
||||
| T_Ident Ident
|
||||
|
||||
@@ -166,6 +166,12 @@ unzipR r = (ls, map snd ts) where (ls,ts) = unzip r
|
||||
mkAssign :: [(Label,Term)] -> [Assign]
|
||||
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 ls ts = [assign l t | (l,t) <- zip ls ts]
|
||||
|
||||
@@ -199,7 +205,7 @@ typeTok = Sort cTok
|
||||
typeStrs = Sort cStrs
|
||||
|
||||
typeString, typeFloat, typeInt :: Term
|
||||
typeInts :: Integer -> Term
|
||||
typeInts :: Int -> Term
|
||||
typePBool :: Term
|
||||
typeError :: Term
|
||||
|
||||
@@ -210,7 +216,7 @@ typeInts i = App (cnPredef cInts) (EInt i)
|
||||
typePBool = cnPredef cPBool
|
||||
typeError = cnPredef cErrorType
|
||||
|
||||
isTypeInts :: Term -> Maybe Integer
|
||||
isTypeInts :: Term -> Maybe Int
|
||||
isTypeInts (App c (EInt i)) | c == cnPredef cInts = Just i
|
||||
isTypeInts _ = Nothing
|
||||
|
||||
@@ -299,7 +305,7 @@ freshAsTerm s = Vr (varX (readIntArg s))
|
||||
string2term :: String -> Term
|
||||
string2term = K
|
||||
|
||||
int2term :: Integer -> Term
|
||||
int2term :: Int -> Term
|
||||
int2term = EInt
|
||||
|
||||
float2term :: Double -> Term
|
||||
|
||||
@@ -19,6 +19,7 @@ module GF.Grammar.Predef
|
||||
, cInt
|
||||
, cFloat
|
||||
, cString
|
||||
, cVar
|
||||
, cInts
|
||||
, cPBool
|
||||
, cErrorType
|
||||
@@ -73,6 +74,9 @@ cFloat = identC (BS.pack "Float")
|
||||
cString :: Ident
|
||||
cString = identC (BS.pack "String")
|
||||
|
||||
cVar :: Ident
|
||||
cVar = identC (BS.pack "__gfVar")
|
||||
|
||||
cInts :: Ident
|
||||
cInts = identC (BS.pack "Ints")
|
||||
|
||||
@@ -89,7 +93,7 @@ cUndefinedType :: Ident
|
||||
cUndefinedType = identC (BS.pack "UndefinedType")
|
||||
|
||||
isLiteralCat :: Ident -> Bool
|
||||
isLiteralCat c = elem c [cInt,cString,cFloat]
|
||||
isLiteralCat c = elem c [cInt,cString,cFloat,cVar]
|
||||
|
||||
cPTrue :: Ident
|
||||
cPTrue = identC (BS.pack "PTrue")
|
||||
|
||||
@@ -171,7 +171,7 @@ ppTerm q d (Q id) = ppQIdent q id
|
||||
ppTerm q d (QC id) = ppQIdent q id
|
||||
ppTerm q d (Sort id) = ppIdent id
|
||||
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 (Meta _) = char '?'
|
||||
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 PW = char '_'
|
||||
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 (PString s) = str s
|
||||
ppPatt q d (PR xs) = braces (hsep (punctuate semi [ppLabel l <+> equals <+> ppPatt q 0 e | (l,e) <- xs]))
|
||||
|
||||
@@ -9,6 +9,7 @@ import GF.Compile
|
||||
import GF.Compile.Export
|
||||
|
||||
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.Option
|
||||
@@ -16,6 +17,7 @@ import GF.Data.ErrM
|
||||
|
||||
import Data.Maybe
|
||||
import Data.Binary
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import System.FilePath
|
||||
import System.IO
|
||||
import Control.Exception
|
||||
@@ -37,7 +39,7 @@ compileSourceFiles opts fs =
|
||||
let cnc = justModuleName (last fs)
|
||||
if flag optStopAfterPhase opts == Compile
|
||||
then return ()
|
||||
else do pgf <- link opts cnc gr
|
||||
else do pgf <- link opts (identC (BS.pack cnc)) gr
|
||||
writePGF opts pgf
|
||||
writeOutputs opts pgf
|
||||
|
||||
@@ -49,7 +51,7 @@ compileCFFiles opts fs =
|
||||
gr <- compileSourceGrammar opts gf
|
||||
if flag optStopAfterPhase opts == Compile
|
||||
then return ()
|
||||
else do pgf <- link opts cnc gr
|
||||
else do pgf <- link opts (identC (BS.pack cnc)) gr
|
||||
writePGF opts pgf
|
||||
writeOutputs opts pgf
|
||||
|
||||
|
||||
@@ -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)
|
||||
@@ -68,22 +68,6 @@ data Alternative =
|
||||
Alt [String] [String]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Term =
|
||||
R [Term]
|
||||
| P Term Term
|
||||
| S [Term]
|
||||
| K Tokn
|
||||
| V Int
|
||||
| C Int
|
||||
| FV [Term]
|
||||
| W String Term
|
||||
| TM String
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Tokn =
|
||||
KS String
|
||||
| KP [String] [Alternative]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
-- merge two PGFs; fails is differens absnames; priority to second arg
|
||||
|
||||
|
||||
@@ -117,15 +117,6 @@ contextLength ty = case ty of
|
||||
showPrintName :: PGF -> Language -> CId -> String
|
||||
showPrintName pgf lang id = lookMap (showCId id) id $ printnames $ lookMap (error "no lang") lang $ concretes pgf
|
||||
|
||||
term0 :: CId -> Term
|
||||
term0 = TM . showCId
|
||||
|
||||
tm0 :: Term
|
||||
tm0 = TM "?"
|
||||
|
||||
kks :: String -> Term
|
||||
kks = K . KS
|
||||
|
||||
-- lookup with default value
|
||||
lookMap :: (Show i, Ord i) => a -> i -> Map.Map i a -> a
|
||||
lookMap d c m = Map.findWithDefault d c m
|
||||
|
||||
@@ -28,7 +28,8 @@ import PGF.CId (CId,showCId,ppCId,pCId,mkCId)
|
||||
import PGF.Data
|
||||
import PGF.Expr (showExpr, Tree)
|
||||
import PGF.Linearize
|
||||
import PGF.Macros (lookValCat, lookMap, _B, _V, BracketedString(..), flattenBracketedString)
|
||||
import PGF.Macros (lookValCat, lookMap, _B, _V,
|
||||
BracketedString(..), BracketedTokn(..), flattenBracketedString)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.IntMap as IntMap
|
||||
@@ -274,7 +275,7 @@ tag i
|
||||
--
|
||||
-- Uuuuugly!!! I hope that this code will be removed one day.
|
||||
|
||||
type LinTable = Array LIndex [Tokn]
|
||||
type LinTable = Array LIndex [BracketedTokn]
|
||||
|
||||
|
||||
linTree :: PGF -> Language -> (Maybe CId -> [Int] -> LinTable -> LinTable) -> Expr -> [LinTable]
|
||||
@@ -299,7 +300,7 @@ linTree pgf lang mark e = lin0 [] [] [] Nothing e
|
||||
lin path xs mb_fid (ETyped e _) es = lin path xs mb_fid e es
|
||||
lin path xs mb_fid (EImplArg e) es = lin path xs mb_fid e es
|
||||
|
||||
ss s = listArray (0,0) [[KS s]]
|
||||
ss s = listArray (0,0) [[LeafKS [s]]]
|
||||
|
||||
apply path xs mb_fid f es =
|
||||
case Map.lookup f lp of
|
||||
@@ -332,15 +333,15 @@ linTree pgf lang mark e = lin0 [] [] [] Nothing e
|
||||
|
||||
compute (SymCat d r) = (args !! d) ! r
|
||||
compute (SymLit d r) = (args !! d) ! r
|
||||
compute (SymKS ts) = map KS ts
|
||||
compute (SymKP ts alts) = [KP ts alts]
|
||||
compute (SymKS ts) = [LeafKS ts]
|
||||
compute (SymKP ts alts) = [LeafKP ts alts]
|
||||
|
||||
untokn :: [Tokn] -> [String]
|
||||
untokn :: [BracketedTokn] -> [String]
|
||||
untokn ts = case ts of
|
||||
KP d _ : [] -> d
|
||||
KP d vs : ws -> let ss@(s:_) = untokn ws in sel d vs s ++ ss
|
||||
KS s : ws -> s : untokn ws
|
||||
[] -> []
|
||||
LeafKP d _ : [] -> d
|
||||
LeafKP d vs : ws -> let ss@(s:_) = untokn ws in sel d vs s ++ ss
|
||||
LeafKS s : ws -> s ++ untokn ws
|
||||
[] -> []
|
||||
where
|
||||
sel d vs w = case [v | Alt v cs <- vs, any (\c -> isPrefixOf c w) cs] of
|
||||
v:_ -> v
|
||||
@@ -353,8 +354,8 @@ markLinearizes pgf lang = map (unwords . untokn . (! 0)) . linTree pgf lang mark
|
||||
where
|
||||
mark mb_f path lint = amap (bracket mb_f path) lint
|
||||
|
||||
bracket Nothing path ts = [KS ("("++show (reverse path))] ++ ts ++ [KS ")"]
|
||||
bracket (Just f) path ts = [KS ("(("++showCId f++","++show (reverse path)++")")] ++ ts ++ [KS ")"]
|
||||
bracket Nothing path ts = [LeafKS ["("++show (reverse path)]] ++ ts ++ [LeafKS [")"]]
|
||||
bracket (Just f) path ts = [LeafKS ["(("++showCId f++","++show (reverse path)++")"]] ++ ts ++ [LeafKS [")"]]
|
||||
|
||||
|
||||
graphvizDependencyTree :: String -> Bool -> Maybe Labels -> Maybe String -> PGF -> CId -> Expr -> String
|
||||
|
||||
Reference in New Issue
Block a user