summaryrefslogtreecommitdiff
path: root/src/compiler/GF
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler/GF')
-rw-r--r--src/compiler/GF/Command/Importing.hs5
-rw-r--r--src/compiler/GF/Compile.hs17
-rw-r--r--src/compiler/GF/Compile/Abstract/TC.hs2
-rw-r--r--src/compiler/GF/Compile/Concrete/AppPredefined.hs11
-rw-r--r--src/compiler/GF/Compile/GeneratePMCFG.hs660
-rw-r--r--src/compiler/GF/Compile/GrammarToPGF.hs565
-rw-r--r--src/compiler/GF/Compile/PGFtoProlog.hs5
-rw-r--r--src/compiler/GF/Grammar/Grammar.hs4
-rw-r--r--src/compiler/GF/Grammar/Lexer.x2
-rw-r--r--src/compiler/GF/Grammar/Macros.hs12
-rw-r--r--src/compiler/GF/Grammar/Predef.hs6
-rw-r--r--src/compiler/GF/Grammar/Printer.hs4
12 files changed, 496 insertions, 797 deletions
diff --git a/src/compiler/GF/Command/Importing.hs b/src/compiler/GF/Command/Importing.hs
index 06deab6c6..194c993ba 100644
--- a/src/compiler/GF/Command/Importing.hs
+++ b/src/compiler/GF/Command/Importing.hs
@@ -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 ----
diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs
index bf872c138..ecb533c3f 100644
--- a/src/compiler/GF/Compile.hs
+++ b/src/compiler/GF/Compile.hs
@@ -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
diff --git a/src/compiler/GF/Compile/Abstract/TC.hs b/src/compiler/GF/Compile/Abstract/TC.hs
index 8236bcf44..9c28d88e9 100644
--- a/src/compiler/GF/Compile/Abstract/TC.hs
+++ b/src/compiler/GF/Compile/Abstract/TC.hs
@@ -34,7 +34,7 @@ data AExp =
AVr Ident Val
| ACn QIdent Val
| AType
- | AInt Integer
+ | AInt Int
| AFloat Double
| AStr String
| AMeta MetaId Val
diff --git a/src/compiler/GF/Compile/Concrete/AppPredefined.hs b/src/compiler/GF/Compile/Concrete/AppPredefined.hs
index 73355381e..30f555b60 100644
--- a/src/compiler/GF/Compile/Concrete/AppPredefined.hs
+++ b/src/compiler/GF/Compile/Concrete/AppPredefined.hs
@@ -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
diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs
index a735b7adc..b0f566cea 100644
--- a/src/compiler/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/GF/Compile/GeneratePMCFG.hs
@@ -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)]
+
+ 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
-profileGrammar lang (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) pfrules = do
+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
+
+ 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'
- rformat :: Show a => Int -> a -> String
- rformat n x = replicate (n-length s) ' ' ++ s
- where
- s = show x
+ (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
-
-newtype BranchM a = BM (forall b . (a -> ([ProtoFCat],[Symbol]) -> Branch b) -> ([ProtoFCat],[Symbol]) -> Branch b)
-
-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
-
-instance MonadState ([ProtoFCat],[Symbol]) BranchM where
- get = BM (\c s -> c s s)
- put s = BM (\c _ -> c () s)
+-- 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.
-instance Functor BranchM where
- fmap f (BM m) = BM (\c s -> m (c . f) s)
+data Branch a
+ = Case Int Path [(Term,Branch a)]
+ | Variant [Branch a]
+ | Return a
-runBranchM :: BranchM (Value a) -> ([ProtoFCat],[Symbol]) -> Branch a
-runBranchM (BM m) s = m (\v s -> Return v) s
+newtype CnvMonad a = CM {unCM :: SourceGrammar
+ -> forall b . (a -> ([ProtoFCat],[Symbol]) -> Branch b)
+ -> ([ProtoFCat],[Symbol])
+ -> Branch b}
-variants :: [a] -> BranchM a
-variants xs = BM (\c s -> Variant [c x s | x <- xs])
+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)
-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)
+instance MonadState ([ProtoFCat],[Symbol]) CnvMonad where
+ get = CM (\gr c s -> c s s)
+ put s = CM (\gr c _ -> c () s)
- restrictArg path index (PFCat n cat rcs tcs) = PFCat n cat rcs (addConstraint path index tcs)
+instance Functor CnvMonad where
+ fmap f (CM m) = CM (\gr c s -> m gr (c . f) s)
- 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
+runCnvMonad :: SourceGrammar -> CnvMonad a -> ([ProtoFCat],[Symbol]) -> Branch a
+runCnvMonad gr (CM m) s = m gr (\v s -> Return v) s
-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 [])
+-- | backtracking for all variants
+variants :: [a] -> CnvMonad a
+variants xs = CM (\gr c s -> Variant [c x s | x <- xs])
+-- | 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])
+
+ 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"
+
+-- | 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 conversion
-
-type CnvMonad a = BranchM a
-
-type FPath = [LIndex]
-data ProtoFCat = PFCat Int CId [FPath] [(FPath,[LIndex])]
+-- 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])
-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
-
-
-protoFCat :: (Int,CId) -> Term -> ProtoFCat
-protoFCat (n,cat) ctype =
- let (rcs,tcs) = loop [] [] [] ctype'
- in PFCat n cat rcs tcs
- 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)
-data Branch a
- = Case Int FPath [Branch a]
- | Variant [Branch a]
- | Return (Value a)
-
-data Value a
- = Rec [Branch a]
- | Str a
- | Con LIndex
+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
-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
-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
+----------------------------------------------------------------------
+-- term conversion
-addSequences' :: GrammarEnv -> Branch [Symbol] -> (GrammarEnv, Branch SeqId)
-addSequences' env (Case nr path bs) = let (env1,bs1) = List.mapAccumL addSequences' env bs
+type Value a = Schema Branch a 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)))
+
+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
+ 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)
+
+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)
+
+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)
+
+
+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
+
+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
+
+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)
-
- 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)
-
-expandHOAS opts abs_defs lincats lindefs env =
+ 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..]))
+
+ lincats =
+ Map.insert cVar (Sort cStr) $
+ Map.fromAscList
+ [(c, ty) | (c,GF.Grammar.CncCat (Just (L _ ty)) _ _) <- Map.toList (M.jments mo)]
+
+
+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]
+ 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 rcs tcs) =
+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,ms,_) -> reverse (solutions (variants ms tcs start) ())
+ Just (start,end,_) -> reverse (solutions (fmap (start +) $ variants schema) ())
where
- variants _ [] fcat = return fcat
- variants (m:ms) ((_,indices) : tcs) fcat = do index <- member indices
- variants ms tcs ((m*index) + fcat)
-
+ 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')
-
-restrictHead :: FPath -> LIndex -> 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)
+ args <- updateNthM (restrictProtoFCat path index) nr args
+ put (head, args)
+
+restrictHead :: Path -> Term -> BacktrackM Env ()
+restrictHead path term = do
+ (head, args) <- get
+ head <- restrictProtoFCat path term head
+ put (head, args)
+
+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
diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs
index d1121e827..193a3defc 100644
--- a/src/compiler/GF/Compile/GrammarToPGF.hs
+++ b/src/compiler/GF/Compile/GrammarToPGF.hs
@@ -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)]
-
- mkDef (Just eqs) = Just [C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
- mkDef Nothing = Nothing
-
- 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
+ (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)]
+
+ 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 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]
-
- 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
+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]
- 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
-
- 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
+ predefADefs =
+ [(c, AbsCat (Just (L (0,0) []))) | c <- [cFloat,cInt,cString]]
+
+ 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]]
diff --git a/src/compiler/GF/Compile/PGFtoProlog.hs b/src/compiler/GF/Compile/PGFtoProlog.hs
index 8c5dee166..d5839916b 100644
--- a/src/compiler/GF/Compile/PGFtoProlog.hs
+++ b/src/compiler/GF/Compile/PGFtoProlog.hs
@@ -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
diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs
index 2e6f1f1a7..19e786b2a 100644
--- a/src/compiler/GF/Grammar/Grammar.hs
+++ b/src/compiler/GF/Grammar/Grammar.hs
@@ -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
diff --git a/src/compiler/GF/Grammar/Lexer.x b/src/compiler/GF/Grammar/Lexer.x
index 492c7ce8e..ca796808b 100644
--- a/src/compiler/GF/Grammar/Lexer.x
+++ b/src/compiler/GF/Grammar/Lexer.x
@@ -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
diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs
index 3380a55c0..9b9c45ba7 100644
--- a/src/compiler/GF/Grammar/Macros.hs
+++ b/src/compiler/GF/Grammar/Macros.hs
@@ -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
diff --git a/src/compiler/GF/Grammar/Predef.hs b/src/compiler/GF/Grammar/Predef.hs
index 370497cc7..f16765433 100644
--- a/src/compiler/GF/Grammar/Predef.hs
+++ b/src/compiler/GF/Grammar/Predef.hs
@@ -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")
diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs
index 69c9e8860..3f97dd390 100644
--- a/src/compiler/GF/Grammar/Printer.hs
+++ b/src/compiler/GF/Grammar/Printer.hs
@@ -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]))
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 07:54:11 +0000