forked from GitHub/gf-core
reintroduce the compiler API
This commit is contained in:
Krasimir Angelov
136
src/compiler/api/GF/Compile/CFGtoPGF.hs
Normal file
136
src/compiler/api/GF/Compile/CFGtoPGF.hs
Normal file
@@ -0,0 +1,136 @@
|
||||
{-# LANGUAGE FlexibleContexts, ImplicitParams #-}
|
||||
module GF.Compile.CFGtoPGF (cf2pgf) where
|
||||
|
||||
import GF.Grammar.CFG
|
||||
import GF.Infra.UseIO
|
||||
import GF.Infra.Option
|
||||
import GF.Compile.OptimizePGF
|
||||
|
||||
import PGF2
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.IntMap as IntMap
|
||||
import Data.Array.IArray
|
||||
import Data.List
|
||||
import Data.Maybe(fromMaybe)
|
||||
|
||||
--------------------------
|
||||
-- the compiler ----------
|
||||
--------------------------
|
||||
|
||||
cf2pgf :: Options -> FilePath -> ParamCFG -> Map.Map Fun Double -> PGF
|
||||
cf2pgf opts fpath cf probs = error "TODO: cf2pgf" {-
|
||||
build (let abstr = cf2abstr cf probs
|
||||
in newPGF [] aname abstr [(cname, cf2concr opts abstr cf)])
|
||||
where
|
||||
name = justModuleName fpath
|
||||
aname = name ++ "Abs"
|
||||
cname = name
|
||||
|
||||
cf2abstr :: (?builder :: Builder s) => ParamCFG -> Map.Map Fun Double -> B s AbstrInfo
|
||||
cf2abstr cfg probs = newAbstr aflags acats afuns
|
||||
where
|
||||
aflags = [("startcat", LStr (fst (cfgStartCat cfg)))]
|
||||
|
||||
acats = [(c', [], toLogProb (fromMaybe 0 (Map.lookup c' probs))) | cat <- allCats' cfg, let c' = cat2id cat]
|
||||
afuns = [(f', dTyp [hypo Explicit "_" (dTyp [] (cat2id c) []) | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)) [], 0, [], toLogProb (fromMaybe 0 (Map.lookup f' funs_probs)))
|
||||
| rule <- allRules cfg
|
||||
, let f' = mkRuleName rule]
|
||||
|
||||
funs_probs = (Map.fromList . concat . Map.elems . fmap pad . Map.fromListWith (++))
|
||||
[(cat,[(f',Map.lookup f' probs)]) | rule <- allRules cfg,
|
||||
let cat = cat2id (ruleLhs rule),
|
||||
let f' = mkRuleName rule]
|
||||
where
|
||||
pad :: [(a,Maybe Double)] -> [(a,Double)]
|
||||
pad pfs = [(f,fromMaybe deflt mb_p) | (f,mb_p) <- pfs]
|
||||
where
|
||||
deflt = case length [f | (f,Nothing) <- pfs] of
|
||||
0 -> 0
|
||||
n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n)
|
||||
|
||||
toLogProb = realToFrac . negate . log
|
||||
|
||||
cat2id = fst
|
||||
|
||||
cf2concr :: (?builder :: Builder s) => Options -> B s AbstrInfo -> ParamCFG -> B s ConcrInfo
|
||||
cf2concr opts abstr cfg =
|
||||
let (lindefs',linrefs',productions',cncfuns',sequences',cnccats') =
|
||||
(if flag optOptimizePGF opts then optimizePGF (fst (cfgStartCat cfg)) else id)
|
||||
(lindefsrefs,lindefsrefs,IntMap.toList productions,cncfuns,sequences,cnccats)
|
||||
in newConcr abstr [] []
|
||||
lindefs' linrefs'
|
||||
productions' cncfuns'
|
||||
sequences' cnccats' totalCats
|
||||
where
|
||||
cats = allCats' cfg
|
||||
rules = allRules cfg
|
||||
|
||||
idSeq = [SymCat 0 0]
|
||||
|
||||
sequences0 = Set.fromList (idSeq :
|
||||
map mkSequence rules)
|
||||
sequences = Set.toList sequences0
|
||||
|
||||
idFun = ("_",[Set.findIndex idSeq sequences0])
|
||||
((fun_cnt,cncfuns0),productions0) = mapAccumL (convertRule cs) (1,[idFun]) rules
|
||||
productions = foldl addProd IntMap.empty (concat (productions0++coercions))
|
||||
cncfuns = reverse cncfuns0
|
||||
|
||||
lbls = ["s"]
|
||||
(fid,cnccats) = (mapAccumL mkCncCat 0 . Map.toList . Map.fromListWith max)
|
||||
[(c,p) | (c,ps) <- cats, p <- ps]
|
||||
((totalCats,cs), coercions) = mapAccumL mkCoercions (fid,Map.empty) cats
|
||||
|
||||
lindefsrefs = map mkLinDefRef cats
|
||||
|
||||
convertRule cs (funid,funs) rule =
|
||||
let args = [PArg [] (cat2arg c) | NonTerminal c <- ruleRhs rule]
|
||||
prod = PApply funid args
|
||||
seqid = Set.findIndex (mkSequence rule) sequences0
|
||||
fun = (mkRuleName rule, [seqid])
|
||||
funid' = funid+1
|
||||
in funid' `seq` ((funid',fun:funs),let (c,ps) = ruleLhs rule in [(cat2fid c p, prod) | p <- ps])
|
||||
|
||||
mkSequence rule = snd $ mapAccumL convertSymbol 0 (ruleRhs rule)
|
||||
where
|
||||
convertSymbol d (NonTerminal (c,_)) = (d+1,if c `elem` ["Int","Float","String"] then SymLit d 0 else SymCat d 0)
|
||||
convertSymbol d (Terminal t) = (d, SymKS t)
|
||||
|
||||
mkCncCat fid (cat,n)
|
||||
| cat == "Int" = (fid, (cat, fidInt, fidInt, lbls))
|
||||
| cat == "Float" = (fid, (cat, fidFloat, fidFloat, lbls))
|
||||
| cat == "String" = (fid, (cat, fidString, fidString, lbls))
|
||||
| otherwise = let fid' = fid+n+1
|
||||
in fid' `seq` (fid', (cat, fid, fid+n, lbls))
|
||||
|
||||
mkCoercions (fid,cs) c@(cat,[p]) = ((fid,cs),[])
|
||||
mkCoercions (fid,cs) c@(cat,ps ) =
|
||||
let fid' = fid+1
|
||||
in fid' `seq` ((fid', Map.insert c fid cs), [(fid,PCoerce (cat2fid cat p)) | p <- ps])
|
||||
|
||||
mkLinDefRef (cat,_) =
|
||||
(cat2fid cat 0,[0])
|
||||
|
||||
addProd prods (fid,prod) =
|
||||
case IntMap.lookup fid prods of
|
||||
Just set -> IntMap.insert fid (prod:set) prods
|
||||
Nothing -> IntMap.insert fid [prod] prods
|
||||
|
||||
cat2fid cat p =
|
||||
case [start | (cat',start,_,_) <- cnccats, cat == cat'] of
|
||||
(start:_) -> fid+p
|
||||
_ -> error "cat2fid"
|
||||
|
||||
cat2arg c@(cat,[p]) = cat2fid cat p
|
||||
cat2arg c@(cat,ps ) =
|
||||
case Map.lookup c cs of
|
||||
Just fid -> fid
|
||||
Nothing -> error "cat2arg"
|
||||
|
||||
mkRuleName rule =
|
||||
case ruleName rule of
|
||||
CFObj n _ -> n
|
||||
_ -> "_"
|
||||
-}
|
||||
332
src/compiler/api/GF/Compile/CheckGrammar.hs
Normal file
332
src/compiler/api/GF/Compile/CheckGrammar.hs
Normal file
@@ -0,0 +1,332 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : CheckGrammar
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/11/11 23:24:33 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.31 $
|
||||
--
|
||||
-- AR 4\/12\/1999 -- 1\/4\/2000 -- 8\/9\/2001 -- 15\/5\/2002 -- 27\/11\/2002 -- 18\/6\/2003
|
||||
--
|
||||
-- type checking also does the following modifications:
|
||||
--
|
||||
-- - types of operations and local constants are inferred and put in place
|
||||
--
|
||||
-- - both these types and linearization types are computed
|
||||
--
|
||||
-- - tables are type-annotated
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Compile.CheckGrammar(checkModule) where
|
||||
|
||||
import Prelude hiding ((<>))
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Option
|
||||
|
||||
import GF.Compile.TypeCheck.Abstract
|
||||
import GF.Compile.TypeCheck.Concrete(checkLType,inferLType,ppType)
|
||||
import qualified GF.Compile.TypeCheck.ConcreteNew as CN(checkLType,inferLType)
|
||||
import GF.Compile.Compute.Concrete(normalForm)
|
||||
|
||||
import GF.Grammar
|
||||
import GF.Grammar.Lexer
|
||||
import GF.Grammar.Lookup
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Infra.CheckM
|
||||
|
||||
import Data.List
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import Control.Monad
|
||||
import GF.Text.Pretty
|
||||
|
||||
-- | checking is performed in the dependency order of modules
|
||||
checkModule :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
|
||||
checkModule opts cwd sgr mo@(m,mi) = do
|
||||
checkRestrictedInheritance cwd sgr mo
|
||||
mo <- case mtype mi of
|
||||
MTConcrete a -> do let gr = prependModule sgr mo
|
||||
abs <- lookupModule gr a
|
||||
checkCompleteGrammar opts cwd gr (a,abs) mo
|
||||
_ -> return mo
|
||||
infoss <- checkInModule cwd mi NoLoc empty $ topoSortJments2 mo
|
||||
foldM (foldM (checkInfo opts cwd sgr)) mo infoss
|
||||
|
||||
-- check if restricted inheritance modules are still coherent
|
||||
-- i.e. that the defs of remaining names don't depend on omitted names
|
||||
checkRestrictedInheritance :: FilePath -> SourceGrammar -> SourceModule -> Check ()
|
||||
checkRestrictedInheritance cwd sgr (name,mo) = checkInModule cwd mo NoLoc empty $ do
|
||||
let irs = [ii | ii@(_,mi) <- mextend mo, mi /= MIAll] -- names with restr. inh.
|
||||
let mrs = [((i,m),mi) | (i,m) <- mos, Just mi <- [lookup i irs]]
|
||||
-- the restr. modules themself, with restr. infos
|
||||
mapM_ checkRem mrs
|
||||
where
|
||||
mos = modules sgr
|
||||
checkRem ((i,m),mi) = do
|
||||
let (incl,excl) = partition (isInherited mi) (Map.keys (jments m))
|
||||
let incld c = Set.member c (Set.fromList incl)
|
||||
let illegal c = Set.member c (Set.fromList excl)
|
||||
let illegals = [(f,is) |
|
||||
(f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)]
|
||||
case illegals of
|
||||
[] -> return ()
|
||||
cs -> checkWarn ("In inherited module" <+> i <> ", dependence of excluded constants:" $$
|
||||
nest 2 (vcat [f <+> "on" <+> fsep is | (f,is) <- cs]))
|
||||
allDeps = concatMap (allDependencies (const True) . jments . snd) mos
|
||||
|
||||
checkCompleteGrammar :: Options -> FilePath -> Grammar -> Module -> Module -> Check Module
|
||||
checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc empty $ do
|
||||
let jsa = jments abs
|
||||
let jsc = jments cnc
|
||||
|
||||
-- check that all concrete constants are in abstract; build types for all lin
|
||||
jsc <- foldM checkCnc Map.empty (Map.toList jsc)
|
||||
|
||||
-- check that all abstract constants are in concrete; build default lin and lincats
|
||||
jsc <- foldM checkAbs jsc (Map.toList jsa)
|
||||
|
||||
return (cm,cnc{jments=jsc})
|
||||
where
|
||||
checkAbs js i@(c,info) =
|
||||
case info of
|
||||
AbsFun (Just (L loc ty)) _ _ _
|
||||
-> do let mb_def = do
|
||||
let (cxt,(_,i),_) = typeForm ty
|
||||
info <- lookupIdent i js
|
||||
info <- case info of
|
||||
(AnyInd _ m) -> do (m,info) <- lookupOrigInfo gr (m,i)
|
||||
return info
|
||||
_ -> return info
|
||||
case info of
|
||||
CncCat (Just (L loc (RecType []))) _ _ _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt)
|
||||
_ -> Bad "no def lin"
|
||||
|
||||
case lookupIdent c js of
|
||||
Ok (AnyInd _ _) -> return js
|
||||
Ok (CncFun ty (Just def) mn mf) ->
|
||||
return $ Map.insert c (CncFun ty (Just def) mn mf) js
|
||||
Ok (CncFun ty Nothing mn mf) ->
|
||||
case mb_def of
|
||||
Ok def -> return $ Map.insert c (CncFun ty (Just (L NoLoc def)) mn mf) js
|
||||
Bad _ -> do noLinOf c
|
||||
return js
|
||||
_ -> do
|
||||
case mb_def of
|
||||
Ok def -> do linty <- linTypeOfType gr cm (L loc ty)
|
||||
return $ Map.insert c (CncFun (Just linty) (Just (L NoLoc def)) Nothing Nothing) js
|
||||
Bad _ -> do noLinOf c
|
||||
return js
|
||||
where noLinOf c = checkWarn ("no linearization of" <+> c)
|
||||
AbsCat (Just _) -> case lookupIdent c js of
|
||||
Ok (AnyInd _ _) -> return js
|
||||
Ok (CncCat (Just _) _ _ _ _) -> return js
|
||||
Ok (CncCat Nothing md mr mp mpmcfg) -> do
|
||||
checkWarn ("no linearization type for" <+> c <> ", inserting default {s : Str}")
|
||||
return $ Map.insert c (CncCat (Just (L NoLoc defLinType)) md mr mp mpmcfg) js
|
||||
_ -> do
|
||||
checkWarn ("no linearization type for" <+> c <> ", inserting default {s : Str}")
|
||||
return $ Map.insert c (CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing Nothing) js
|
||||
_ -> return js
|
||||
|
||||
checkCnc js (c,info) =
|
||||
case info of
|
||||
CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of
|
||||
Ok (_,AbsFun (Just (L loc ty)) _ _ _) ->
|
||||
do linty <- linTypeOfType gr cm (L loc ty)
|
||||
return $ Map.insert c (CncFun (Just linty) d mn mf) js
|
||||
_ -> do checkWarn ("function" <+> c <+> "is not in abstract")
|
||||
return js
|
||||
CncCat {} ->
|
||||
case lookupOrigInfo gr (am,c) of
|
||||
Ok (_,AbsCat _) -> return $ Map.insert c info js
|
||||
{- -- This might be too pedantic:
|
||||
Ok (_,AbsFun {}) ->
|
||||
checkError ("lincat:"<+>c<+>"is a fun, not a cat")
|
||||
-}
|
||||
_ -> do checkWarn ("category" <+> c <+> "is not in abstract")
|
||||
return js
|
||||
|
||||
_ -> return $ Map.insert c info js
|
||||
|
||||
checkInfo :: Options -> FilePath -> SourceGrammar -> SourceModule -> (Ident,Info) -> Check SourceModule
|
||||
checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
|
||||
checkReservedId c
|
||||
case info of
|
||||
AbsCat (Just (L loc cont)) ->
|
||||
mkCheck loc "the category" $
|
||||
checkContext gr cont
|
||||
|
||||
AbsFun (Just (L loc typ)) ma md moper -> do
|
||||
mkCheck loc "the type of function" $
|
||||
checkTyp gr typ
|
||||
typ <- compAbsTyp [] typ -- to calculate let definitions
|
||||
case md of
|
||||
Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $
|
||||
checkDef gr (fst sm,c) typ eq) eqs
|
||||
Nothing -> return ()
|
||||
update sm c (AbsFun (Just (L loc typ)) ma md moper)
|
||||
|
||||
CncCat mty mdef mref mpr mpmcfg -> do
|
||||
mty <- case mty of
|
||||
Just (L loc typ) -> chIn loc "linearization type of" $ do
|
||||
(typ,_) <- checkLType gr [] typ typeType
|
||||
typ <- normalForm gr typ
|
||||
return (Just (L loc typ))
|
||||
Nothing -> return Nothing
|
||||
mdef <- case (mty,mdef) of
|
||||
(Just (L _ typ),Just (L loc def)) ->
|
||||
chIn loc "default linearization of" $ do
|
||||
(def,_) <- checkLType gr [] def (mkFunType [typeStr] typ)
|
||||
return (Just (L loc def))
|
||||
_ -> return Nothing
|
||||
mref <- case (mty,mref) of
|
||||
(Just (L _ typ),Just (L loc ref)) ->
|
||||
chIn loc "reference linearization of" $ do
|
||||
(ref,_) <- checkLType gr [] ref (mkFunType [typ] typeStr)
|
||||
return (Just (L loc ref))
|
||||
_ -> return Nothing
|
||||
mpr <- case mpr of
|
||||
(Just (L loc t)) ->
|
||||
chIn loc "print name of" $ do
|
||||
(t,_) <- checkLType gr [] t typeStr
|
||||
return (Just (L loc t))
|
||||
_ -> return Nothing
|
||||
update sm c (CncCat mty mdef mref mpr mpmcfg)
|
||||
|
||||
CncFun mty mt mpr mpmcfg -> do
|
||||
mt <- case (mty,mt) of
|
||||
(Just (_,cat,cont,val),Just (L loc trm)) ->
|
||||
chIn loc "linearization of" $ do
|
||||
(trm,_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val) -- erases arg vars
|
||||
return (Just (L loc (etaExpand [] trm cont)))
|
||||
_ -> return mt
|
||||
mpr <- case mpr of
|
||||
(Just (L loc t)) ->
|
||||
chIn loc "print name of" $ do
|
||||
(t,_) <- checkLType gr [] t typeStr
|
||||
return (Just (L loc t))
|
||||
_ -> return Nothing
|
||||
update sm c (CncFun mty mt mpr mpmcfg)
|
||||
|
||||
ResOper pty pde -> do
|
||||
(pty', pde') <- case (pty,pde) of
|
||||
(Just (L loct ty), Just (L locd de)) -> do
|
||||
ty' <- chIn loct "operation" $ do
|
||||
(ty,_) <- checkLType gr [] ty typeType
|
||||
normalForm gr ty
|
||||
(de',_) <- chIn locd "operation" $
|
||||
checkLType gr [] de ty'
|
||||
return (Just (L loct ty'), Just (L locd de'))
|
||||
(Nothing , Just (L locd de)) -> do
|
||||
(de',ty') <- chIn locd "operation" $
|
||||
inferLType gr [] de
|
||||
return (Just (L locd ty'), Just (L locd de'))
|
||||
(Just (L loct ty), Nothing) -> do
|
||||
chIn loct "operation" $
|
||||
checkError (pp "No definition given to the operation")
|
||||
update sm c (ResOper pty' pde')
|
||||
|
||||
ResOverload os tysts -> chIn NoLoc "overloading" $ do
|
||||
tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType gr [] t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts -- return explicit ones
|
||||
tysts0 <- lookupOverload gr (fst sm,c) -- check against inherited ones too
|
||||
tysts1 <- mapM (uncurry $ flip (checkLType gr []))
|
||||
[(mkFunType args val,tr) | (args,(val,tr)) <- tysts0]
|
||||
--- this can only be a partial guarantee, since matching
|
||||
--- with value type is only possible if expected type is given
|
||||
checkUniq $
|
||||
sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
|
||||
update sm c (ResOverload os [(y,x) | (x,y) <- tysts'])
|
||||
|
||||
ResParam (Just (L loc pcs)) _ -> do
|
||||
(sm,cnt,ts,pcs) <- chIn loc "parameter type" $
|
||||
mkParamValues sm c 0 [] pcs
|
||||
update sm c (ResParam (Just (L loc pcs)) (Just (ts,cnt)))
|
||||
|
||||
_ -> return sm
|
||||
where
|
||||
gr = prependModule sgr sm
|
||||
chIn loc cat = checkInModule cwd (snd sm) loc ("Happened in" <+> cat <+> c)
|
||||
|
||||
mkParamValues sm c cnt ts [] = return (sm,cnt,[],[])
|
||||
mkParamValues sm@(mn,mi) c cnt ts ((p,co):pcs) = do
|
||||
co <- mapM (\(b,v,ty) -> normalForm gr ty >>= \ty -> return (b,v,ty)) co
|
||||
sm <- case lookupIdent p (jments mi) of
|
||||
Ok (ResValue (L loc _) _) -> update sm p (ResValue (L loc (mkProdSimple co (QC (mn,c)))) cnt)
|
||||
Bad msg -> checkError (pp msg)
|
||||
vs <- liftM sequence $ mapM (\(_,_,ty) -> allParamValues gr ty) co
|
||||
(sm,cnt,ts,pcs) <- mkParamValues sm c (cnt+length vs) ts pcs
|
||||
return (sm,cnt,map (mkApp (QC (mn,p))) vs ++ ts,(p,co):pcs)
|
||||
|
||||
checkUniq xss = case xss of
|
||||
x:y:xs
|
||||
| x == y -> checkError $ "ambiguous for type" <+>
|
||||
ppType (mkFunType (tail x) (head x))
|
||||
| otherwise -> checkUniq $ y:xs
|
||||
_ -> return ()
|
||||
|
||||
mkCheck loc cat ss = case ss of
|
||||
[] -> return sm
|
||||
_ -> chIn loc cat $ checkError (vcat ss)
|
||||
|
||||
compAbsTyp g t = case t of
|
||||
Vr x -> maybe (checkError ("no value given to variable" <+> x)) return $ lookup x g
|
||||
Let (x,(_,a)) b -> do
|
||||
a' <- compAbsTyp g a
|
||||
compAbsTyp ((x, a'):g) b
|
||||
Prod b x a t -> do
|
||||
a' <- compAbsTyp g a
|
||||
t' <- compAbsTyp ((x,Vr x):g) t
|
||||
return $ Prod b x a' t'
|
||||
Abs _ _ _ -> return t
|
||||
_ -> composOp (compAbsTyp g) t
|
||||
|
||||
etaExpand xs t [] = t
|
||||
etaExpand xs (Abs bt x t) (_ :cont) = Abs bt x (etaExpand (x:xs) t cont)
|
||||
etaExpand xs t ((bt,_,ty):cont) = Abs bt x (etaExpand (x:xs) (App t (Vr x)) cont)
|
||||
where
|
||||
x = freeVar 1 xs
|
||||
|
||||
freeVar i xs
|
||||
| elem x xs = freeVar (i+1) xs
|
||||
| otherwise = x
|
||||
where
|
||||
x = identS ("v"++show i)
|
||||
|
||||
update (mn,mi) c info = return (mn,mi{jments=Map.insert c info (jments mi)})
|
||||
|
||||
|
||||
-- | for grammars obtained otherwise than by parsing ---- update!!
|
||||
checkReservedId :: Ident -> Check ()
|
||||
checkReservedId x =
|
||||
when (isReservedWord x) $
|
||||
checkWarn ("reserved word used as identifier:" <+> x)
|
||||
|
||||
-- auxiliaries
|
||||
|
||||
-- | linearization types and defaults
|
||||
linTypeOfType :: Grammar -> ModuleName -> L Type -> Check ([Ident],Ident,Context,Type)
|
||||
linTypeOfType cnc m (L loc typ) = do
|
||||
let (ctxt,res_cat) = typeSkeleton typ
|
||||
val <- lookLin res_cat
|
||||
lin_args <- mapM mkLinArg (zip [1..] ctxt)
|
||||
let (args,arg_cats) = unzip lin_args
|
||||
return (arg_cats, snd res_cat, args, val)
|
||||
where
|
||||
mkLinArg (i,(n,mc@(m,cat))) = do
|
||||
val <- lookLin mc
|
||||
let vars = mkRecType varLabel $ replicate n typeStr
|
||||
rec <- if n==0 then return val else
|
||||
errIn (render ("extending" $$
|
||||
nest 2 vars $$
|
||||
"with" $$
|
||||
nest 2 val)) $
|
||||
plusRecType vars val
|
||||
return ((Explicit,varX i,rec),cat)
|
||||
lookLin (_,c) = checks [ --- rather: update with defLinType ?
|
||||
lookupLincat cnc m c >>= normalForm cnc
|
||||
,return defLinType
|
||||
]
|
||||
138
src/compiler/api/GF/Compile/Compute/Abstract.hs
Normal file
138
src/compiler/api/GF/Compile/Compute/Abstract.hs
Normal file
@@ -0,0 +1,138 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : GF.Compile.Abstract.Compute
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/10/02 20:50:19 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.8 $
|
||||
--
|
||||
-- computation in abstract syntax w.r.t. explicit definitions.
|
||||
--
|
||||
-- old GF computation; to be updated
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Compile.Compute.Abstract (LookDef,
|
||||
compute,
|
||||
computeAbsTerm,
|
||||
computeAbsTermIn,
|
||||
beta
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
import GF.Grammar
|
||||
import GF.Grammar.Lookup
|
||||
|
||||
import Debug.Trace
|
||||
import Data.List(intersperse)
|
||||
import Control.Monad (liftM, liftM2)
|
||||
import GF.Text.Pretty
|
||||
|
||||
-- for debugging
|
||||
tracd m t = t
|
||||
-- tracd = trace
|
||||
|
||||
compute :: SourceGrammar -> Term -> Err Term
|
||||
compute = computeAbsTerm
|
||||
|
||||
computeAbsTerm :: SourceGrammar -> Term -> Err Term
|
||||
computeAbsTerm gr = computeAbsTermIn (lookupAbsDef gr) []
|
||||
|
||||
-- | a hack to make compute work on source grammar as well
|
||||
type LookDef = Ident -> Ident -> Err (Maybe Int,Maybe [Equation])
|
||||
|
||||
computeAbsTermIn :: LookDef -> [Ident] -> Term -> Err Term
|
||||
computeAbsTermIn lookd xs e = errIn (render (text "computing" <+> ppTerm Unqualified 0 e)) $ compt xs e where
|
||||
compt vv t = case t of
|
||||
-- Prod x a b -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b)
|
||||
-- Abs x b -> liftM (Abs x) (compt (x:vv) b)
|
||||
_ -> do
|
||||
let t' = beta vv t
|
||||
(yy,f,aa) <- termForm t'
|
||||
let vv' = map snd yy ++ vv
|
||||
aa' <- mapM (compt vv') aa
|
||||
case look f of
|
||||
Just eqs -> tracd (text "\nmatching" <+> ppTerm Unqualified 0 f) $
|
||||
case findMatch eqs aa' of
|
||||
Ok (d,g) -> do
|
||||
--- let (xs,ts) = unzip g
|
||||
--- ts' <- alphaFreshAll vv' ts
|
||||
let g' = g --- zip xs ts'
|
||||
d' <- compt vv' $ substTerm vv' g' d
|
||||
tracd (text "by Egs:" <+> ppTerm Unqualified 0 d') $ return $ mkAbs yy $ d'
|
||||
_ -> tracd (text "no match" <+> ppTerm Unqualified 0 t') $
|
||||
do
|
||||
let v = mkApp f aa'
|
||||
return $ mkAbs yy $ v
|
||||
_ -> do
|
||||
let t2 = mkAbs yy $ mkApp f aa'
|
||||
tracd (text "not defined" <+> ppTerm Unqualified 0 t2) $ return t2
|
||||
|
||||
look t = case t of
|
||||
(Q (m,f)) -> case lookd m f of
|
||||
Ok (_,md) -> md
|
||||
_ -> Nothing
|
||||
_ -> Nothing
|
||||
|
||||
beta :: [Ident] -> Exp -> Exp
|
||||
beta vv c = case c of
|
||||
Let (x,(_,a)) b -> beta vv $ substTerm vv [(x,beta vv a)] (beta (x:vv) b)
|
||||
App f a ->
|
||||
let (a',f') = (beta vv a, beta vv f) in
|
||||
case f' of
|
||||
Abs _ x b -> beta vv $ substTerm vv [(x,a')] (beta (x:vv) b)
|
||||
_ -> (if a'==a && f'==f then id else beta vv) $ App f' a'
|
||||
Prod b x a t -> Prod b x (beta vv a) (beta (x:vv) t)
|
||||
Abs b x t -> Abs b x (beta (x:vv) t)
|
||||
_ -> c
|
||||
|
||||
-- special version of pattern matching, to deal with comp under lambda
|
||||
|
||||
findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution)
|
||||
findMatch cases terms = case cases of
|
||||
[] -> Bad $ render (text "no applicable case for" <+> hcat (punctuate comma (map (ppTerm Unqualified 0) terms)))
|
||||
(patts,_):_ | length patts /= length terms ->
|
||||
Bad (render (text "wrong number of args for patterns :" <+>
|
||||
hsep (map (ppPatt Unqualified 0) patts) <+> text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms)))
|
||||
(patts,val):cc -> case mapM tryMatch (zip patts terms) of
|
||||
Ok substs -> return (tracd (text "value" <+> ppTerm Unqualified 0 val) val, concat substs)
|
||||
_ -> findMatch cc terms
|
||||
|
||||
tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
|
||||
tryMatch (p,t) = do
|
||||
t' <- termForm t
|
||||
trym p t'
|
||||
where
|
||||
|
||||
trym p t' = err (\s -> tracd s (Bad s)) (\t -> tracd (prtm p t) (return t)) $ ----
|
||||
case (p,t') of
|
||||
(PW, _) | notMeta t -> return [] -- optimization with wildcard
|
||||
(PV x, _) | notMeta t -> return [(x,t)]
|
||||
(PString s, ([],K i,[])) | s==i -> return []
|
||||
(PInt s, ([],EInt i,[])) | s==i -> return []
|
||||
(PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
|
||||
(PP (q,p) pp, ([], QC (r,f), tt)) |
|
||||
p `eqStrIdent` f && length pp == length tt -> do
|
||||
matches <- mapM tryMatch (zip pp tt)
|
||||
return (concat matches)
|
||||
(PP (q,p) pp, ([], Q (r,f), tt)) |
|
||||
p `eqStrIdent` f && length pp == length tt -> do
|
||||
matches <- mapM tryMatch (zip pp tt)
|
||||
return (concat matches)
|
||||
(PT _ p',_) -> trym p' t'
|
||||
(PAs x p',_) -> do
|
||||
subst <- trym p' t'
|
||||
return $ (x,t) : subst
|
||||
_ -> Bad (render (text "no match in pattern" <+> ppPatt Unqualified 0 p <+> text "for" <+> ppTerm Unqualified 0 t))
|
||||
|
||||
notMeta e = case e of
|
||||
Meta _ -> False
|
||||
App f a -> notMeta f && notMeta a
|
||||
Abs _ _ b -> notMeta b
|
||||
_ -> True
|
||||
|
||||
prtm p g =
|
||||
ppPatt Unqualified 0 p <+> colon $$ hsep (punctuate semi [ppIdent x <+> char '=' <+> ppTerm Unqualified 0 y | (x,y) <- g])
|
||||
914
src/compiler/api/GF/Compile/Compute/Concrete.hs
Normal file
914
src/compiler/api/GF/Compile/Compute/Concrete.hs
Normal file
@@ -0,0 +1,914 @@
|
||||
{-# LANGUAGE RankNTypes, BangPatterns, CPP #-}
|
||||
|
||||
-- | Functions for computing the values of terms in the concrete syntax, in
|
||||
-- | preparation for PMCFG generation.
|
||||
module GF.Compile.Compute.Concrete
|
||||
( normalForm
|
||||
, Value(..), Thunk, ThunkState(..), Env, Scope, showValue
|
||||
, MetaThunks, Constraint
|
||||
, EvalM(..), runEvalM, runEvalOneM, evalError, evalWarn
|
||||
, eval, apply, force, value2term, patternMatch
|
||||
, newThunk, newEvaluatedThunk
|
||||
, newResiduation, newNarrowing, getVariables
|
||||
, getRef, setRef
|
||||
, getResDef, getInfo, getResType, getOverload
|
||||
, getAllParamValues
|
||||
) where
|
||||
|
||||
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
|
||||
|
||||
import GF.Grammar hiding (Env, VGen, VApp, VRecType)
|
||||
import GF.Grammar.Lookup(lookupResDef,lookupResType,
|
||||
lookupOrigInfo,lookupOverloadTypes,
|
||||
allParamValues)
|
||||
import GF.Grammar.Predef
|
||||
import GF.Grammar.Lockfield(lockLabel)
|
||||
import GF.Grammar.Printer
|
||||
import GF.Data.Operations(Err(..))
|
||||
import GF.Infra.CheckM
|
||||
import GF.Infra.Option
|
||||
import Data.STRef
|
||||
import Data.Maybe(fromMaybe)
|
||||
import Data.List
|
||||
import Data.Char
|
||||
import Control.Monad
|
||||
import Control.Monad.ST
|
||||
import Control.Applicative hiding (Const)
|
||||
import qualified Control.Monad.Fail as Fail
|
||||
import qualified Data.Map as Map
|
||||
import GF.Text.Pretty
|
||||
import PGF2.Transactions(LIndex)
|
||||
|
||||
-- * Main entry points
|
||||
|
||||
normalForm :: Grammar -> Term -> Check Term
|
||||
normalForm gr t =
|
||||
fmap mkFV (runEvalM gr (eval [] t [] >>= value2term []))
|
||||
where
|
||||
mkFV [t] = t
|
||||
mkFV ts = FV ts
|
||||
|
||||
type Sigma s = Value s
|
||||
type Constraint s = Value s
|
||||
|
||||
data ThunkState s
|
||||
= Unevaluated (Env s) Term
|
||||
| Evaluated {-# UNPACK #-} !Int (Value s)
|
||||
| Hole {-# UNPACK #-} !MetaId
|
||||
| Narrowing {-# UNPACK #-} !MetaId Type
|
||||
| Residuation {-# UNPACK #-} !MetaId (Scope s) (Maybe (Constraint s))
|
||||
|
||||
type Thunk s = STRef s (ThunkState s)
|
||||
type Env s = [(Ident,Thunk s)]
|
||||
type Scope s = [(Ident,Value s)]
|
||||
|
||||
data Value s
|
||||
= VApp QIdent [Thunk s]
|
||||
| VMeta (Thunk s) [Thunk s]
|
||||
| VSusp (Thunk s) (Value s -> EvalM s (Value s)) [Thunk s]
|
||||
| VGen {-# UNPACK #-} !Int [Thunk s]
|
||||
| VClosure (Env s) Term
|
||||
| VProd BindType Ident (Value s) (Value s)
|
||||
| VRecType [(Label, Value s)]
|
||||
| VR [(Label, Thunk s)]
|
||||
| VP (Value s) Label [Thunk s]
|
||||
| VExtR (Value s) (Value s)
|
||||
| VTable (Value s) (Value s)
|
||||
| VT (Value s) (Env s) [Case]
|
||||
| VV (Value s) [Thunk s]
|
||||
| VS (Value s) (Thunk s) [Thunk s]
|
||||
| VSort Ident
|
||||
| VInt Integer
|
||||
| VFlt Double
|
||||
| VStr String
|
||||
| VEmpty
|
||||
| VC (Value s) (Value s)
|
||||
| VGlue (Value s) (Value s)
|
||||
| VPatt Int (Maybe Int) Patt
|
||||
| VPattType (Value s)
|
||||
| VAlts (Value s) [(Value s, Value s)]
|
||||
| VStrs [Value s]
|
||||
-- These two constructors are only used internally
|
||||
-- in the PMCFG generator.
|
||||
| VSymCat Int LIndex [(LIndex, (Thunk s, Type))]
|
||||
| VSymVar Int Int
|
||||
-- These two constructors are only used internally
|
||||
-- in the type checker.
|
||||
| VCRecType [(Label, Bool, Constraint s)]
|
||||
| VCInts (Maybe Integer) (Maybe Integer)
|
||||
|
||||
|
||||
showValue (VApp q tnks) = "(VApp "++unwords (show q : map (const "_") tnks) ++ ")"
|
||||
showValue (VMeta _ _) = "VMeta"
|
||||
showValue (VSusp _ _ _) = "VSusp"
|
||||
showValue (VGen i _) = "(VGen "++show i++")"
|
||||
showValue (VClosure _ _) = "VClosure"
|
||||
showValue (VProd _ x v1 v2) = "VProd ("++show x++") ("++showValue v1++") ("++showValue v2++")"
|
||||
showValue (VRecType _) = "VRecType"
|
||||
showValue (VR lbls) = "(VR {"++unwords (map (\(lbl,_) -> show lbl) lbls)++"})"
|
||||
showValue (VP v l _) = "(VP "++showValue v++" "++show l++")"
|
||||
showValue (VExtR _ _) = "VExtR"
|
||||
showValue (VTable v1 v2) = "VTable ("++showValue v1++") ("++showValue v2++")"
|
||||
showValue (VT _ _ cs) = "(VT "++show cs++")"
|
||||
showValue (VV _ _) = "VV"
|
||||
showValue (VS v _ _) = "(VS "++showValue v++")"
|
||||
showValue (VSort s) = "(VSort "++show s++")"
|
||||
showValue (VInt _) = "VInt"
|
||||
showValue (VFlt _) = "VFlt"
|
||||
showValue (VStr s) = "(VStr "++show s++")"
|
||||
showValue VEmpty = "VEmpty"
|
||||
showValue (VC _ _) = "VC"
|
||||
showValue (VGlue _ _) = "VGlue"
|
||||
showValue (VPatt _ _ _) = "VPatt"
|
||||
showValue (VPattType _) = "VPattType"
|
||||
showValue (VAlts _ _) = "VAlts"
|
||||
showValue (VStrs _) = "VStrs"
|
||||
showValue (VSymCat _ _ _) = "VSymCat"
|
||||
|
||||
eval env (Vr x) vs = do (tnk,depth) <- lookup x env
|
||||
withVar depth $ do
|
||||
v <- force tnk
|
||||
apply v vs
|
||||
where
|
||||
lookup x [] = evalError ("Variable" <+> pp x <+> "is not in scope")
|
||||
lookup x ((y,tnk):env)
|
||||
| x == y = return (tnk,length env)
|
||||
| otherwise = lookup x env
|
||||
eval env (Sort s) []
|
||||
| s == cTok = return (VSort cStr)
|
||||
| otherwise = return (VSort s)
|
||||
eval env (EInt n) [] = return (VInt n)
|
||||
eval env (EFloat d) [] = return (VFlt d)
|
||||
eval env (K t) [] = return (VStr t)
|
||||
eval env Empty [] = return VEmpty
|
||||
eval env (App t1 t2) vs = do tnk <- newThunk env t2
|
||||
eval env t1 (tnk : vs)
|
||||
eval env (Abs b x t) [] = return (VClosure env (Abs b x t))
|
||||
eval env (Abs b x t) (v:vs) = eval ((x,v):env) t vs
|
||||
eval env (Meta i) vs = do tnk <- newHole i
|
||||
return (VMeta tnk vs)
|
||||
eval env (ImplArg t) [] = eval env t []
|
||||
eval env (Prod b x t1 t2)[] = do v1 <- eval env t1 []
|
||||
return (VProd b x v1 (VClosure env t2))
|
||||
eval env (Typed t ty) vs = eval env t vs
|
||||
eval env (RecType lbls) [] = do lbls <- mapM (\(lbl,ty) -> fmap ((,) lbl) (eval env ty [])) lbls
|
||||
return (VRecType (sortRec lbls))
|
||||
eval env (R as) [] = do as <- mapM (\(lbl,(_,t)) -> fmap ((,) lbl) (newThunk env t)) as
|
||||
return (VR as)
|
||||
eval env (P t lbl) vs = do v <- eval env t []
|
||||
case v of
|
||||
VR as -> case lookup lbl as of
|
||||
Nothing -> evalError ("Missing value for label" <+> pp lbl $$
|
||||
"in" <+> pp (P t lbl))
|
||||
Just tnk -> do v <- force tnk
|
||||
apply v vs
|
||||
v -> return (VP v lbl vs)
|
||||
eval env (ExtR t1 t2) [] = do v1 <- eval env t1 []
|
||||
v2 <- eval env t2 []
|
||||
case (v1,v2) of
|
||||
(VR as1,VR as2) -> return (VR (foldl (\as (lbl,v) -> update lbl v as) as1 as2))
|
||||
(VRecType as1,VRecType as2) -> return (VRecType (foldl (\as (lbl,v) -> update lbl v as) as1 as2))
|
||||
_ -> return (VExtR v1 v2)
|
||||
eval env (Table t1 t2) [] = do v1 <- eval env t1 []
|
||||
v2 <- eval env t2 []
|
||||
return (VTable v1 v2)
|
||||
eval env (T (TTyped ty) cs)[]=do vty <- eval env ty []
|
||||
return (VT vty env cs)
|
||||
eval env (T (TWild ty) cs) []=do vty <- eval env ty []
|
||||
return (VT vty env cs)
|
||||
eval env (V ty ts) [] = do vty <- eval env ty []
|
||||
tnks <- mapM (newThunk env) ts
|
||||
return (VV vty tnks)
|
||||
eval env (S t1 t2) vs = do v1 <- eval env t1 []
|
||||
tnk2 <- newThunk env t2
|
||||
let v0 = VS v1 tnk2 vs
|
||||
case v1 of
|
||||
VT _ env cs -> patternMatch v0 (map (\(p,t) -> (env,[p],tnk2:vs,t)) cs)
|
||||
VV vty tnks -> do ty <- value2term (map fst env) vty
|
||||
vtableSelect v0 ty tnks tnk2 vs
|
||||
v1 -> return v0
|
||||
eval env (Let (x,(_,t1)) t2) vs = do tnk <- newThunk env t1
|
||||
eval ((x,tnk):env) t2 vs
|
||||
eval env (Q q@(m,id)) vs
|
||||
| m == cPredef = do vs' <- mapM force vs
|
||||
mb_res <- evalPredef id vs'
|
||||
case mb_res of
|
||||
Const res -> return res
|
||||
RunTime -> return (VApp q vs)
|
||||
NonExist -> return (VApp (cPredef,cNonExist) [])
|
||||
| otherwise = do t <- getResDef q
|
||||
eval env t vs
|
||||
eval env (QC q) vs = return (VApp q vs)
|
||||
eval env (C t1 t2) [] = do v1 <- eval env t1 []
|
||||
v2 <- eval env t2 []
|
||||
case (v1,v2) of
|
||||
(v1, VEmpty) -> return v1
|
||||
(VEmpty,v2 ) -> return v2
|
||||
_ -> return (VC v1 v2)
|
||||
eval env t@(Glue t1 t2) [] = do v1 <- eval env t1 []
|
||||
v2 <- eval env t2 []
|
||||
let glue VEmpty v = v
|
||||
glue (VC v1 v2) v = VC v1 (glue v2 v)
|
||||
glue (VApp q []) v
|
||||
| q == (cPredef,cNonExist) = VApp q []
|
||||
glue v VEmpty = v
|
||||
glue v (VC v1 v2) = VC (glue v v1) v2
|
||||
glue v (VApp q [])
|
||||
| q == (cPredef,cNonExist) = VApp q []
|
||||
glue (VStr s1) (VStr s2) = VStr (s1++s2)
|
||||
glue v (VAlts d vas) = VAlts (glue v d) [(glue v v',ss) | (v',ss) <- vas]
|
||||
glue (VAlts d vas) (VStr s) = pre d vas s
|
||||
glue (VAlts d vas) v = glue d v
|
||||
glue v1 v2 = VGlue v1 v2
|
||||
|
||||
pre vd [] s = glue vd (VStr s)
|
||||
pre vd ((v,VStrs ss):vas) s
|
||||
| or [startsWith s' s | VStr s' <- ss] = glue v (VStr s)
|
||||
| otherwise = pre vd vas s
|
||||
|
||||
return (glue v1 v2)
|
||||
eval env (EPatt min max p) [] = return (VPatt min max p)
|
||||
eval env (EPattType t) [] = do v <- eval env t []
|
||||
return (VPattType v)
|
||||
eval env (ELincat c ty) [] = do v <- eval env ty []
|
||||
let lbl = lockLabel c
|
||||
lv = VRecType []
|
||||
case v of
|
||||
(VRecType as) -> return (VRecType (update lbl lv as))
|
||||
_ -> return (VExtR v (VRecType [(lbl,lv)]))
|
||||
eval env (ELin c t) [] = do v <- eval env t []
|
||||
let lbl = lockLabel c
|
||||
tnk <- newEvaluatedThunk (VR [])
|
||||
case v of
|
||||
(VR as) -> return (VR (update lbl tnk as))
|
||||
_ -> return (VExtR v (VR [(lbl,tnk)]))
|
||||
eval env (FV ts) vs = msum [eval env t vs | t <- ts]
|
||||
eval env (Alts d as) [] = do vd <- eval env d []
|
||||
vas <- forM as $ \(t,s) -> do
|
||||
vt <- eval env t []
|
||||
vs <- eval env s []
|
||||
return (vt,vs)
|
||||
return (VAlts vd vas)
|
||||
eval env (Strs ts) [] = do vs <- mapM (\t -> eval env t []) ts
|
||||
return (VStrs vs)
|
||||
eval env (TSymCat d r rs) []= do rs <- forM rs $ \(i,(pv,ty)) ->
|
||||
case lookup pv env of
|
||||
Just tnk -> return (i,(tnk,ty))
|
||||
Nothing -> evalError ("Variable" <+> pp pv <+> "is not in scope")
|
||||
return (VSymCat d r rs)
|
||||
eval env (TSymVar d r) [] = do return (VSymVar d r)
|
||||
eval env t vs = evalError ("Cannot reduce term" <+> pp t)
|
||||
|
||||
apply (VMeta m vs0) vs = return (VMeta m (vs0++vs))
|
||||
apply (VSusp m k vs0) vs = return (VSusp m k (vs0++vs))
|
||||
apply (VApp f vs0) vs = return (VApp f (vs0++vs))
|
||||
apply (VGen i vs0) vs = return (VGen i (vs0++vs))
|
||||
apply (VClosure env (Abs b x t)) (v:vs) = eval ((x,v):env) t vs
|
||||
apply v [] = return v
|
||||
|
||||
evalPredef id [v]
|
||||
| id == cLength = case value2string v of
|
||||
Const s -> return (Const (VInt (genericLength s)))
|
||||
_ -> return RunTime
|
||||
evalPredef id [v1,v2]
|
||||
| id == cTake = return (fmap string2value (liftA2 genericTake (value2int v1) (value2string v2)))
|
||||
evalPredef id [v1,v2]
|
||||
| id == cDrop = return (fmap string2value (liftA2 genericDrop (value2int v1) (value2string v2)))
|
||||
evalPredef id [v1,v2]
|
||||
| id == cTk = return (fmap string2value (liftA2 genericTk (value2int v1) (value2string v2)))
|
||||
where
|
||||
genericTk n = reverse . genericDrop n . reverse
|
||||
evalPredef id [v1,v2]
|
||||
| id == cDp = return (fmap string2value (liftA2 genericDp (value2int v1) (value2string v2)))
|
||||
where
|
||||
genericDp n = reverse . genericTake n . reverse
|
||||
evalPredef id [v]
|
||||
| id == cIsUpper= return (fmap toPBool (liftA (all isUpper) (value2string v)))
|
||||
evalPredef id [v]
|
||||
| id == cToUpper= return (fmap string2value (liftA (map toUpper) (value2string v)))
|
||||
evalPredef id [v]
|
||||
| id == cToLower= return (fmap string2value (liftA (map toLower) (value2string v)))
|
||||
evalPredef id [v1,v2]
|
||||
| id == cEqStr = return (fmap toPBool (liftA2 (==) (value2string v1) (value2string v2)))
|
||||
evalPredef id [v1,v2]
|
||||
| id == cOccur = return (fmap toPBool (liftA2 occur (value2string v1) (value2string v2)))
|
||||
evalPredef id [v1,v2]
|
||||
| id == cOccurs = return (fmap toPBool (liftA2 occurs (value2string v1) (value2string v2)))
|
||||
evalPredef id [v1,v2]
|
||||
| id == cEqInt = return (fmap toPBool (liftA2 (==) (value2int v1) (value2int v2)))
|
||||
evalPredef id [v1,v2]
|
||||
| id == cLessInt= return (fmap toPBool (liftA2 (<) (value2int v1) (value2int v2)))
|
||||
evalPredef id [v1,v2]
|
||||
| id == cPlus = return (fmap VInt (liftA2 (+) (value2int v1) (value2int v2)))
|
||||
evalPredef id [v]
|
||||
| id == cError = case value2string v of
|
||||
Const msg -> fail msg
|
||||
_ -> fail "Indescribable error appeared"
|
||||
evalPredef id vs = return RunTime
|
||||
|
||||
toPBool True = VApp (cPredef,cPTrue) []
|
||||
toPBool False = VApp (cPredef,cPFalse) []
|
||||
|
||||
occur s1 [] = False
|
||||
occur s1 s2@(_:tail) = check s1 s2
|
||||
where
|
||||
check xs [] = False
|
||||
check [] ys = True
|
||||
check (x:xs) (y:ys)
|
||||
| x == y = check xs ys
|
||||
check _ _ = occur s1 tail
|
||||
|
||||
occurs cs s2 = any (\c -> elem c s2) cs
|
||||
|
||||
update lbl v [] = [(lbl,v)]
|
||||
update lbl v (a@(lbl',_):as)
|
||||
| lbl==lbl' = (lbl,v) : as
|
||||
| otherwise = a : update lbl v as
|
||||
|
||||
|
||||
patternMatch v0 [] = return v0
|
||||
patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
|
||||
where
|
||||
match env [] eqs args = eval env t args
|
||||
match env (PT ty p :ps) eqs args = match env (p:ps) eqs args
|
||||
match env (PAlt p1 p2:ps) eqs args = match env (p1:ps) ((env,p2:ps,args,t):eqs) args
|
||||
match env (PM q :ps) eqs args = do t <- getResDef q
|
||||
v <- eval [] t []
|
||||
case v of
|
||||
VPatt _ _ p -> match env (p:ps) eqs args
|
||||
_ -> evalError $ hang "Expected pattern macro:" 4
|
||||
(pp t)
|
||||
match env (PV v :ps) eqs (arg:args) = match ((v,arg):env) ps eqs args
|
||||
match env (PAs v p :ps) eqs (arg:args) = match ((v,arg):env) (p:ps) eqs (arg:args)
|
||||
match env (PW :ps) eqs (arg:args) = match env ps eqs args
|
||||
match env (PTilde _ :ps) eqs (arg:args) = match env ps eqs args
|
||||
match env (p :ps) eqs (arg:args) = do
|
||||
v <- force arg
|
||||
match' env p ps eqs arg v args
|
||||
|
||||
match' env p ps eqs arg v args = do
|
||||
case (p,v) of
|
||||
(p, VMeta i vs) -> susp i (\v -> apply v vs >>= \v -> match' env p ps eqs arg v args)
|
||||
(p, VGen i vs) -> return v0
|
||||
(p, VSusp i k vs) -> susp i (\v -> k v >>= \v -> apply v vs >>= \v -> match' env p ps eqs arg v args)
|
||||
(PP q qs, VApp r tnks)
|
||||
| q == r -> match env (qs++ps) eqs (tnks++args)
|
||||
(PR pas, VR as) -> matchRec env (reverse pas) as ps eqs args
|
||||
(PString s1, VStr s2)
|
||||
| s1 == s2 -> match env ps eqs args
|
||||
(PString s1, VEmpty)
|
||||
| null s1 -> match env ps eqs args
|
||||
(PSeq min1 max1 p1 min2 max2 p2,v)
|
||||
-> case value2string v of
|
||||
Const s -> do let n = length s
|
||||
lo = min1 `max` (n-fromMaybe n max2)
|
||||
hi = (n-min2) `min` fromMaybe n max1
|
||||
(ds,cs) = splitAt lo s
|
||||
eqs <- matchStr env (p1:p2:ps) eqs (hi-lo) (reverse ds) cs args
|
||||
patternMatch v0 eqs
|
||||
RunTime -> return v0
|
||||
NonExist-> patternMatch v0 eqs
|
||||
(PRep minp maxp p, v)
|
||||
-> case value2string v of
|
||||
Const s -> do let n = length s `div` (max minp 1)
|
||||
eqs <- matchRep env n minp maxp p minp maxp p ps ((env,PString []:ps,(arg:args),t) : eqs) (arg:args)
|
||||
patternMatch v0 eqs
|
||||
RunTime -> return v0
|
||||
NonExist-> patternMatch v0 eqs
|
||||
(PChar, VStr [_]) -> match env ps eqs args
|
||||
(PChars cs, VStr [c])
|
||||
| elem c cs -> match env ps eqs args
|
||||
(PInt n, VInt m)
|
||||
| n == m -> match env ps eqs args
|
||||
(PFloat n, VFlt m)
|
||||
| n == m -> match env ps eqs args
|
||||
_ -> patternMatch v0 eqs
|
||||
|
||||
matchRec env [] as ps eqs args = match env ps eqs args
|
||||
matchRec env ((lbl,p):pas) as ps eqs args =
|
||||
case lookup lbl as of
|
||||
Just tnk -> matchRec env pas as (p:ps) eqs (tnk:args)
|
||||
Nothing -> evalError ("Missing value for label" <+> pp lbl)
|
||||
|
||||
matchStr env ps eqs i ds [] args = do
|
||||
arg1 <- newEvaluatedThunk (string2value (reverse ds))
|
||||
arg2 <- newEvaluatedThunk (string2value [])
|
||||
return ((env,ps,arg1:arg2:args,t) : eqs)
|
||||
matchStr env ps eqs 0 ds cs args = do
|
||||
arg1 <- newEvaluatedThunk (string2value (reverse ds))
|
||||
arg2 <- newEvaluatedThunk (string2value cs)
|
||||
return ((env,ps,arg1:arg2:args,t) : eqs)
|
||||
matchStr env ps eqs i ds (c:cs) args = do
|
||||
arg1 <- newEvaluatedThunk (string2value (reverse ds))
|
||||
arg2 <- newEvaluatedThunk (string2value (c:cs))
|
||||
eqs <- matchStr env ps eqs (i-1 :: Int) (c:ds) cs args
|
||||
return ((env,ps,arg1:arg2:args,t) : eqs)
|
||||
|
||||
matchRep env 0 minp maxp p minq maxq q ps eqs args = do
|
||||
return eqs
|
||||
matchRep env n minp maxp p minq maxq q ps eqs args = do
|
||||
matchRep env (n-1) minp maxp p (minp+minq) (liftM2 (+) maxp maxq) (PSeq minp maxp p minq maxq q) ps ((env,q:ps,args,t) : eqs) args
|
||||
|
||||
|
||||
vtableSelect v0 ty tnks tnk2 vs = do
|
||||
v2 <- force tnk2
|
||||
(i,_) <- value2index v2 ty
|
||||
v <- force (tnks !! i)
|
||||
apply v vs
|
||||
where
|
||||
value2index (VR as) (RecType lbls) = compute lbls
|
||||
where
|
||||
compute [] = return (0,1)
|
||||
compute ((lbl,ty):lbls) = do
|
||||
case lookup lbl as of
|
||||
Just tnk -> do v <- force tnk
|
||||
(r, cnt ) <- value2index v ty
|
||||
(r',cnt') <- compute lbls
|
||||
return (r*cnt'+r',cnt*cnt')
|
||||
Nothing -> evalError ("Missing value for label" <+> pp lbl $$
|
||||
"among" <+> hsep (punctuate (pp ',') (map fst as)))
|
||||
value2index (VApp q tnks) ty = do
|
||||
(r ,ctxt,cnt ) <- getIdxCnt q
|
||||
(r', cnt') <- compute ctxt tnks
|
||||
return (r+r',cnt)
|
||||
where
|
||||
getIdxCnt q = do
|
||||
(_,ResValue (L _ ty) idx) <- getInfo q
|
||||
let (ctxt,QC p) = typeFormCnc ty
|
||||
(_,ResParam _ (Just (_,cnt))) <- getInfo p
|
||||
return (idx,ctxt,cnt)
|
||||
|
||||
compute [] [] = return (0,1)
|
||||
compute ((_,_,ty):ctxt) (tnk:tnks) = do
|
||||
v <- force tnk
|
||||
(r, cnt ) <- value2index v ty
|
||||
(r',cnt') <- compute ctxt tnks
|
||||
return (r*cnt'+r',cnt*cnt')
|
||||
value2index (VInt n) ty
|
||||
| Just max <- isTypeInts ty = return (fromIntegral n,fromIntegral max+1)
|
||||
value2index (VMeta i vs) ty = do
|
||||
v <- susp i (\v -> apply v vs)
|
||||
value2index v ty
|
||||
value2index (VSusp i k vs) ty = do
|
||||
v <- susp i (\v -> k v >>= \v -> apply v vs)
|
||||
value2index v ty
|
||||
value2index v ty = do t <- value2term [] v
|
||||
evalError ("the parameter:" <+> ppTerm Unqualified 0 t $$
|
||||
"cannot be evaluated at compile time.")
|
||||
|
||||
|
||||
susp i ki = EvalM $ \gr k mt d r msgs -> do
|
||||
s <- readSTRef i
|
||||
case s of
|
||||
Narrowing id (QC q) -> case lookupOrigInfo gr q of
|
||||
Ok (m,ResParam (Just (L _ ps)) _) -> bindParam gr k mt d r msgs s m ps
|
||||
Bad msg -> return (Fail (pp msg) msgs)
|
||||
Narrowing id ty
|
||||
| Just max <- isTypeInts ty
|
||||
-> bindInt gr k mt d r msgs s 0 max
|
||||
Evaluated _ v -> case ki v of
|
||||
EvalM f -> f gr k mt d r msgs
|
||||
_ -> k (VSusp i ki []) mt d r msgs
|
||||
where
|
||||
bindParam gr k mt d r msgs s m [] = return (Success r msgs)
|
||||
bindParam gr k mt d r msgs s m ((p, ctxt):ps) = do
|
||||
(mt',tnks) <- mkArgs mt ctxt
|
||||
let v = VApp (m,p) tnks
|
||||
writeSTRef i (Evaluated 0 v)
|
||||
res <- case ki v of
|
||||
EvalM f -> f gr k mt' d r msgs
|
||||
writeSTRef i s
|
||||
case res of
|
||||
Fail msg msgs -> return (Fail msg msgs)
|
||||
Success r msgs -> bindParam gr k mt d r msgs s m ps
|
||||
|
||||
mkArgs mt [] = return (mt,[])
|
||||
mkArgs mt ((_,_,ty):ctxt) = do
|
||||
let i = case Map.maxViewWithKey mt of
|
||||
Just ((i,_),_) -> i+1
|
||||
_ -> 0
|
||||
tnk <- newSTRef (Narrowing i ty)
|
||||
(mt,tnks) <- mkArgs (Map.insert i tnk mt) ctxt
|
||||
return (mt,tnk:tnks)
|
||||
|
||||
bindInt gr k mt d r msgs s iv max
|
||||
| iv <= max = do
|
||||
let v = VInt iv
|
||||
writeSTRef i (Evaluated 0 v)
|
||||
res <- case ki v of
|
||||
EvalM f -> f gr k mt d r msgs
|
||||
writeSTRef i s
|
||||
case res of
|
||||
Fail msg msgs -> return (Fail msg msgs)
|
||||
Success r msgs -> bindInt gr k mt d r msgs s (iv+1) max
|
||||
| otherwise = return (Success r msgs)
|
||||
|
||||
|
||||
value2term xs (VApp q tnks) =
|
||||
foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (if fst q == cPredef then Q q else QC q) tnks
|
||||
value2term xs (VMeta m vs) = do
|
||||
s <- getRef m
|
||||
case s of
|
||||
Evaluated _ v -> do v <- apply v vs
|
||||
value2term xs v
|
||||
Unevaluated env t -> do v <- eval env t vs
|
||||
value2term xs v
|
||||
Hole i -> foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (Meta i) vs
|
||||
Residuation i _ ctr -> case ctr of
|
||||
Just ctr -> value2term xs ctr
|
||||
Nothing -> foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (Meta i) vs
|
||||
Narrowing i _ -> foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (Meta i) vs
|
||||
value2term xs (VSusp j k vs) = do
|
||||
v <- k (VGen maxBound vs)
|
||||
value2term xs v
|
||||
value2term xs (VGen j tnks) =
|
||||
foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (Vr (reverse xs !! j)) tnks
|
||||
value2term xs (VClosure env (Abs b x t)) = do
|
||||
tnk <- newEvaluatedThunk (VGen (length xs) [])
|
||||
v <- eval ((x,tnk):env) t []
|
||||
let x' = mkFreshVar xs x
|
||||
t <- value2term (x':xs) v
|
||||
return (Abs b x' t)
|
||||
value2term xs (VProd b x v1 v2)
|
||||
| x == identW = do t1 <- value2term xs v1
|
||||
v2 <- case v2 of
|
||||
VClosure env t2 -> eval env t2 []
|
||||
v2 -> return v2
|
||||
t2 <- value2term xs v2
|
||||
return (Prod b x t1 t2)
|
||||
| otherwise = do t1 <- value2term xs v1
|
||||
tnk <- newEvaluatedThunk (VGen (length xs) [])
|
||||
v2 <- case v2 of
|
||||
VClosure env t2 -> eval ((x,tnk):env) t2 []
|
||||
v2 -> return v2
|
||||
t2 <- value2term (x:xs) v2
|
||||
return (Prod b (mkFreshVar xs x) t1 t2)
|
||||
value2term xs (VRecType lbls) = do
|
||||
lbls <- mapM (\(lbl,v) -> fmap ((,) lbl) (value2term xs v)) lbls
|
||||
return (RecType lbls)
|
||||
value2term xs (VR as) = do
|
||||
as <- mapM (\(lbl,tnk) -> fmap (\t -> (lbl,(Nothing,t))) (tnk2term xs tnk)) as
|
||||
return (R as)
|
||||
value2term xs (VP v lbl tnks) = do
|
||||
t <- value2term xs v
|
||||
foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (P t lbl) tnks
|
||||
value2term xs (VExtR v1 v2) = do
|
||||
t1 <- value2term xs v1
|
||||
t2 <- value2term xs v2
|
||||
return (ExtR t1 t2)
|
||||
value2term xs (VTable v1 v2) = do
|
||||
t1 <- value2term xs v1
|
||||
t2 <- value2term xs v2
|
||||
return (Table t1 t2)
|
||||
value2term xs (VT vty env cs)= do
|
||||
ty <- value2term xs vty
|
||||
cs <- forM cs $ \(p,t) -> do
|
||||
(_,xs',env') <- pattVars (length xs,xs,env) p
|
||||
v <- eval env' t []
|
||||
t <- value2term xs' v
|
||||
return (p,t)
|
||||
return (T (TTyped ty) cs)
|
||||
value2term xs (VV vty tnks)= do ty <- value2term xs vty
|
||||
ts <- mapM (tnk2term xs) tnks
|
||||
return (V ty ts)
|
||||
value2term xs (VS v1 tnk2 tnks) = do t1 <- value2term xs v1
|
||||
t2 <- tnk2term xs tnk2
|
||||
foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (S t1 t2) tnks
|
||||
value2term xs (VSort s) = return (Sort s)
|
||||
value2term xs (VStr tok) = return (K tok)
|
||||
value2term xs (VInt n) = return (EInt n)
|
||||
value2term xs (VFlt n) = return (EFloat n)
|
||||
value2term xs VEmpty = return Empty
|
||||
value2term xs (VC v1 v2) = do
|
||||
t1 <- value2term xs v1
|
||||
t2 <- value2term xs v2
|
||||
return (C t1 t2)
|
||||
value2term xs (VGlue v1 v2) = do
|
||||
t1 <- value2term xs v1
|
||||
t2 <- value2term xs v2
|
||||
return (Glue t1 t2)
|
||||
value2term xs (VPatt min max p) = return (EPatt min max p)
|
||||
value2term xs (VPattType v) = do t <- value2term xs v
|
||||
return (EPattType t)
|
||||
value2term xs (VAlts vd vas) = do
|
||||
d <- value2term xs vd
|
||||
as <- forM vas $ \(vt,vs) -> do
|
||||
t <- value2term xs vt
|
||||
s <- value2term xs vs
|
||||
return (t,s)
|
||||
return (Alts d as)
|
||||
value2term xs (VStrs vs) = do
|
||||
ts <- mapM (value2term xs) vs
|
||||
return (Strs ts)
|
||||
value2term xs (VCInts (Just i) Nothing) = return (App (Q (cPredef,cInts)) (EInt i))
|
||||
value2term xs (VCInts Nothing (Just j)) = return (App (Q (cPredef,cInts)) (EInt j))
|
||||
value2term xs (VCRecType lctrs) = do
|
||||
ltys <- mapM (\(l,o,ctr) -> value2term xs ctr >>= \ty -> return (l,ty)) lctrs
|
||||
return (RecType ltys)
|
||||
value2term xs (VSymCat d r rs) = return (TSymCat d r [(i,(identW,ty)) | (i,(_,ty)) <- rs])
|
||||
value2term xs v = error (showValue v)
|
||||
|
||||
pattVars st (PP _ ps) = foldM pattVars st ps
|
||||
pattVars st (PV x) = case st of
|
||||
(i,xs,env) -> do tnk <- newEvaluatedThunk (VGen i [])
|
||||
return (i+1,x:xs,(x,tnk):env)
|
||||
pattVars st (PR as) = foldM (\st (_,p) -> pattVars st p) st as
|
||||
pattVars st (PT ty p) = pattVars st p
|
||||
pattVars st (PAs x p) = do st <- case st of
|
||||
(i,xs,env) -> do tnk <- newEvaluatedThunk (VGen i [])
|
||||
return (i+1,x:xs,(x,tnk):env)
|
||||
pattVars st p
|
||||
pattVars st (PImplArg p) = pattVars st p
|
||||
pattVars st (PSeq _ _ p1 _ _ p2) = do st <- pattVars st p1
|
||||
pattVars st p2
|
||||
pattVars st _ = return st
|
||||
|
||||
data ConstValue a
|
||||
= Const a
|
||||
| RunTime
|
||||
| NonExist
|
||||
|
||||
instance Functor ConstValue where
|
||||
fmap f (Const c) = Const (f c)
|
||||
fmap f RunTime = RunTime
|
||||
fmap f NonExist = NonExist
|
||||
|
||||
instance Applicative ConstValue where
|
||||
pure = Const
|
||||
|
||||
(Const f) <*> (Const x) = Const (f x)
|
||||
NonExist <*> _ = NonExist
|
||||
_ <*> NonExist = NonExist
|
||||
RunTime <*> _ = RunTime
|
||||
_ <*> RunTime = RunTime
|
||||
|
||||
#if MIN_VERSION_base(4,10,0)
|
||||
liftA2 f (Const a) (Const b) = Const (f a b)
|
||||
liftA2 f NonExist _ = NonExist
|
||||
liftA2 f _ NonExist = NonExist
|
||||
liftA2 f RunTime _ = RunTime
|
||||
liftA2 f _ RunTime = RunTime
|
||||
#endif
|
||||
|
||||
value2string v = fmap (\(_,ws,_) -> unwords ws) (value2string' v False [] [])
|
||||
|
||||
value2string' (VStr w1) True (w2:ws) qs = Const (False,(w1++w2):ws,qs)
|
||||
value2string' (VStr w) _ ws qs = Const (False,w :ws,qs)
|
||||
value2string' VEmpty b ws qs = Const (b,ws,qs)
|
||||
value2string' (VC v1 v2) b ws qs =
|
||||
case value2string' v2 b ws qs of
|
||||
Const (b,ws,qs) -> value2string' v1 b ws qs
|
||||
res -> res
|
||||
value2string' (VApp q []) b ws qs
|
||||
| q == (cPredef,cNonExist) = NonExist
|
||||
value2string' (VApp q []) b ws qs
|
||||
| q == (cPredef,cSOFT_SPACE) = if null ws
|
||||
then Const (b,ws,q:qs)
|
||||
else Const (b,ws,qs)
|
||||
value2string' (VApp q []) b ws qs
|
||||
| q == (cPredef,cBIND) || q == (cPredef,cSOFT_BIND)
|
||||
= if null ws
|
||||
then Const (True,ws,q:qs)
|
||||
else Const (True,ws,qs)
|
||||
value2string' (VApp q []) b ws qs
|
||||
| q == (cPredef,cCAPIT) = capit ws
|
||||
where
|
||||
capit [] = Const (b,[],q:qs)
|
||||
capit ((c:cs) : ws) = Const (b,(toUpper c : cs) : ws,qs)
|
||||
capit ws = Const (b,ws,qs)
|
||||
value2string' (VApp q []) b ws qs
|
||||
| q == (cPredef,cALL_CAPIT) = all_capit ws
|
||||
where
|
||||
all_capit [] = Const (b,[],q:qs)
|
||||
all_capit (w : ws) = Const (b,map toUpper w : ws,qs)
|
||||
value2string' (VAlts vd vas) b ws qs =
|
||||
case ws of
|
||||
[] -> value2string' vd b ws qs
|
||||
(w:_) -> pre vd vas w b ws qs
|
||||
where
|
||||
pre vd [] w = value2string' vd
|
||||
pre vd ((v,VStrs ss):vas) w
|
||||
| or [startsWith s w | VStr s <- ss] = value2string' v
|
||||
| otherwise = pre vd vas w
|
||||
value2string' _ _ _ _ = RunTime
|
||||
|
||||
startsWith [] _ = True
|
||||
startsWith (x:xs) (y:ys)
|
||||
| x == y = startsWith xs ys
|
||||
startsWith _ _ = False
|
||||
|
||||
|
||||
string2value s = string2value' (words s)
|
||||
|
||||
string2value' [] = VEmpty
|
||||
string2value' [w] = VStr w
|
||||
string2value' (w:ws) = VC (VStr w) (string2value' ws)
|
||||
|
||||
value2int (VInt n) = Const n
|
||||
value2int _ = RunTime
|
||||
|
||||
-----------------------------------------------------------------------
|
||||
-- * Evaluation monad
|
||||
|
||||
type MetaThunks s = Map.Map MetaId (Thunk s)
|
||||
type Cont s r = MetaThunks s -> Int -> r -> [Message] -> ST s (CheckResult r [Message])
|
||||
newtype EvalM s a = EvalM (forall r . Grammar -> (a -> Cont s r) -> Cont s r)
|
||||
|
||||
instance Functor (EvalM s) where
|
||||
fmap f (EvalM g) = EvalM (\gr k -> g gr (k . f))
|
||||
|
||||
instance Applicative (EvalM s) where
|
||||
pure x = EvalM (\gr k -> k x)
|
||||
(EvalM f) <*> (EvalM x) = EvalM (\gr k -> f gr (\f -> x gr (\x -> k (f x))))
|
||||
|
||||
instance Monad (EvalM s) where
|
||||
(EvalM f) >>= g = EvalM (\gr k -> f gr (\x -> case g x of
|
||||
EvalM g -> g gr k))
|
||||
#if !(MIN_VERSION_base(4,13,0))
|
||||
-- Monad(fail) will be removed in GHC 8.8+
|
||||
fail = Fail.fail
|
||||
#endif
|
||||
|
||||
instance Fail.MonadFail (EvalM s) where
|
||||
fail msg = EvalM (\gr k _ _ r msgs -> return (Fail (pp msg) msgs))
|
||||
|
||||
instance Alternative (EvalM s) where
|
||||
empty = EvalM (\gr k _ _ r msgs -> return (Success r msgs))
|
||||
(EvalM f) <|> (EvalM g) = EvalM $ \gr k mt b r msgs -> do
|
||||
res <- f gr k mt b r msgs
|
||||
case res of
|
||||
Fail msg msgs -> return (Fail msg msgs)
|
||||
Success r msgs -> g gr k mt b r msgs
|
||||
|
||||
instance MonadPlus (EvalM s) where
|
||||
|
||||
runEvalM :: Grammar -> (forall s . EvalM s a) -> Check [a]
|
||||
runEvalM gr f = Check $ \(es,ws) ->
|
||||
case runST (case f of
|
||||
EvalM f -> f gr (\x mt _ xs ws -> return (Success (x:xs) ws)) Map.empty maxBound [] ws) of
|
||||
Fail msg ws -> Fail msg (es,ws)
|
||||
Success xs ws -> Success (reverse xs) (es,ws)
|
||||
|
||||
runEvalOneM :: Grammar -> (forall s . EvalM s a) -> Check a
|
||||
runEvalOneM gr f = Check $ \(es,ws) ->
|
||||
case runST (case f of
|
||||
EvalM f -> f gr (\x mt _ xs ws -> return (Success (x:xs) ws)) Map.empty maxBound [] ws) of
|
||||
Fail msg ws -> Fail msg (es,ws)
|
||||
Success [] ws -> Fail (pp "The evaluation produced no results") (es,ws)
|
||||
Success (x:_) ws -> Success x (es,ws)
|
||||
|
||||
evalError :: Message -> EvalM s a
|
||||
evalError msg = EvalM (\gr k _ _ r msgs -> return (Fail msg msgs))
|
||||
|
||||
evalWarn :: Message -> EvalM s ()
|
||||
evalWarn msg = EvalM (\gr k mt d r msgs -> k () mt d r (msg:msgs))
|
||||
|
||||
getResDef :: QIdent -> EvalM s Term
|
||||
getResDef q = EvalM $ \gr k mt d r msgs -> do
|
||||
case lookupResDef gr q of
|
||||
Ok t -> k t mt d r msgs
|
||||
Bad msg -> return (Fail (pp msg) msgs)
|
||||
|
||||
getInfo :: QIdent -> EvalM s (ModuleName,Info)
|
||||
getInfo q = EvalM $ \gr k mt d r msgs -> do
|
||||
case lookupOrigInfo gr q of
|
||||
Ok res -> k res mt d r msgs
|
||||
Bad msg -> return (Fail (pp msg) msgs)
|
||||
|
||||
getResType :: QIdent -> EvalM s Type
|
||||
getResType q = EvalM $ \gr k mt d r msgs -> do
|
||||
case lookupResType gr q of
|
||||
Ok t -> k t mt d r msgs
|
||||
Bad msg -> return (Fail (pp msg) msgs)
|
||||
|
||||
getOverload :: Term -> QIdent -> EvalM s (Term,Type)
|
||||
getOverload t q = EvalM $ \gr k mt d r msgs -> do
|
||||
case lookupOverloadTypes gr q of
|
||||
Ok ttys -> let err = "Overload resolution failed" $$
|
||||
"of term " <+> pp t $$
|
||||
"with types" <+> vcat [ppTerm Terse 0 ty | (_,ty) <- ttys]
|
||||
|
||||
go [] = return (Fail err msgs)
|
||||
go (tty:ttys) = do res <- k tty mt d r msgs
|
||||
case res of
|
||||
Fail _ _ -> return res -- go ttys
|
||||
Success r msgs -> return (Success r msgs)
|
||||
|
||||
in go ttys
|
||||
Bad msg -> return (Fail (pp msg) msgs)
|
||||
|
||||
getAllParamValues :: Type -> EvalM s [Term]
|
||||
getAllParamValues ty = EvalM $ \gr k mt d r msgs ->
|
||||
case allParamValues gr ty of
|
||||
Ok ts -> k ts mt d r msgs
|
||||
Bad msg -> return (Fail (pp msg) msgs)
|
||||
|
||||
newThunk env t = EvalM $ \gr k mt d r msgs -> do
|
||||
tnk <- newSTRef (Unevaluated env t)
|
||||
k tnk mt d r msgs
|
||||
|
||||
newEvaluatedThunk v = EvalM $ \gr k mt d r msgs -> do
|
||||
tnk <- newSTRef (Evaluated maxBound v)
|
||||
k tnk mt d r msgs
|
||||
|
||||
newHole i = EvalM $ \gr k mt d r msgs ->
|
||||
if i == 0
|
||||
then do tnk <- newSTRef (Hole i)
|
||||
k tnk mt d r msgs
|
||||
else case Map.lookup i mt of
|
||||
Just tnk -> k tnk mt d r msgs
|
||||
Nothing -> do tnk <- newSTRef (Hole i)
|
||||
k tnk (Map.insert i tnk mt) d r msgs
|
||||
|
||||
newResiduation scope = EvalM $ \gr k mt d r msgs -> do
|
||||
let i = Map.size mt + 1
|
||||
tnk <- newSTRef (Residuation i scope Nothing)
|
||||
k (i,tnk) (Map.insert i tnk mt) d r msgs
|
||||
|
||||
newNarrowing ty = EvalM $ \gr k mt d r msgs -> do
|
||||
let i = Map.size mt + 1
|
||||
tnk <- newSTRef (Narrowing i ty)
|
||||
k (i,tnk) (Map.insert i tnk mt) d r msgs
|
||||
|
||||
withVar d0 (EvalM f) = EvalM $ \gr k mt d1 r msgs ->
|
||||
let !d = min d0 d1
|
||||
in f gr k mt d r msgs
|
||||
|
||||
getVariables :: EvalM s [(LVar,LIndex)]
|
||||
getVariables = EvalM $ \gr k mt d ws r -> do
|
||||
ps <- metas2params gr (Map.elems mt)
|
||||
k ps mt d ws r
|
||||
where
|
||||
metas2params gr [] = return []
|
||||
metas2params gr (tnk:tnks) = do
|
||||
st <- readSTRef tnk
|
||||
case st of
|
||||
Narrowing i ty -> do let cnt = case allParamValues gr ty of
|
||||
Ok ts -> length ts
|
||||
Bad msg -> error msg
|
||||
params <- metas2params gr tnks
|
||||
if cnt > 1
|
||||
then return ((i-1,cnt):params)
|
||||
else return params
|
||||
_ -> metas2params gr tnks
|
||||
|
||||
getRef tnk = EvalM $ \gr k mt d r msgs -> readSTRef tnk >>= \st -> k st mt d r msgs
|
||||
setRef tnk st = EvalM $ \gr k mt d r msgs -> do
|
||||
old <- readSTRef tnk
|
||||
writeSTRef tnk st
|
||||
res <- k () mt d r msgs
|
||||
writeSTRef tnk old
|
||||
return res
|
||||
|
||||
force tnk = EvalM $ \gr k mt d r msgs -> do
|
||||
s <- readSTRef tnk
|
||||
case s of
|
||||
Unevaluated env t -> case eval env t [] of
|
||||
EvalM f -> f gr (\v mt b r msgs -> do let d = length env
|
||||
writeSTRef tnk (Evaluated d v)
|
||||
r <- k v mt d r msgs
|
||||
writeSTRef tnk s
|
||||
return r) mt d r msgs
|
||||
Evaluated d v -> k v mt d r msgs
|
||||
Hole _ -> k (VMeta tnk []) mt d r msgs
|
||||
Residuation _ _ _ -> k (VMeta tnk []) mt d r msgs
|
||||
Narrowing _ _ -> k (VMeta tnk []) mt d r msgs
|
||||
|
||||
tnk2term xs tnk = EvalM $ \gr k mt d r msgs ->
|
||||
let join f g = do res <- f
|
||||
case res of
|
||||
Fail msg msgs -> return (Fail msg msgs)
|
||||
Success r msgs -> g r msgs
|
||||
|
||||
flush [] k1 mt r msgs = k1 mt r msgs
|
||||
flush [x] k1 mt r msgs = join (k x mt d r msgs) (k1 mt)
|
||||
flush xs k1 mt r msgs = join (k (FV (reverse xs)) mt d r msgs) (k1 mt)
|
||||
|
||||
acc d0 x mt d (r,!c,xs) msgs
|
||||
| d < d0 = flush xs (\mt r msgs -> join (k x mt d r msgs) (\r msgs -> return (Success (r,c+1,[]) msgs))) mt r msgs
|
||||
| otherwise = return (Success (r,c+1,x:xs) msgs)
|
||||
|
||||
in do s <- readSTRef tnk
|
||||
case s of
|
||||
Unevaluated env t -> do let d0 = length env
|
||||
res <- case eval env t [] of
|
||||
EvalM f -> f gr (\v mt d msgs r -> do writeSTRef tnk (Evaluated d0 v)
|
||||
r <- case value2term xs v of
|
||||
EvalM f -> f gr (acc d0) mt d msgs r
|
||||
writeSTRef tnk s
|
||||
return r) mt maxBound (r,0,[]) msgs
|
||||
case res of
|
||||
Fail msg msgs -> return (Fail msg msgs)
|
||||
Success (r,0,xs) msgs -> k (FV []) mt d r msgs
|
||||
Success (r,c,xs) msgs -> flush xs (\mt msgs r -> return (Success msgs r)) mt r msgs
|
||||
Evaluated d0 v -> do res <- case value2term xs v of
|
||||
EvalM f -> f gr (acc d0) mt maxBound (r,0,[]) msgs
|
||||
case res of
|
||||
Fail msg msgs -> return (Fail msg msgs)
|
||||
Success (r,0,xs) msgs -> k (FV []) mt d r msgs
|
||||
Success (r,c,xs) msgs -> flush xs (\mt r msgs -> return (Success r msgs)) mt r msgs
|
||||
Hole i -> k (Meta i) mt d r msgs
|
||||
Residuation i _ _ -> k (Meta i) mt d r msgs
|
||||
Narrowing i _ -> k (Meta i) mt d r msgs
|
||||
|
||||
scopeEnv scope = zipWithM (\x i -> newEvaluatedThunk (VGen i []) >>= \tnk -> return (x,tnk)) (reverse scope) [0..]
|
||||
417
src/compiler/api/GF/Compile/ConcreteToHaskell.hs
Normal file
417
src/compiler/api/GF/Compile/ConcreteToHaskell.hs
Normal file
@@ -0,0 +1,417 @@
|
||||
-- | Translate concrete syntax to Haskell
|
||||
module GF.Compile.ConcreteToHaskell(concretes2haskell,concrete2haskell) where
|
||||
|
||||
import PGF2(Literal(..))
|
||||
import Data.List(isPrefixOf,sort,sortOn)
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as S
|
||||
import GF.Text.Pretty
|
||||
--import GF.Grammar.Predef(cPredef,cInts)
|
||||
--import GF.Compile.Compute.Predef(predef)
|
||||
--import GF.Compile.Compute.Value(Predefined(..))
|
||||
import GF.Infra.Ident(Ident,identC,identS,identW,prefixIdent,showRawIdent,rawIdentS)
|
||||
import GF.Infra.Option
|
||||
import GF.Haskell as H
|
||||
import GF.Grammar.Canonical as C
|
||||
import GF.Compile.GrammarToCanonical
|
||||
import Debug.Trace(trace)
|
||||
|
||||
-- | Generate Haskell code for the all concrete syntaxes associated with
|
||||
-- the named abstract syntax in given the grammar.
|
||||
concretes2haskell opts absname gr = do
|
||||
Grammar abstr cncs <- grammar2canonical opts absname gr
|
||||
return [(filename,render80 $ concrete2haskell opts abstr cncmod)
|
||||
| cncmod<-cncs,
|
||||
let ModId name = concName cncmod
|
||||
filename = showRawIdent name ++ ".hs" :: FilePath
|
||||
]
|
||||
|
||||
-- | Generate Haskell code for the given concrete module.
|
||||
-- The only options that make a difference are
|
||||
-- @-haskell=noprefix@ and @-haskell=variants@.
|
||||
concrete2haskell opts
|
||||
abstr@(Abstract _ _ cats funs)
|
||||
modinfo@(Concrete cnc absname _ ps lcs lns) =
|
||||
haskPreamble absname cnc $$
|
||||
vcat (
|
||||
nl:Comment "--- Parameter types ---":
|
||||
map paramDef ps ++
|
||||
nl:Comment "--- Type signatures for linearization functions ---":
|
||||
map signature cats ++
|
||||
nl:Comment "--- Linearization functions for empty categories ---":
|
||||
emptydefs ++
|
||||
nl:Comment "--- Linearization types ---":
|
||||
map lincatDef lcs ++
|
||||
nl:Comment "--- Linearization functions ---":
|
||||
lindefs ++
|
||||
nl:Comment "--- Type classes for projection functions ---":
|
||||
map labelClass (S.toList labels) ++
|
||||
nl:Comment "--- Record types ---":
|
||||
concatMap recordType recs)
|
||||
where
|
||||
nl = Comment ""
|
||||
recs = S.toList (S.difference (records (lcs,lns)) common_records)
|
||||
|
||||
labels = S.difference (S.unions (map S.fromList recs)) common_labels
|
||||
common_records = S.fromList [[label_s]]
|
||||
common_labels = S.fromList [label_s]
|
||||
label_s = LabelId (rawIdentS "s")
|
||||
|
||||
signature (CatDef c _) = TypeSig lf (Fun abs (pure lin))
|
||||
where
|
||||
abs = tcon0 (prefixIdent "A." (gId c))
|
||||
lin = tcon0 lc
|
||||
lf = linfunName c
|
||||
lc = lincatName c
|
||||
|
||||
emptydefs = map emptydef (S.toList emptyCats)
|
||||
emptydef c = Eqn (linfunName c,[WildP]) (Const "undefined")
|
||||
|
||||
emptyCats = allcats `S.difference` linfuncats
|
||||
where
|
||||
--funcats = S.fromList [c | FunDef f (C.Type _ (TypeApp c _))<-funs]
|
||||
allcats = S.fromList [c | CatDef c _<-cats]
|
||||
|
||||
gId :: ToIdent i => i -> Ident
|
||||
gId = (if haskellOption opts HaskellNoPrefix then id else prefixIdent "G")
|
||||
. toIdent
|
||||
|
||||
va = haskellOption opts HaskellVariants
|
||||
pure = if va then ListT else id
|
||||
|
||||
haskPreamble :: ModId -> ModId -> Doc
|
||||
haskPreamble absname cncname =
|
||||
"{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}" $$
|
||||
"module" <+> cncname <+> "where" $$
|
||||
"import Prelude hiding (Ordering(..))" $$
|
||||
"import Control.Applicative((<$>),(<*>))" $$
|
||||
"import PGF.Haskell" $$
|
||||
"import qualified" <+> absname <+> "as A" $$
|
||||
"" $$
|
||||
"--- Standard definitions ---" $$
|
||||
"linString (A.GString s) ="<+>pure "R_s [TK s]" $$
|
||||
"linInt (A.GInt i) ="<+>pure "R_s [TK (show i)]" $$
|
||||
"linFloat (A.GFloat x) ="<+>pure "R_s [TK (show x)]" $$
|
||||
"" $$
|
||||
"----------------------------------------------------" $$
|
||||
"-- Automatic translation from GF to Haskell follows" $$
|
||||
"----------------------------------------------------"
|
||||
where
|
||||
pure = if va then brackets else pp
|
||||
|
||||
paramDef pd =
|
||||
case pd of
|
||||
ParamAliasDef p t -> H.Type (conap0 (gId p)) (convLinType t)
|
||||
ParamDef p pvs -> Data (conap0 (gId p)) (map paramCon pvs) derive
|
||||
where
|
||||
paramCon (Param c cs) = ConAp (gId c) (map (tcon0.gId) cs)
|
||||
derive = ["Eq","Ord","Show"]
|
||||
|
||||
convLinType = ppT
|
||||
where
|
||||
ppT t =
|
||||
case t of
|
||||
FloatType -> tcon0 (identS "Float")
|
||||
IntType -> tcon0 (identS "Int")
|
||||
ParamType (ParamTypeId p) -> tcon0 (gId p)
|
||||
RecordType rs -> tcon (rcon' ls) (map ppT ts)
|
||||
where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-rs]
|
||||
StrType -> tcon0 (identS "Str")
|
||||
TableType pt lt -> Fun (ppT pt) (ppT lt)
|
||||
-- TupleType lts ->
|
||||
|
||||
lincatDef (LincatDef c t) = tsyn0 (lincatName c) (convLinType t)
|
||||
|
||||
linfuncats = S.fromList linfuncatl
|
||||
(linfuncatl,lindefs) = unzip (linDefs lns)
|
||||
|
||||
linDefs = map eqn . sortOn fst . map linDef
|
||||
where eqn (cat,(f,(ps,rhs))) = (cat,Eqn (f,ps) rhs)
|
||||
|
||||
linDef (LinDef f xs rhs0) =
|
||||
(cat,(linfunName cat,(lhs,rhs)))
|
||||
where
|
||||
lhs = [ConP (aId f) (map VarP abs_args)]
|
||||
aId f = prefixIdent "A." (gId f)
|
||||
|
||||
[lincat] = [lincat | LincatDef c lincat<-lcs,c==cat]
|
||||
[C.Type absctx (TypeApp cat _)] = [t | FunDef f' t<-funs, f'==f]
|
||||
|
||||
abs_args = map abs_arg args
|
||||
abs_arg = prefixIdent "abs_"
|
||||
args = map (prefixIdent "g" . toIdent) xs
|
||||
|
||||
rhs = lets (zipWith letlin args absctx)
|
||||
(convert vs (coerce env lincat rhs0))
|
||||
where
|
||||
vs = [(VarValueId (Unqual x),a)|(VarId x,a)<-zip xs args]
|
||||
env= [(VarValueId (Unqual x),lc)|(VarId x,lc)<-zip xs (map arglincat absctx)]
|
||||
|
||||
letlin a (TypeBinding _ (C.Type _ (TypeApp acat _))) =
|
||||
(a,Ap (Var (linfunName acat)) (Var (abs_arg a)))
|
||||
|
||||
arglincat (TypeBinding _ (C.Type _ (TypeApp acat _))) = lincat
|
||||
where
|
||||
[lincat] = [lincat | LincatDef c lincat<-lcs,c==acat]
|
||||
|
||||
convert = convert' va
|
||||
|
||||
convert' va vs = ppT
|
||||
where
|
||||
ppT0 = convert' False vs
|
||||
ppTv vs' = convert' va vs'
|
||||
|
||||
pure = if va then single else id
|
||||
|
||||
ppT t =
|
||||
case t of
|
||||
TableValue ty cs -> pure (table cs)
|
||||
Selection t p -> select (ppT t) (ppT p)
|
||||
ConcatValue t1 t2 -> concat (ppT t1) (ppT t2)
|
||||
RecordValue r -> aps (rcon ls) (map ppT ts)
|
||||
where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-r]
|
||||
PredefValue p -> single (Var (toIdent p)) -- hmm
|
||||
Projection t l -> ap (proj l) (ppT t)
|
||||
VariantValue [] -> empty
|
||||
VariantValue ts@(_:_) -> variants ts
|
||||
VarValue x -> maybe (Var (gId x)) (pure . Var) $ lookup x vs
|
||||
PreValue vs t' -> pure (alts t' vs)
|
||||
ParamConstant (Param c vs) -> aps (Var (pId c)) (map ppT vs)
|
||||
ErrorValue s -> ap (Const "error") (Const (show s)) -- !!
|
||||
LiteralValue l -> ppL l
|
||||
_ -> error ("convert "++show t)
|
||||
|
||||
ppL l =
|
||||
case l of
|
||||
LFlt x -> pure (lit x)
|
||||
LInt n -> pure (lit n)
|
||||
LStr s -> pure (token s)
|
||||
|
||||
pId p@(ParamId s) =
|
||||
if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack
|
||||
|
||||
table cs =
|
||||
if all (null.patVars) ps
|
||||
then lets ds (LambdaCase [(ppP p,t')|(p,t')<-zip ps ts'])
|
||||
else LambdaCase (map ppCase cs)
|
||||
where
|
||||
(ds,ts') = dedup ts
|
||||
(ps,ts) = unzip [(p,t)|TableRow p t<-cs]
|
||||
ppCase (TableRow p t) = (ppP p,ppTv (patVars p++vs) t)
|
||||
{-
|
||||
ppPredef n =
|
||||
case predef n of
|
||||
Ok BIND -> single (c "BIND")
|
||||
Ok SOFT_BIND -> single (c "SOFT_BIND")
|
||||
Ok SOFT_SPACE -> single (c "SOFT_SPACE")
|
||||
Ok CAPIT -> single (c "CAPIT")
|
||||
Ok ALL_CAPIT -> single (c "ALL_CAPIT")
|
||||
_ -> Var n
|
||||
-}
|
||||
ppP p =
|
||||
case p of
|
||||
ParamPattern (Param c ps) -> ConP (gId c) (map ppP ps)
|
||||
RecordPattern r -> ConP (rcon' ls) (map ppP ps)
|
||||
where (ls,ps) = unzip $ sortOn fst [(l,p)|RecordRow l p<-r]
|
||||
WildPattern -> WildP
|
||||
|
||||
token s = single (c "TK" `Ap` lit s)
|
||||
|
||||
alts t' vs = single (c "TP" `Ap` List (map alt vs) `Ap` ppT0 t')
|
||||
where
|
||||
alt (s,t) = Pair (List (pre s)) (ppT0 t)
|
||||
pre s = map lit s
|
||||
|
||||
c = Const
|
||||
lit s = c (show s) -- hmm
|
||||
concat = if va then concat' else plusplus
|
||||
where
|
||||
concat' (List [List ts1]) (List [List ts2]) = List [List (ts1++ts2)]
|
||||
concat' t1 t2 = Op t1 "+++" t2
|
||||
|
||||
pure' = single -- forcing the list monad
|
||||
|
||||
select = if va then select' else Ap
|
||||
select' (List [t]) (List [p]) = Op t "!" p
|
||||
select' (List [t]) p = Op t "!$" p
|
||||
select' t p = Op t "!*" p
|
||||
|
||||
ap = if va then ap' else Ap
|
||||
where
|
||||
ap' (List [f]) x = fmap f x
|
||||
ap' f x = Op f "<*>" x
|
||||
fmap f (List [x]) = pure' (Ap f x)
|
||||
fmap f x = Op f "<$>" x
|
||||
|
||||
-- join = if va then join' else id
|
||||
join' (List [x]) = x
|
||||
join' x = c "concat" `Ap` x
|
||||
|
||||
empty = if va then List [] else c "error" `Ap` c (show "empty variant")
|
||||
variants = if va then \ ts -> join' (List (map ppT ts))
|
||||
else \ (t:_) -> ppT t
|
||||
|
||||
aps f [] = f
|
||||
aps f (a:as) = aps (ap f a) as
|
||||
|
||||
dedup ts =
|
||||
if M.null dups
|
||||
then ([],map ppT ts)
|
||||
else ([(ev i,ppT t)|(i,t)<-defs],zipWith entry ts is)
|
||||
where
|
||||
entry t i = maybe (ppT t) (Var . ev) (M.lookup i dups)
|
||||
ev i = identS ("e'"++show i)
|
||||
|
||||
defs = [(i1,t)|(t,i1:_:_)<-ms]
|
||||
dups = M.fromList [(i2,i1)|(_,i1:is@(_:_))<-ms,i2<-i1:is]
|
||||
ms = M.toList m
|
||||
m = fmap sort (M.fromListWith (++) (zip ts [[i]|i<-is]))
|
||||
is = [0..]::[Int]
|
||||
|
||||
|
||||
--con = Cn . identS
|
||||
|
||||
class Records t where
|
||||
records :: t -> S.Set [LabelId]
|
||||
|
||||
instance Records t => Records [t] where
|
||||
records = S.unions . map records
|
||||
|
||||
instance (Records t1,Records t2) => Records (t1,t2) where
|
||||
records (t1,t2) = S.union (records t1) (records t2)
|
||||
|
||||
instance Records LincatDef where
|
||||
records (LincatDef _ lt) = records lt
|
||||
|
||||
instance Records LinDef where
|
||||
records (LinDef _ _ lv) = records lv
|
||||
|
||||
instance Records LinType where
|
||||
records t =
|
||||
case t of
|
||||
RecordType r -> rowRecords r
|
||||
TableType pt lt -> records (pt,lt)
|
||||
TupleType ts -> records ts
|
||||
_ -> S.empty
|
||||
|
||||
rowRecords r = S.insert (sort ls) (records ts)
|
||||
where (ls,ts) = unzip [(l,t)|RecordRow l t<-r]
|
||||
|
||||
instance Records LinValue where
|
||||
records v =
|
||||
case v of
|
||||
ConcatValue v1 v2 -> records (v1,v2)
|
||||
ParamConstant (Param c vs) -> records vs
|
||||
RecordValue r -> rowRecords r
|
||||
TableValue t r -> records (t,r)
|
||||
TupleValue vs -> records vs
|
||||
VariantValue vs -> records vs
|
||||
PreValue alts d -> records (map snd alts,d)
|
||||
Projection v l -> records v
|
||||
Selection v1 v2 -> records (v1,v2)
|
||||
_ -> S.empty
|
||||
|
||||
instance Records rhs => Records (TableRow rhs) where
|
||||
records (TableRow _ v) = records v
|
||||
|
||||
|
||||
-- | Record subtyping is converted into explicit coercions in Haskell
|
||||
coerce env ty t =
|
||||
case (ty,t) of
|
||||
(_,VariantValue ts) -> VariantValue (map (coerce env ty) ts)
|
||||
(TableType ti tv,TableValue _ cs) ->
|
||||
TableValue ti [TableRow p (coerce env tv t)|TableRow p t<-cs]
|
||||
(RecordType rt,RecordValue r) ->
|
||||
RecordValue [RecordRow l (coerce env ft f) |
|
||||
RecordRow l f<-r,ft<-[ft | RecordRow l' ft <- rt, l'==l]]
|
||||
(RecordType rt,VarValue x)->
|
||||
case lookup x env of
|
||||
Just ty' | ty'/=ty -> -- better to compare to normal form of ty'
|
||||
--trace ("coerce "++render ty'++" to "++render ty) $
|
||||
app (to_rcon rt) [t]
|
||||
| otherwise -> t -- types match, no coercion needed
|
||||
_ -> trace (render ("missing type to coerce"<+>x<+>"to"<+>render ty
|
||||
$$ "in" <+> map fst env))
|
||||
t
|
||||
_ -> t
|
||||
where
|
||||
app f ts = ParamConstant (Param f ts) -- !! a hack
|
||||
to_rcon = ParamId . Unqual . rawIdentS . to_rcon' . labels
|
||||
|
||||
patVars p = []
|
||||
|
||||
labels r = [l | RecordRow l _ <- r]
|
||||
|
||||
proj = Var . identS . proj'
|
||||
proj' (LabelId l) = "proj_" ++ showRawIdent l
|
||||
rcon = Var . rcon'
|
||||
rcon' = identS . rcon_name
|
||||
rcon_name ls = "R"++concat (sort ['_':showRawIdent l | LabelId l <- ls])
|
||||
to_rcon' = ("to_"++) . rcon_name
|
||||
|
||||
recordType ls =
|
||||
Data lhs [app] ["Eq","Ord","Show"]:
|
||||
enumAllInstance:
|
||||
zipWith projection vs ls ++
|
||||
[Eqn (identS (to_rcon' ls),[VarP r])
|
||||
(foldl Ap (Var cn) [Var (identS (proj' l)) `Ap` Var r|l<-ls])]
|
||||
where
|
||||
r = identS "r"
|
||||
cn = rcon' ls
|
||||
-- Not all record labels are syntactically correct as type variables in Haskell
|
||||
-- app = cn<+>ls
|
||||
lhs = ConAp cn vs -- don't reuse record labels
|
||||
app = fmap TId lhs
|
||||
tapp = foldl TAp (TId cn) (map TId vs)
|
||||
vs = [identS ('t':show i)|i<-[1..n]]
|
||||
n = length ls
|
||||
|
||||
projection v l = Instance [] (TId name `TAp` tapp `TAp` TId v)
|
||||
[((prj,[papp]),Var v)]
|
||||
where
|
||||
name = identS ("Has_"++render l)
|
||||
prj = identS (proj' l)
|
||||
papp = ConP cn (map VarP vs)
|
||||
|
||||
enumAllInstance =
|
||||
Instance ctx (tEnumAll `TAp` tapp)[(lhs0 "enumAll",enumCon cn n)]
|
||||
where
|
||||
ctx = [tEnumAll `TAp` TId v|v<-vs]
|
||||
tEnumAll = TId (identS "EnumAll")
|
||||
|
||||
labelClass l =
|
||||
Class [] (ConAp name [r,a]) [([r],[a])]
|
||||
[(identS (proj' l),TId r `Fun` TId a)]
|
||||
where
|
||||
name = identS ("Has_"++render l)
|
||||
r = identS "r"
|
||||
a = identS "a"
|
||||
|
||||
enumCon name arity =
|
||||
if arity==0
|
||||
then single (Var name)
|
||||
else foldl ap (single (Var name)) (replicate arity (Const "enumAll"))
|
||||
where
|
||||
ap (List [f]) a = Op f "<$>" a
|
||||
ap f a = Op f "<*>" a
|
||||
|
||||
lincatName,linfunName :: CatId -> Ident
|
||||
lincatName c = prefixIdent "Lin" (toIdent c)
|
||||
linfunName c = prefixIdent "lin" (toIdent c)
|
||||
|
||||
class ToIdent i where toIdent :: i -> Ident
|
||||
|
||||
instance ToIdent ParamId where toIdent (ParamId q) = qIdentC q
|
||||
instance ToIdent PredefId where toIdent (PredefId s) = identC s
|
||||
instance ToIdent CatId where toIdent (CatId s) = identC s
|
||||
instance ToIdent C.FunId where toIdent (FunId s) = identC s
|
||||
instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentC q
|
||||
|
||||
qIdentC = identS . unqual
|
||||
|
||||
unqual (Qual (ModId m) n) = showRawIdent m++"_"++ showRawIdent n
|
||||
unqual (Unqual n) = showRawIdent n
|
||||
|
||||
instance ToIdent VarId where
|
||||
toIdent Anonymous = identW
|
||||
toIdent (VarId s) = identC s
|
||||
70
src/compiler/api/GF/Compile/ExampleBased.hs
Normal file
70
src/compiler/api/GF/Compile/ExampleBased.hs
Normal file
@@ -0,0 +1,70 @@
|
||||
module GF.Compile.ExampleBased (
|
||||
parseExamplesInGrammar,
|
||||
configureExBased
|
||||
) where
|
||||
|
||||
import PGF2
|
||||
import Data.List
|
||||
|
||||
parseExamplesInGrammar :: ExConfiguration -> FilePath -> IO (FilePath,[String])
|
||||
parseExamplesInGrammar conf file = do
|
||||
src <- readFile file -- .gfe
|
||||
let file' = take (length file - 3) file ++ "gf" -- .gf
|
||||
ws <- convertFile conf src file'
|
||||
return (file',ws)
|
||||
|
||||
convertFile :: ExConfiguration -> String -> FilePath -> IO [String]
|
||||
convertFile conf src file = do
|
||||
writeFile file "" -- "-- created by example-based grammar writing in GF\n"
|
||||
conv [] src
|
||||
where
|
||||
conv ws s = do
|
||||
(cex,end) <- findExample s
|
||||
if null end then return (nub (sort ws)) else do
|
||||
ws2 <- convEx cex
|
||||
conv (ws2 ++ ws) end
|
||||
findExample s = case s of
|
||||
'%':'e':'x':cs -> return $ getExample cs
|
||||
c:cs -> appf [c] >> findExample cs
|
||||
_ -> return (undefined,s)
|
||||
getExample s =
|
||||
let
|
||||
(cat,exend) = break (=='"') s
|
||||
(ex, end) = break (=='"') (tail exend)
|
||||
in ((unwords (words cat),ex), tail end) -- quotes ignored
|
||||
pgf = resource_pgf conf
|
||||
lang = language conf
|
||||
convEx (cat,ex) = do
|
||||
appn "("
|
||||
let typ = maybe (error "no valid cat") id $ readType cat
|
||||
ws <- case parse lang typ ex of
|
||||
ParseFailed _ _ -> do
|
||||
appv ("WARNING: cannot parse example " ++ ex)
|
||||
return []
|
||||
ParseIncomplete ->
|
||||
return []
|
||||
ParseOk ts ->
|
||||
case ts of
|
||||
(t:tt) -> do
|
||||
if null tt
|
||||
then return ()
|
||||
else appv ("WARNING: ambiguous example " ++ ex)
|
||||
appn (printExp conf (fst t))
|
||||
mapM_ (appn . (" --- " ++) . printExp conf . fst) tt
|
||||
appn ")"
|
||||
return []
|
||||
return ws
|
||||
appf = appendFile file
|
||||
appn s = appf s >> appf "\n"
|
||||
appv s = appn ("--- " ++ s) >> putStrLn s
|
||||
|
||||
data ExConfiguration = ExConf {
|
||||
resource_pgf :: PGF,
|
||||
verbose :: Bool,
|
||||
language :: Concr,
|
||||
printExp :: Expr -> String
|
||||
}
|
||||
|
||||
configureExBased :: PGF -> Concr -> (Expr -> String) -> ExConfiguration
|
||||
configureExBased pgf concr pr = ExConf pgf False concr pr
|
||||
|
||||
61
src/compiler/api/GF/Compile/Export.hs
Normal file
61
src/compiler/api/GF/Compile/Export.hs
Normal file
@@ -0,0 +1,61 @@
|
||||
module GF.Compile.Export where
|
||||
|
||||
import PGF2
|
||||
import GF.Compile.PGFtoHaskell
|
||||
--import GF.Compile.PGFtoAbstract
|
||||
import GF.Compile.PGFtoJava
|
||||
import GF.Infra.Option
|
||||
--import GF.Speech.CFG
|
||||
import GF.Speech.PGFToCFG
|
||||
import GF.Speech.SRGS_ABNF
|
||||
import GF.Speech.SRGS_XML
|
||||
import GF.Speech.JSGF
|
||||
import GF.Speech.GSL
|
||||
import GF.Speech.SRG
|
||||
import GF.Speech.VoiceXML
|
||||
import GF.Speech.SLF
|
||||
import GF.Speech.PrRegExp
|
||||
|
||||
import Data.Maybe
|
||||
import qualified Data.Map as Map
|
||||
import System.FilePath
|
||||
import GF.Text.Pretty
|
||||
|
||||
-- top-level access to code generation
|
||||
|
||||
-- | Export a PGF to the given 'OutputFormat'. For many output formats,
|
||||
-- additional 'Options' can be used to control the output.
|
||||
exportPGF :: Options
|
||||
-> OutputFormat
|
||||
-> PGF
|
||||
-> [(FilePath,String)] -- ^ List of recommended file names and contents.
|
||||
exportPGF opts fmt pgf =
|
||||
case fmt of
|
||||
FmtPGFPretty -> multi "txt" (showPGF)
|
||||
FmtCanonicalGF -> [] -- canon "gf" (render80 . abstract2canonical)
|
||||
FmtCanonicalJson-> []
|
||||
FmtHaskell -> multi "hs" (grammar2haskell opts name)
|
||||
FmtJava -> multi "java" (grammar2java opts name)
|
||||
FmtBNF -> single "bnf" bnfPrinter
|
||||
FmtEBNF -> single "ebnf" (ebnfPrinter opts)
|
||||
FmtSRGS_XML -> single "grxml" (srgsXmlPrinter opts)
|
||||
FmtSRGS_XML_NonRec -> single "grxml" (srgsXmlNonRecursivePrinter opts)
|
||||
FmtSRGS_ABNF -> single "gram" (srgsAbnfPrinter opts)
|
||||
FmtSRGS_ABNF_NonRec -> single "gram" (srgsAbnfNonRecursivePrinter opts)
|
||||
FmtJSGF -> single "jsgf" (jsgfPrinter opts)
|
||||
FmtGSL -> single "gsl" (gslPrinter opts)
|
||||
FmtVoiceXML -> single "vxml" grammar2vxml
|
||||
FmtSLF -> single "slf" slfPrinter
|
||||
FmtRegExp -> single "rexp" regexpPrinter
|
||||
FmtFA -> single "dot" slfGraphvizPrinter
|
||||
FmtLR -> single "dot" (\_ -> graphvizLRAutomaton)
|
||||
where
|
||||
name = fromMaybe (abstractName pgf) (flag optName opts)
|
||||
|
||||
multi :: String -> (PGF -> String) -> [(FilePath,String)]
|
||||
multi ext pr = [(name <.> ext, pr pgf)]
|
||||
|
||||
-- canon ext pr = [("canonical"</>name<.>ext,pr pgf)]
|
||||
|
||||
single :: String -> (PGF -> Concr -> String) -> [(FilePath,String)]
|
||||
single ext pr = [(concreteName cnc <.> ext, pr pgf cnc) | cnc <- Map.elems (languages pgf)]
|
||||
302
src/compiler/api/GF/Compile/GenerateBC.hs
Normal file
302
src/compiler/api/GF/Compile/GenerateBC.hs
Normal file
@@ -0,0 +1,302 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module GF.Compile.GenerateBC(generateByteCode) where
|
||||
|
||||
import GF.Grammar
|
||||
import GF.Grammar.Lookup(lookupAbsDef,lookupFunType)
|
||||
import GF.Data.Operations
|
||||
import PGF2(Literal(..))
|
||||
import PGF2.ByteCode
|
||||
import qualified Data.Map as Map
|
||||
import Data.List(nub,mapAccumL)
|
||||
import Data.Maybe(fromMaybe)
|
||||
|
||||
generateByteCode :: SourceGrammar -> Int -> [L Equation] -> [[Instr]]
|
||||
generateByteCode gr arity eqs =
|
||||
let (bs,instrs) = compileEquations gr arity (arity+1) is
|
||||
(map (\(L _ (ps,t)) -> ([],ps,t)) eqs)
|
||||
Nothing
|
||||
[b]
|
||||
b = if arity == 0 || null eqs
|
||||
then instrs
|
||||
else CHECK_ARGS arity:instrs
|
||||
in reverse bs
|
||||
where
|
||||
is = push_is (arity-1) arity []
|
||||
|
||||
compileEquations :: SourceGrammar -> Int -> Int -> [IVal] -> [([(Ident,IVal)],[Patt],Term)] -> Maybe (Int,CodeLabel) -> [[Instr]] -> ([[Instr]],[Instr])
|
||||
compileEquations gr arity st _ [] fl bs = (bs,mkFail arity st fl)
|
||||
compileEquations gr arity st [] ((vs,[],t):_) fl bs = compileBody gr arity st vs t bs
|
||||
compileEquations gr arity st (i:is) eqs fl bs = whilePP eqs Map.empty
|
||||
where
|
||||
whilePP [] cns = case Map.toList cns of
|
||||
[] -> (bs,[FAIL])
|
||||
(cn:cns) -> let (bs1,instrs1) = compileBranch0 fl bs cn
|
||||
bs2 = foldl (compileBranch fl) bs1 cns
|
||||
bs3 = mkFail arity st fl : bs2
|
||||
in (bs3,[PUSH_FRAME, EVAL (shiftIVal (st+2) i) RecCall] ++ instrs1)
|
||||
whilePP ((vs, PP c ps' : ps, t):eqs) cns = whilePP eqs (Map.insertWith (++) (Q c,length ps') [(vs,ps'++ps,t)] cns)
|
||||
whilePP ((vs, PInt n : ps, t):eqs) cns = whilePP eqs (Map.insertWith (++) (EInt n,0) [(vs,ps,t)] cns)
|
||||
whilePP ((vs, PString s: ps, t):eqs) cns = whilePP eqs (Map.insertWith (++) (K s,0) [(vs,ps,t)] cns)
|
||||
whilePP ((vs, PFloat d : ps, t):eqs) cns = whilePP eqs (Map.insertWith (++) (EFloat d,0) [(vs,ps,t)] cns)
|
||||
whilePP ((vs, PImplArg p:ps, t):eqs) cns = whilePP ((vs,p:ps,t):eqs) cns
|
||||
whilePP ((vs, PT _ p : ps, t):eqs) cns = whilePP ((vs,p:ps,t):eqs) cns
|
||||
whilePP ((vs, PAs x p : ps, t):eqs) cns = whilePP (((x,i):vs,p:ps,t):eqs) cns
|
||||
whilePP eqs cns = case Map.toList cns of
|
||||
[] -> whilePV eqs []
|
||||
(cn:cns) -> let fl1 = Just (st,length bs2)
|
||||
(bs1,instrs1) = compileBranch0 fl1 bs cn
|
||||
bs2 = foldl (compileBranch fl1) bs1 cns
|
||||
(bs3,instrs3) = compileEquations gr arity st (i:is) eqs fl (instrs3:bs2)
|
||||
in (bs3,[PUSH_FRAME, EVAL (shiftIVal (st+2) i) RecCall] ++ instrs1)
|
||||
|
||||
whilePV [] vrs = compileEquations gr arity st is vrs fl bs
|
||||
whilePV ((vs, PV x : ps, t):eqs) vrs = whilePV eqs (((x,i):vs,ps,t) : vrs)
|
||||
whilePV ((vs, PW : ps, t):eqs) vrs = whilePV eqs (( vs,ps,t) : vrs)
|
||||
whilePV ((vs, PTilde _ : ps, t):eqs) vrs = whilePV eqs (( vs,ps,t) : vrs)
|
||||
whilePV ((vs, PImplArg p:ps, t):eqs) vrs = whilePV ((vs,p:ps,t):eqs) vrs
|
||||
whilePV ((vs, PT _ p : ps, t):eqs) vrs = whilePV ((vs,p:ps,t):eqs) vrs
|
||||
whilePV eqs vrs = let fl1 = Just (st,length bs1)
|
||||
(bs1,instrs1) = compileEquations gr arity st is vrs fl1 bs
|
||||
(bs2,instrs2) = compileEquations gr arity st (i:is) eqs fl (instrs2:bs1)
|
||||
in (bs2,instrs1)
|
||||
|
||||
case_instr t =
|
||||
case t of
|
||||
(Q (_,id)) -> CASE (showIdent id)
|
||||
(EInt n) -> CASE_LIT (LInt n)
|
||||
(K s) -> CASE_LIT (LStr s)
|
||||
(EFloat d) -> CASE_LIT (LFlt d)
|
||||
|
||||
saves n = reverse [SAVE i | i <- [0..n-1]]
|
||||
|
||||
compileBranch0 fl bs ((t,n),eqs) =
|
||||
let (bs1,instrs) = compileEquations gr arity (st+n) (push_is (st+n-1) n is) eqs fl bs
|
||||
in (bs1, case_instr t (length bs1) : saves n ++ instrs)
|
||||
|
||||
compileBranch l bs ((t,n),eqs) =
|
||||
let (bs1,instrs) = compileEquations gr arity (st+n) (push_is (st+n-1) n is) eqs fl ((case_instr t (length bs1) : saves n ++ instrs) : bs)
|
||||
in bs1
|
||||
|
||||
mkFail arity st1 Nothing
|
||||
| arity+1 /= st1 = [DROP (st1-arity), FAIL]
|
||||
| otherwise = [FAIL]
|
||||
mkFail arity st1 (Just (st0,l))
|
||||
| st1 /= st0 = [DROP (st1-st0), JUMP l]
|
||||
| otherwise = [JUMP l]
|
||||
|
||||
compileBody gr arity st vs e bs =
|
||||
let eval st fun args
|
||||
| arity == 0 = let (st1,is) = pushArgs (st+2) (reverse args)
|
||||
fun' = shiftIVal st1 fun
|
||||
in [PUSH_FRAME]++is++[EVAL fun' UpdateCall]
|
||||
| otherwise = let (st1,fun',is) = tuckArgs arity st fun args
|
||||
in is++[EVAL fun' (TailCall (st1-length args-1))]
|
||||
(heap,bs1,is) = compileFun gr eval st vs e 0 bs []
|
||||
in (bs1,if heap > 0 then (ALLOC heap : is) else is)
|
||||
|
||||
compileFun gr eval st vs (Abs _ x e) h0 bs args =
|
||||
let (h1,bs1,arg,is1) = compileLambda gr st vs [x] e h0 bs
|
||||
in (h1,bs1,is1++eval st arg args)
|
||||
compileFun gr eval st vs (App e1 e2) h0 bs args =
|
||||
let (h1,bs1,arg,is1) = compileArg gr st vs e2 h0 bs
|
||||
(h2,bs2,is2) = compileFun gr eval st vs e1 h1 bs1 (arg:args)
|
||||
in (h2,bs2,is1++is2)
|
||||
compileFun gr eval st vs (Q (m,id)) h0 bs args =
|
||||
case lookupAbsDef gr m id of
|
||||
Ok (_,Just _)
|
||||
-> (h0,bs,eval st (GLOBAL (showIdent id)) args)
|
||||
_ -> let Ok ty = lookupFunType gr m id
|
||||
(ctxt,_,_) = typeForm ty
|
||||
c_arity = length ctxt
|
||||
n_args = length args
|
||||
is1 = setArgs st args
|
||||
diff = c_arity-n_args
|
||||
in if diff <= 0
|
||||
then if n_args == 0
|
||||
then (h0,bs,eval st (GLOBAL (showIdent id)) [])
|
||||
else let h1 = h0 + 2 + n_args
|
||||
in (h1,bs,PUT_CONSTR (showIdent id):is1++eval st (HEAP h0) [])
|
||||
else let h1 = h0 + 1 + n_args
|
||||
is2 = [SET (FREE_VAR i) | i <- [0..n_args-1]] ++ [SET (ARG_VAR (i+1)) | i <- [0..diff-1]]
|
||||
b = CHECK_ARGS diff :
|
||||
ALLOC (c_arity+2) :
|
||||
PUT_CONSTR (showIdent id) :
|
||||
is2 ++
|
||||
TUCK (ARG_VAR 0) diff :
|
||||
EVAL (HEAP h0) (TailCall diff) :
|
||||
[]
|
||||
in (h1,b:bs,PUT_CLOSURE (length bs):is1++eval st (HEAP h0) [])
|
||||
compileFun gr eval st vs (QC qid) h0 bs args =
|
||||
compileFun gr eval st vs (Q qid) h0 bs args
|
||||
compileFun gr eval st vs (Vr x) h0 bs args =
|
||||
(h0,bs,eval st (getVar vs x) args)
|
||||
compileFun gr eval st vs (EInt n) h0 bs _ =
|
||||
let h1 = h0 + 2
|
||||
in (h1,bs,PUT_LIT (LInt n) : eval st (HEAP h0) [])
|
||||
compileFun gr eval st vs (K s) h0 bs _ =
|
||||
let h1 = h0 + 2
|
||||
in (h1,bs,PUT_LIT (LStr s) : eval st (HEAP h0) [])
|
||||
compileFun gr eval st vs (EFloat d) h0 bs _ =
|
||||
let h1 = h0 + 2
|
||||
in (h1,bs,PUT_LIT (LFlt d) : eval st (HEAP h0) [])
|
||||
compileFun gr eval st vs (Typed e _) h0 bs args =
|
||||
compileFun gr eval st vs e h0 bs args
|
||||
compileFun gr eval st vs (Let (x, (_, e1)) e2) h0 bs args =
|
||||
let (h1,bs1,arg,is1) = compileLambda gr st vs [] e1 h0 bs
|
||||
(h2,bs2,is2) = compileFun gr eval st ((x,arg):vs) e2 h1 bs1 args
|
||||
in (h2,bs2,is1++is2)
|
||||
compileFun gr eval st vs e@(Glue e1 e2) h0 bs args =
|
||||
let eval' st fun args = [PUSH_FRAME]++is++[EVAL fun' RecCall]
|
||||
where
|
||||
(_st1,is) = pushArgs (st+2) (reverse args)
|
||||
fun' = shiftIVal st fun
|
||||
|
||||
flatten (Glue e1 e2) h0 bs =
|
||||
let (h1,bs1,is1) = flatten e1 h0 bs
|
||||
(h2,bs2,is2) = flatten e2 h1 bs1
|
||||
in (h2,bs2,is1++is2)
|
||||
flatten e h0 bs =
|
||||
let (h1,bs1,is1) = compileFun gr eval' (st+3) vs e h0 bs args
|
||||
in (h1,bs1,is1++[ADD])
|
||||
|
||||
(h1,bs1,is) = flatten e h0 bs
|
||||
|
||||
in (h1,bs1,[PUSH_ACCUM (LFlt 0)]++is++[POP_ACCUM]++eval (st+1) (ARG_VAR st) [])
|
||||
compileFun gr eval st vs e _ _ _ = error (show e)
|
||||
|
||||
compileArg gr st vs (Q(m,id)) h0 bs =
|
||||
case lookupAbsDef gr m id of
|
||||
Ok (_,Just _) -> (h0,bs,GLOBAL (showIdent id),[])
|
||||
_ -> let Ok ty = lookupFunType gr m id
|
||||
(ctxt,_,_) = typeForm ty
|
||||
c_arity = length ctxt
|
||||
in if c_arity == 0
|
||||
then (h0,bs,GLOBAL (showIdent id),[])
|
||||
else let is2 = [SET (ARG_VAR (i+1)) | i <- [0..c_arity-1]]
|
||||
b = CHECK_ARGS c_arity :
|
||||
ALLOC (c_arity+2) :
|
||||
PUT_CONSTR (showIdent id) :
|
||||
is2 ++
|
||||
TUCK (ARG_VAR 0) c_arity :
|
||||
EVAL (HEAP h0) (TailCall c_arity) :
|
||||
[]
|
||||
h1 = h0 + 2
|
||||
in (h1,b:bs,HEAP h0,[PUT_CLOSURE (length bs),SET_PAD])
|
||||
compileArg gr st vs (QC qid) h0 bs =
|
||||
compileArg gr st vs (Q qid) h0 bs
|
||||
compileArg gr st vs (Vr x) h0 bs =
|
||||
(h0,bs,getVar vs x,[])
|
||||
compileArg gr st vs (EInt n) h0 bs =
|
||||
let h1 = h0 + 2
|
||||
in (h1,bs,HEAP h0,[PUT_LIT (LInt n)])
|
||||
compileArg gr st vs (K s) h0 bs =
|
||||
let h1 = h0 + 2
|
||||
in (h1,bs,HEAP h0,[PUT_LIT (LStr s)])
|
||||
compileArg gr st vs (EFloat d) h0 bs =
|
||||
let h1 = h0 + 2
|
||||
in (h1,bs,HEAP h0,[PUT_LIT (LFlt d)])
|
||||
compileArg gr st vs (Typed e _) h0 bs =
|
||||
compileArg gr st vs e h0 bs
|
||||
compileArg gr st vs (ImplArg e) h0 bs =
|
||||
compileArg gr st vs e h0 bs
|
||||
compileArg gr st vs e h0 bs =
|
||||
let (f,es) = appForm e
|
||||
isConstr = case f of
|
||||
Q c@(m,id) -> case lookupAbsDef gr m id of
|
||||
Ok (_,Just _) -> Nothing
|
||||
_ -> Just c
|
||||
QC c@(m,id) -> case lookupAbsDef gr m id of
|
||||
Ok (_,Just _) -> Nothing
|
||||
_ -> Just c
|
||||
_ -> Nothing
|
||||
in case isConstr of
|
||||
Just (m,id) ->
|
||||
let Ok ty = lookupFunType gr m id
|
||||
(ctxt,_,_) = typeForm ty
|
||||
c_arity = length ctxt
|
||||
((h1,bs1,is1),args) = mapAccumL (\(h,bs,is) e -> let (h1,bs1,arg,is1) = compileArg gr st vs e h bs
|
||||
in ((h1,bs1,is++is1),arg))
|
||||
(h0,bs,[])
|
||||
es
|
||||
n_args = length args
|
||||
is2 = setArgs st args
|
||||
diff = c_arity-n_args
|
||||
in if diff <= 0
|
||||
then let h2 = h1 + 2 + n_args
|
||||
in (h2,bs1,HEAP h1,is1 ++ (PUT_CONSTR (showIdent id) : is2))
|
||||
else let h2 = h1 + 1 + n_args
|
||||
is2 = [SET (FREE_VAR i) | i <- [0..n_args-1]] ++ [SET (ARG_VAR (i+1)) | i <- [0..diff-1]]
|
||||
b = CHECK_ARGS diff :
|
||||
ALLOC (c_arity+2) :
|
||||
PUT_CONSTR (showIdent id) :
|
||||
is2 ++
|
||||
TUCK (ARG_VAR 0) diff :
|
||||
EVAL (HEAP h0) (TailCall diff) :
|
||||
[]
|
||||
in (h2,b:bs1,HEAP h1,is1 ++ (PUT_CLOSURE (length bs):is2))
|
||||
Nothing -> compileLambda gr st vs [] e h0 bs
|
||||
|
||||
compileLambda gr st vs xs (Abs _ x e) h0 bs =
|
||||
compileLambda gr st vs (x:xs) e h0 bs
|
||||
compileLambda gr st vs xs e h0 bs =
|
||||
let ys = nub (freeVars xs e)
|
||||
arity = length xs
|
||||
(bs1,b) = compileBody gr arity
|
||||
(arity+1)
|
||||
(zip xs (map ARG_VAR [0..]) ++
|
||||
zip ys (map FREE_VAR [0..]))
|
||||
e (b1:bs)
|
||||
b1 = if arity == 0
|
||||
then b
|
||||
else CHECK_ARGS arity:b
|
||||
is = if null ys
|
||||
then [SET_PAD]
|
||||
else map (SET . shiftIVal st . getVar vs) ys
|
||||
h1 = h0 + 1 + length is
|
||||
in (h1,bs1,HEAP h0,PUT_CLOSURE (length bs) : is)
|
||||
|
||||
getVar vs x =
|
||||
case lookup x vs of
|
||||
Just arg -> arg
|
||||
Nothing -> error "compileVar: unknown variable"
|
||||
|
||||
shiftIVal st (ARG_VAR i) = ARG_VAR (st-i-1)
|
||||
shiftIVal st arg = arg
|
||||
|
||||
pushArgs st [] = (st,[])
|
||||
pushArgs st (arg:args) = let (st1,is) = pushArgs (st+1) args
|
||||
in (st1, PUSH (shiftIVal st arg) : is)
|
||||
|
||||
tuckArgs arity st fun args = (st2,shiftIVal st2 fun',is1++is2)
|
||||
where
|
||||
(st2,fun',is2) = tucks st1 0 fun tas
|
||||
(st1,is1) = pushArgs st pas
|
||||
(tas,pas) = splitAt st args'
|
||||
args' = reverse (ARG_VAR arity : args)
|
||||
|
||||
tucks st i fun [] = (st,fun,[])
|
||||
tucks st i fun (arg:args)
|
||||
| arg == ARG_VAR i = tucks st (i+1) fun args
|
||||
| otherwise = case save st (ARG_VAR i) (fun:args) of
|
||||
Just (fun:args) -> let (st1,fun',is) = tucks (st+1) (i+1) fun args
|
||||
in (st1, fun', PUSH (ARG_VAR (st-i-1)) :
|
||||
TUCK (shiftIVal (st+1) arg) (st-i) : is)
|
||||
Nothing -> let (st1,fun',is) = tucks st (i+1) fun args
|
||||
in (st1, fun', TUCK (shiftIVal st arg) (st-i-1) : is)
|
||||
|
||||
save st arg0 [] = Nothing
|
||||
save st arg0 (arg:args)
|
||||
| arg0 == arg = Just (ARG_VAR st1 : fromMaybe args (save st arg0 args))
|
||||
| otherwise = fmap (arg :) (save st arg0 args)
|
||||
|
||||
setArgs st [] = []
|
||||
setArgs st (arg:args) = SET (shiftIVal st arg) : setArgs st args
|
||||
|
||||
freeVars xs (Abs _ x e) = freeVars (x:xs) e
|
||||
freeVars xs (Vr x)
|
||||
| not (elem x xs) = [x]
|
||||
freeVars xs e = collectOp (freeVars xs) e
|
||||
|
||||
push_is :: Int -> Int -> [IVal] -> [IVal]
|
||||
push_is i 0 is = is
|
||||
push_is i n is = ARG_VAR i : push_is (i-1) (n-1) is
|
||||
338
src/compiler/api/GF/Compile/GeneratePMCFG.hs
Normal file
338
src/compiler/api/GF/Compile/GeneratePMCFG.hs
Normal file
@@ -0,0 +1,338 @@
|
||||
{-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : Krasimir Angelov
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- Convert PGF grammar to PMCFG grammar.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Compile.GeneratePMCFG
|
||||
(generatePMCFG, pmcfgForm, type2fields
|
||||
) where
|
||||
|
||||
import GF.Grammar hiding (VApp,VRecType)
|
||||
import GF.Grammar.Predef
|
||||
import GF.Grammar.Lookup
|
||||
import GF.Infra.CheckM
|
||||
import GF.Infra.Option
|
||||
import GF.Text.Pretty
|
||||
import GF.Compile.Compute.Concrete
|
||||
import GF.Data.Operations(Err(..))
|
||||
import PGF2.Transactions
|
||||
import Control.Monad
|
||||
import Control.Monad.State
|
||||
import Control.Monad.ST
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.List(mapAccumL,sortOn,sortBy)
|
||||
import Data.Maybe(fromMaybe,isNothing)
|
||||
import Data.STRef
|
||||
|
||||
generatePMCFG :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
|
||||
generatePMCFG opts cwd gr cmo@(cm,cmi)
|
||||
| mstatus cmi == MSComplete && isModCnc cmi && isNothing (mseqs cmi) =
|
||||
do let gr' = prependModule gr cmo
|
||||
(js,seqs) <- runStateT (Map.traverseWithKey (\id info -> StateT (addPMCFG opts cwd gr' cmi id info)) (jments cmi)) Map.empty
|
||||
return (cm,cmi{jments = js, mseqs=Just (mapToSequence seqs)})
|
||||
| otherwise = return cmo
|
||||
where
|
||||
mapToSequence m = Seq.fromList (map fst (sortOn snd (Map.toList m)))
|
||||
|
||||
type SequenceSet = Map.Map [Symbol] Int
|
||||
|
||||
addPMCFG opts cwd gr cmi id (CncCat mty@(Just (L loc ty)) mdef mref mprn Nothing) seqs = do
|
||||
(defs,seqs) <-
|
||||
case mdef of
|
||||
Nothing -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do
|
||||
term <- mkLinDefault gr ty
|
||||
pmcfgForm gr term [(Explicit,identW,typeStr)] ty seqs
|
||||
Just (L loc term) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do
|
||||
pmcfgForm gr term [(Explicit,identW,typeStr)] ty seqs
|
||||
(refs,seqs) <-
|
||||
case mref of
|
||||
Nothing -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do
|
||||
term <- mkLinReference gr ty
|
||||
pmcfgForm gr term [(Explicit,identW,ty)] typeStr seqs
|
||||
Just (L loc term) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do
|
||||
pmcfgForm gr term [(Explicit,identW,ty)] typeStr seqs
|
||||
mprn <- case mprn of
|
||||
Nothing -> return Nothing
|
||||
Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do
|
||||
prn <- normalForm gr prn
|
||||
return (Just (L loc prn))
|
||||
return (CncCat mty mdef mref mprn (Just (defs,refs)),seqs)
|
||||
addPMCFG opts cwd gr cmi id (CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) seqs = do
|
||||
(rules,seqs) <-
|
||||
checkInModule cwd cmi loc ("Happened in the PMCFG generation for" <+> id) $
|
||||
pmcfgForm gr term ctxt val seqs
|
||||
mprn <- case mprn of
|
||||
Nothing -> return Nothing
|
||||
Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do
|
||||
prn <- normalForm gr prn
|
||||
return (Just (L loc prn))
|
||||
return (CncFun mty mlin mprn (Just rules),seqs)
|
||||
addPMCFG opts cwd gr cmi id info seqs = return (info,seqs)
|
||||
|
||||
pmcfgForm :: Grammar -> Term -> Context -> Type -> SequenceSet -> Check ([Production],SequenceSet)
|
||||
pmcfgForm gr t ctxt ty seqs = do
|
||||
res <- runEvalM gr $ do
|
||||
(_,args) <- mapAccumM (\arg_no (_,_,ty) -> do
|
||||
t <- EvalM (\gr k mt d r msgs -> do (mt,_,t) <- type2metaTerm gr arg_no mt 0 [] ty
|
||||
k t mt d r msgs)
|
||||
tnk <- newThunk [] t
|
||||
return (arg_no+1,tnk))
|
||||
0 ctxt
|
||||
v <- eval [] t args
|
||||
(lins,params) <- flatten v ty ([],[])
|
||||
lins <- fmap reverse $ mapM str2lin lins
|
||||
(r,rs,_) <- compute params
|
||||
args <- zipWithM tnk2lparam args ctxt
|
||||
vars <- getVariables
|
||||
let res = LParam r (order rs)
|
||||
return (vars,args,res,lins)
|
||||
return (runState (mapM mkProduction res) seqs)
|
||||
where
|
||||
tnk2lparam tnk (_,_,ty) = do
|
||||
v <- force tnk
|
||||
(_,params) <- flatten v ty ([],[])
|
||||
(r,rs,_) <- compute params
|
||||
return (PArg [] (LParam r (order rs)))
|
||||
|
||||
compute [] = return (0,[],1)
|
||||
compute ((v,ty):params) = do
|
||||
(r, rs ,cnt ) <- param2int v ty
|
||||
(r',rs',cnt') <- compute params
|
||||
return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
|
||||
|
||||
mkProduction (vars,args,res,lins) = do
|
||||
lins <- mapM getSeqId lins
|
||||
return (Production vars args res lins)
|
||||
where
|
||||
getSeqId :: [Symbol] -> State (Map.Map [Symbol] SeqId) SeqId
|
||||
getSeqId lin = state $ \m ->
|
||||
case Map.lookup lin m of
|
||||
Just seqid -> (seqid,m)
|
||||
Nothing -> let seqid = Map.size m
|
||||
in (seqid,Map.insert lin seqid m)
|
||||
|
||||
type2metaTerm :: SourceGrammar -> Int -> MetaThunks s -> LIndex -> [(LIndex,(Ident,Type))] -> Type -> ST s (MetaThunks s,Int,Term)
|
||||
type2metaTerm gr d ms r rs (Sort s) | s == cStr =
|
||||
return (ms,r+1,TSymCat d r rs)
|
||||
type2metaTerm gr d ms r rs (RecType lbls) = do
|
||||
((ms',r'),ass) <- mapAccumM (\(ms,r) (lbl,ty) -> case lbl of
|
||||
LVar j -> return ((ms,r),(lbl,(Just ty,TSymVar d j)))
|
||||
lbl -> do (ms',r',t) <- type2metaTerm gr d ms r rs ty
|
||||
return ((ms',r'),(lbl,(Just ty,t))))
|
||||
(ms,r) lbls
|
||||
return (ms',r',R ass)
|
||||
type2metaTerm gr d ms r rs (Table p q)
|
||||
| count == 1 = do (ms',r',t) <- type2metaTerm gr d ms r rs q
|
||||
return (ms',r+(r'-r),T (TTyped p) [(PW,t)])
|
||||
| otherwise = do let pv = varX (length rs+1)
|
||||
(ms',delta,t) <-
|
||||
fixST $ \(~(_,delta,_)) ->
|
||||
do (ms',r',t) <- type2metaTerm gr d ms r ((delta,(pv,p)):rs) q
|
||||
return (ms',r'-r,t)
|
||||
return (ms',r+delta*count,T (TTyped p) [(PV pv,t)])
|
||||
where
|
||||
count = case allParamValues gr p of
|
||||
Ok ts -> length ts
|
||||
Bad msg -> error msg
|
||||
type2metaTerm gr d ms r rs ty@(QC q) = do
|
||||
let i = Map.size ms + 1
|
||||
tnk <- newSTRef (Narrowing i ty)
|
||||
return (Map.insert i tnk ms,r,Meta i)
|
||||
type2metaTerm gr d ms r rs ty
|
||||
| Just n <- isTypeInts ty = do
|
||||
let i = Map.size ms + 1
|
||||
tnk <- newSTRef (Narrowing i ty)
|
||||
return (Map.insert i tnk ms,r,Meta i)
|
||||
|
||||
flatten (VR as) (RecType lbls) st = do
|
||||
foldM collect st lbls
|
||||
where
|
||||
collect st (lbl,ty) =
|
||||
case lookup lbl as of
|
||||
Just tnk -> do v <- force tnk
|
||||
flatten v ty st
|
||||
Nothing -> evalError ("Missing value for label" <+> pp lbl $$
|
||||
"among" <+> hsep (punctuate (pp ',') (map fst as)))
|
||||
flatten v@(VT _ env cs) (Table p q) st = do
|
||||
ts <- getAllParamValues p
|
||||
foldM collect st ts
|
||||
where
|
||||
collect st t = do
|
||||
tnk <- newThunk [] t
|
||||
let v0 = VS v tnk []
|
||||
v <- patternMatch v0 (map (\(p,t) -> (env,[p],[tnk],t)) cs)
|
||||
flatten v q st
|
||||
flatten (VV _ tnks) (Table _ q) st = do
|
||||
foldM collect st tnks
|
||||
where
|
||||
collect st tnk = do
|
||||
v <- force tnk
|
||||
flatten v q st
|
||||
flatten v (Sort s) (lins,params) | s == cStr = do
|
||||
deepForce v
|
||||
return (v:lins,params)
|
||||
flatten v ty@(QC q) (lins,params) = do
|
||||
deepForce v
|
||||
return (lins,(v,ty):params)
|
||||
flatten v ty (lins,params)
|
||||
| Just n <- isTypeInts ty = do deepForce v
|
||||
return (lins,(v,ty):params)
|
||||
| otherwise = error (showValue v)
|
||||
|
||||
deepForce (VR as) = mapM_ (\(lbl,v) -> force v >>= deepForce) as
|
||||
deepForce (VApp q tnks) = mapM_ (\tnk -> force tnk >>= deepForce) tnks
|
||||
deepForce (VC v1 v2) = deepForce v1 >> deepForce v2
|
||||
deepForce (VAlts def alts) = do deepForce def
|
||||
mapM_ (\(v,_) -> deepForce v) alts
|
||||
deepForce (VSymCat d r rs) = mapM_ (\(_,(tnk,_)) -> force tnk >>= deepForce) rs
|
||||
deepForce _ = return ()
|
||||
|
||||
str2lin (VApp q [])
|
||||
| q == (cPredef, cBIND) = return [SymBIND]
|
||||
| q == (cPredef, cNonExist) = return [SymNE]
|
||||
| q == (cPredef, cSOFT_BIND) = return [SymSOFT_BIND]
|
||||
| q == (cPredef, cSOFT_SPACE) = return [SymSOFT_SPACE]
|
||||
| q == (cPredef, cCAPIT) = return [SymCAPIT]
|
||||
| q == (cPredef, cALL_CAPIT) = return [SymALL_CAPIT]
|
||||
str2lin (VStr s) = return [SymKS s]
|
||||
str2lin (VSymCat d r rs) = do (r, rs) <- compute r rs
|
||||
return [SymCat d (LParam r (order rs))]
|
||||
where
|
||||
compute r' [] = return (r',[])
|
||||
compute r' ((cnt',(tnk,ty)):tnks) = do
|
||||
v <- force tnk
|
||||
(r, rs, cnt) <- param2int v ty
|
||||
(r',rs') <- compute r' tnks
|
||||
return (r*cnt'+r',combine cnt' rs rs')
|
||||
str2lin (VSymVar d r) = return [SymVar d r]
|
||||
str2lin VEmpty = return []
|
||||
str2lin (VC v1 v2) = liftM2 (++) (str2lin v1) (str2lin v2)
|
||||
str2lin (VAlts def alts) = do def <- str2lin def
|
||||
alts <- forM alts $ \(v,VStrs vs) -> do
|
||||
lin <- str2lin v
|
||||
return (lin,[s | VStr s <- vs])
|
||||
return [SymKP def alts]
|
||||
str2lin v = do t <- value2term [] v
|
||||
evalError ("the string:" <+> ppTerm Unqualified 0 t $$
|
||||
"cannot be evaluated at compile time.")
|
||||
|
||||
param2int (VR as) (RecType lbls) = compute lbls
|
||||
where
|
||||
compute [] = return (0,[],1)
|
||||
compute ((lbl,ty):lbls) = do
|
||||
case lookup lbl as of
|
||||
Just tnk -> do v <- force tnk
|
||||
(r, rs ,cnt ) <- param2int v ty
|
||||
(r',rs',cnt') <- compute lbls
|
||||
return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
|
||||
Nothing -> evalError ("Missing value for label" <+> pp lbl $$
|
||||
"among" <+> hsep (punctuate (pp ',') (map fst as)))
|
||||
param2int (VApp q tnks) ty = do
|
||||
(r , ctxt,cnt ) <- getIdxCnt q
|
||||
(r',rs', cnt') <- compute ctxt tnks
|
||||
return (r+r',rs',cnt)
|
||||
where
|
||||
getIdxCnt q = do
|
||||
(_,ResValue (L _ ty) idx) <- getInfo q
|
||||
let (ctxt,QC p) = typeFormCnc ty
|
||||
(_,ResParam _ (Just (_,cnt))) <- getInfo p
|
||||
return (idx,ctxt,cnt)
|
||||
|
||||
compute [] [] = return (0,[],1)
|
||||
compute ((_,_,ty):ctxt) (tnk:tnks) = do
|
||||
v <- force tnk
|
||||
(r, rs ,cnt ) <- param2int v ty
|
||||
(r',rs',cnt') <- compute ctxt tnks
|
||||
return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
|
||||
param2int (VInt n) ty
|
||||
| Just max <- isTypeInts ty= return (fromIntegral n,[],fromIntegral max+1)
|
||||
param2int (VMeta tnk _) ty = do
|
||||
tnk_st <- getRef tnk
|
||||
case tnk_st of
|
||||
Evaluated _ v -> param2int v ty
|
||||
Narrowing j ty -> do ts <- getAllParamValues ty
|
||||
return (0,[(1,j-1)],length ts)
|
||||
param2int v ty = do t <- value2term [] v
|
||||
evalError ("the parameter:" <+> ppTerm Unqualified 0 t $$
|
||||
"cannot be evaluated at compile time.")
|
||||
|
||||
combine' 1 rs 1 rs' = []
|
||||
combine' 1 rs cnt' rs' = rs'
|
||||
combine' cnt rs 1 rs' = rs
|
||||
combine' cnt rs cnt' rs' = combine cnt' rs rs'
|
||||
|
||||
combine cnt' [] rs' = rs'
|
||||
combine cnt' rs [] = [(r*cnt',pv) | (r,pv) <- rs]
|
||||
combine cnt' ((r,pv):rs) ((r',pv'):rs') =
|
||||
case compare pv pv' of
|
||||
LT -> (r*cnt', pv ) : combine cnt' rs ((r',pv'):rs')
|
||||
EQ -> (r*cnt'+r',pv ) : combine cnt' rs ((r',pv'):rs')
|
||||
GT -> ( r',pv') : combine cnt' ((r,pv):rs) rs'
|
||||
|
||||
order = sortBy (\(r1,_) (r2,_) -> compare r2 r1)
|
||||
|
||||
mapAccumM f a [] = return (a,[])
|
||||
mapAccumM f a (x:xs) = do (a, y) <- f a x
|
||||
(a,ys) <- mapAccumM f a xs
|
||||
return (a,y:ys)
|
||||
|
||||
type2fields :: SourceGrammar -> Type -> [String]
|
||||
type2fields gr = type2fields empty
|
||||
where
|
||||
type2fields d (Sort s) | s == cStr = [show d]
|
||||
type2fields d (RecType lbls) =
|
||||
concatMap (\(lbl,ty) -> type2fields (d <+> pp lbl) ty) lbls
|
||||
type2fields d (Table p q) =
|
||||
let Ok ts = allParamValues gr p
|
||||
in concatMap (\t -> type2fields (d <+> ppTerm Unqualified 5 t) q) ts
|
||||
type2fields d _ = []
|
||||
|
||||
mkLinDefault :: SourceGrammar -> Type -> Check Term
|
||||
mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
|
||||
where
|
||||
mkDefField ty =
|
||||
case ty of
|
||||
Table p t -> do t' <- mkDefField t
|
||||
let T _ cs = mkWildCases t'
|
||||
return $ T (TWild p) cs
|
||||
Sort s | s == cStr -> return (Vr varStr)
|
||||
QC p -> case lookupParamValues gr p of
|
||||
Ok [] -> checkError ("no parameter values given to type" <+> ppQIdent Qualified p)
|
||||
Ok (v:_) -> return v
|
||||
Bad msg -> fail msg
|
||||
RecType r -> do
|
||||
let (ls,ts) = unzip r
|
||||
ts <- mapM mkDefField ts
|
||||
return $ R (zipWith assign ls ts)
|
||||
_ | Just _ <- isTypeInts ty -> return $ EInt 0 -- exists in all as first val
|
||||
_ -> checkError ("a field in a linearization type cannot be" <+> ty)
|
||||
|
||||
mkLinReference :: SourceGrammar -> Type -> Check Term
|
||||
mkLinReference gr typ = do
|
||||
mb_term <- mkRefField typ (Vr varStr)
|
||||
return (Abs Explicit varStr (fromMaybe Empty mb_term))
|
||||
where
|
||||
mkRefField ty trm =
|
||||
case ty of
|
||||
Table pty ty -> case allParamValues gr pty of
|
||||
Ok [] -> checkError ("no parameter values given to type" <+> pty)
|
||||
Ok (p:ps) -> mkRefField ty (S trm p)
|
||||
Bad msg -> fail msg
|
||||
Sort s | s == cStr -> return (Just trm)
|
||||
QC p -> return Nothing
|
||||
RecType rs -> traverse rs trm
|
||||
_ | Just _ <- isTypeInts ty -> return Nothing
|
||||
_ -> checkError ("a field in a linearization type cannot be" <+> typ)
|
||||
|
||||
traverse [] trm = return Nothing
|
||||
traverse ((l,ty):rs) trm = do res <- mkRefField ty (P trm l)
|
||||
case res of
|
||||
Just trm -> return (Just trm)
|
||||
Nothing -> traverse rs trm
|
||||
138
src/compiler/api/GF/Compile/GetGrammar.hs
Normal file
138
src/compiler/api/GF/Compile/GetGrammar.hs
Normal file
@@ -0,0 +1,138 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : GetGrammar
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/11/15 17:56:13 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.16 $
|
||||
--
|
||||
-- this module builds the internal GF grammar that is sent to the type checker
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Compile.GetGrammar (getSourceModule, getBNFCRules, getEBNFRules) where
|
||||
|
||||
import Prelude hiding (catch)
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
import GF.Infra.UseIO
|
||||
import GF.Infra.Option(Options,optPreprocessors,addOptions,renameEncoding,optEncoding,flag,defaultEncoding)
|
||||
import GF.Grammar.Lexer
|
||||
import GF.Grammar.Parser
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.BNFC
|
||||
import GF.Grammar.EBNF
|
||||
import GF.Compile.ReadFiles(parseSource)
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Data.Char(isAscii)
|
||||
import Control.Monad (foldM,when,unless)
|
||||
import System.Process (system)
|
||||
import GF.System.Directory(removeFile,getCurrentDirectory)
|
||||
import System.FilePath(makeRelative)
|
||||
|
||||
--getSourceModule :: Options -> FilePath -> IOE SourceModule
|
||||
-- | Read a source file and parse it (after applying preprocessors specified in the options)
|
||||
getSourceModule opts file0 =
|
||||
--errIn file0 $
|
||||
do tmp <- liftIO $ foldM runPreprocessor (Source file0) (flag optPreprocessors opts)
|
||||
raw <- liftIO $ keepTemp tmp
|
||||
--ePutStrLn $ "1 "++file0
|
||||
(optCoding,parsed) <- parseSource opts pModDef raw
|
||||
case parsed of
|
||||
Left (Pn l c,msg) -> do file <- liftIO $ writeTemp tmp
|
||||
cwd <- getCurrentDirectory
|
||||
let location = makeRelative cwd file++":"++show l++":"++show c
|
||||
raise (location++":\n "++msg)
|
||||
Right (i,mi0) ->
|
||||
do liftIO $ removeTemp tmp
|
||||
let mi =mi0 {mflags=mflags mi0 `addOptions` opts, msrc=file0}
|
||||
case renameEncoding `fmap` flag optEncoding (mflags mi0) of
|
||||
Just coding' ->
|
||||
when (coding/=coding') $
|
||||
raise $ "Encoding mismatch: "++coding++" /= "++coding'
|
||||
where coding = maybe defaultEncoding renameEncoding optCoding
|
||||
_ -> return ()
|
||||
return (i,mi)
|
||||
|
||||
getBNFCRules :: Options -> FilePath -> IOE [BNFCRule]
|
||||
getBNFCRules opts fpath = do
|
||||
raw <- liftIO (BS.readFile fpath)
|
||||
---- debug BS.putStrLn $ raws
|
||||
(optCoding,parsed) <- parseSource opts pBNFCRules raw
|
||||
case parsed of
|
||||
Left _ -> do
|
||||
let ifToChange s ss = if (BS.all (\c -> elem c [' ','\t']) s || BS.last s == ';') then s else ss -- change if not all space or end with ';'
|
||||
let raws = BS.concat $ map (\s -> ifToChange s $ BS.concat [s,BS.singleton ';']) $ BS.split '\n' raw -- add semicolon to each line to be able to parse the format in GF book
|
||||
(optCoding,parseds) <- parseSource opts pBNFCRules raws
|
||||
case parseds of
|
||||
Left (Pn l c,msg) -> do cwd <- getCurrentDirectory
|
||||
let location = makeRelative cwd fpath++":"++show l++":"++show c
|
||||
raise (location++":\n "++msg)
|
||||
Right rules -> return rules
|
||||
Right rules -> return rules
|
||||
|
||||
getEBNFRules :: Options -> FilePath -> IOE [ERule]
|
||||
getEBNFRules opts fpath = do
|
||||
raw <- liftIO (BS.readFile fpath)
|
||||
(optCoding,parsed) <- parseSource opts pEBNFRules raw
|
||||
case parsed of
|
||||
Left (Pn l c,msg) -> do cwd <- getCurrentDirectory
|
||||
let location = makeRelative cwd fpath++":"++show l++":"++show c
|
||||
raise (location++":\n "++msg)
|
||||
Right rules -> return rules
|
||||
|
||||
runPreprocessor :: Temporary -> String -> IO Temporary
|
||||
runPreprocessor tmp0 p =
|
||||
maybe external internal (lookup p builtin_preprocessors)
|
||||
where
|
||||
internal preproc = (Internal . preproc) `fmap` readTemp tmp0
|
||||
external =
|
||||
do file0 <- writeTemp tmp0
|
||||
-- FIXME: should use System.IO.openTempFile
|
||||
let file1a = "_gf_preproc.tmp"
|
||||
file1b = "_gf_preproc2.tmp"
|
||||
-- file0 and file1 must be different
|
||||
file1 = if file0==file1a then file1b else file1a
|
||||
cmd = p +++ file0 ++ ">" ++ file1
|
||||
system cmd
|
||||
return (Temp file1)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
builtin_preprocessors = [("mkPresent",mkPresent),("mkMinimal",mkMinimal)]
|
||||
|
||||
mkPresent = omit_lines "--# notpresent" -- grep -v "\-\-\# notpresent"
|
||||
mkMinimal = omit_lines "--# notminimal" -- grep -v "\-\-\# notminimal"
|
||||
|
||||
omit_lines s = BS.unlines . filter (not . BS.isInfixOf bs) . BS.lines
|
||||
where bs = BS.pack s
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Temporary = Source FilePath | Temp FilePath | Internal BS.ByteString
|
||||
|
||||
writeTemp tmp =
|
||||
case tmp of
|
||||
Source path -> return path
|
||||
Temp path -> return path
|
||||
Internal str -> do -- FIXME: should use System.IO.openTempFile
|
||||
let tmp = "_gf_preproc.tmp"
|
||||
BS.writeFile tmp str
|
||||
return tmp
|
||||
|
||||
readTemp tmp = do str <- keepTemp tmp
|
||||
removeTemp tmp
|
||||
return str
|
||||
|
||||
keepTemp tmp =
|
||||
case tmp of
|
||||
Source path -> BS.readFile path
|
||||
Temp path -> BS.readFile path
|
||||
Internal str -> return str
|
||||
|
||||
removeTemp (Temp path) = removeFile path
|
||||
removeTemp _ = return ()
|
||||
423
src/compiler/api/GF/Compile/GrammarToCanonical.hs
Normal file
423
src/compiler/api/GF/Compile/GrammarToCanonical.hs
Normal file
@@ -0,0 +1,423 @@
|
||||
-- | Translate grammars to Canonical form
|
||||
-- (a common intermediate representation to simplify export to other formats)
|
||||
module GF.Compile.GrammarToCanonical(
|
||||
grammar2canonical,abstract2canonical,concretes2canonical,
|
||||
projection,selection
|
||||
) where
|
||||
import Data.List(nub,partition)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe(fromMaybe)
|
||||
import qualified Data.Set as S
|
||||
import GF.Data.ErrM
|
||||
import GF.Text.Pretty
|
||||
import GF.Grammar.Grammar as G
|
||||
import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
|
||||
import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,composSafeOp,mkAbs,mkApp,term2patt,sortRec)
|
||||
import GF.Grammar.Lockfield(isLockLabel)
|
||||
import GF.Grammar.Predef(cPredef,cInts)
|
||||
import GF.Infra.Ident(ModuleName(..),Ident,identW,ident2raw,rawIdentS,showIdent)
|
||||
import GF.Infra.Option(Options,optionsPGF)
|
||||
import GF.Infra.CheckM
|
||||
import PGF2(Literal(..))
|
||||
import GF.Compile.Compute.Concrete(normalForm)
|
||||
import GF.Grammar.Canonical as C
|
||||
import System.FilePath ((</>), (<.>))
|
||||
import qualified Debug.Trace as T
|
||||
|
||||
|
||||
-- | Generate Canonical code for the named abstract syntax and all associated
|
||||
-- concrete syntaxes
|
||||
grammar2canonical :: Options -> ModuleName -> G.Grammar -> Check C.Grammar
|
||||
grammar2canonical opts absname gr = do
|
||||
abs <- abstract2canonical absname gr
|
||||
cncs <- concretes2canonical opts absname gr
|
||||
return (Grammar abs (map snd cncs))
|
||||
|
||||
-- | Generate Canonical code for the named abstract syntax
|
||||
abstract2canonical :: ModuleName -> G.Grammar -> Check Abstract
|
||||
abstract2canonical absname gr =
|
||||
return (Abstract (modId absname) (convFlags gr absname) cats funs)
|
||||
where
|
||||
cats = [CatDef (gId c) (convCtx ctx) | ((_,c),AbsCat ctx) <- adefs]
|
||||
|
||||
funs = [FunDef (gId f) (convType ty) |
|
||||
((_,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs]
|
||||
|
||||
adefs = allOrigInfos gr absname
|
||||
|
||||
convCtx = maybe [] (map convHypo . unLoc)
|
||||
convHypo (bt,name,t) =
|
||||
case typeForm t of
|
||||
([],(_,cat),[]) -> gId cat -- !!
|
||||
tf -> error ("abstract2canonical convHypo: " ++ show tf)
|
||||
|
||||
convType t =
|
||||
case typeForm t of
|
||||
(hyps,(_,cat),args) -> Type bs (TypeApp (gId cat) as)
|
||||
where
|
||||
bs = map convHypo' hyps
|
||||
as = map convType args
|
||||
|
||||
convHypo' (bt,name,t) = TypeBinding (gId name) (convType t)
|
||||
|
||||
-- | Generate Canonical code for the all concrete syntaxes associated with
|
||||
-- the named abstract syntax in given the grammar.
|
||||
concretes2canonical :: Options -> ModuleName -> G.Grammar -> Check [(FilePath, Concrete)]
|
||||
concretes2canonical opts absname gr =
|
||||
sequence
|
||||
[fmap ((,) cncname) (concrete2canonical gr absname cnc cncmod)
|
||||
| cnc<-allConcretes gr absname,
|
||||
let cncname = "canonical" </> render cnc <.> "gf"
|
||||
Ok cncmod = lookupModule gr cnc
|
||||
]
|
||||
|
||||
-- | Generate Canonical GF for the given concrete module.
|
||||
concrete2canonical :: G.Grammar -> ModuleName -> ModuleName -> ModuleInfo -> Check Concrete
|
||||
concrete2canonical gr absname cnc modinfo = do
|
||||
defs <- fmap concat $ mapM (toCanonical gr absname) (M.toList (jments modinfo))
|
||||
return (Concrete (modId cnc) (modId absname) (convFlags gr cnc)
|
||||
(neededParamTypes S.empty (params defs))
|
||||
[lincat | (_,Left lincat) <- defs]
|
||||
[lin | (_,Right lin) <- defs])
|
||||
where
|
||||
params = S.toList . S.unions . map fst
|
||||
|
||||
neededParamTypes have [] = []
|
||||
neededParamTypes have (q:qs) =
|
||||
if q `S.member` have
|
||||
then neededParamTypes have qs
|
||||
else let ((got,need),def) = paramType gr q
|
||||
in def++neededParamTypes (S.union got have) (S.toList need++qs)
|
||||
|
||||
-- toCanonical :: G.Grammar -> ModuleName -> (Ident, Info) -> [(S.Set QIdent, Either LincatDef LinDef)]
|
||||
toCanonical gr absname (name,jment) =
|
||||
case jment of
|
||||
CncCat (Just (L loc typ)) _ _ pprn _ -> do
|
||||
ntyp <- normalForm gr typ
|
||||
let pts = paramTypes gr ntyp
|
||||
return [(pts,Left (LincatDef (gId name) (convType ntyp)))]
|
||||
CncFun (Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn _ -> do
|
||||
let params = [(b,x)|(b,x,_)<-ctx]
|
||||
args = map snd params
|
||||
e0 <- normalForm gr (mkAbs params (mkApp def (map Vr args)))
|
||||
let e = cleanupRecordFields lincat (unAbs (length params) e0)
|
||||
tts = tableTypes gr [e]
|
||||
return [(tts,Right (LinDef (gId name) (map gId args) (convert gr e)))]
|
||||
AnyInd _ m -> case lookupOrigInfo gr (m,name) of
|
||||
Ok (m,jment) -> toCanonical gr absname (name,jment)
|
||||
_ -> return []
|
||||
_ -> return []
|
||||
where
|
||||
unAbs 0 t = t
|
||||
unAbs n (Abs _ _ t) = unAbs (n-1) t
|
||||
unAbs _ t = t
|
||||
|
||||
tableTypes :: G.Grammar -> [Term] -> S.Set QIdent
|
||||
tableTypes gr ts = S.unions (map tabtys ts)
|
||||
where
|
||||
tabtys t =
|
||||
case t of
|
||||
V t cc -> S.union (paramTypes gr t) (tableTypes gr cc)
|
||||
T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs))
|
||||
_ -> collectOp tabtys t
|
||||
|
||||
paramTypes :: G.Grammar -> G.Type -> S.Set QIdent
|
||||
paramTypes gr t =
|
||||
case t of
|
||||
RecType fs -> S.unions (map (paramTypes gr.snd) fs)
|
||||
Table t1 t2 -> S.union (paramTypes gr t1) (paramTypes gr t2)
|
||||
App tf ta -> S.union (paramTypes gr tf) (paramTypes gr ta)
|
||||
Sort _ -> S.empty
|
||||
EInt _ -> S.empty
|
||||
Q q -> lookup q
|
||||
QC q -> lookup q
|
||||
FV ts -> S.unions (map (paramTypes gr) ts)
|
||||
_ -> ignore
|
||||
where
|
||||
lookup q = case lookupOrigInfo gr q of
|
||||
Ok (_,ResOper _ (Just (L _ t))) ->
|
||||
S.insert q (paramTypes gr t)
|
||||
Ok (_,ResParam {}) -> S.singleton q
|
||||
_ -> ignore
|
||||
|
||||
ignore = T.trace ("Ignore: " ++ show t) S.empty
|
||||
|
||||
-- | Filter out record fields from definitions which don't appear in lincat.
|
||||
cleanupRecordFields :: G.Type -> Term -> Term
|
||||
cleanupRecordFields (RecType ls) (R as) =
|
||||
let defnFields = M.fromList ls
|
||||
in R
|
||||
[ (lbl, (mty, t'))
|
||||
| (lbl, (mty, t)) <- as
|
||||
, M.member lbl defnFields
|
||||
, let Just ty = M.lookup lbl defnFields
|
||||
, let t' = cleanupRecordFields ty t
|
||||
]
|
||||
cleanupRecordFields ty t@(FV _) = composSafeOp (cleanupRecordFields ty) t
|
||||
cleanupRecordFields _ t = t
|
||||
|
||||
convert :: G.Grammar -> Term -> LinValue
|
||||
convert gr = convert' gr []
|
||||
|
||||
convert' :: G.Grammar -> [Ident] -> Term -> LinValue
|
||||
convert' gr vs = ppT
|
||||
where
|
||||
ppT0 = convert' gr vs
|
||||
ppTv vs' = convert' gr vs'
|
||||
|
||||
ppT t =
|
||||
case t of
|
||||
-- Abs b x t -> ...
|
||||
-- V ty ts -> VTableValue (convType ty) (map ppT ts)
|
||||
V ty ts -> TableValue (convType ty) [TableRow (ppP p) (ppT t)|(p,t)<-zip ps ts]
|
||||
where
|
||||
Ok pts = allParamValues gr ty
|
||||
Ok ps = mapM term2patt pts
|
||||
T (TTyped ty) cs -> TableValue (convType ty) (map ppCase cs)
|
||||
S t p -> selection (ppT t) (ppT p)
|
||||
C t1 t2 -> concatValue (ppT t1) (ppT t2)
|
||||
App f a -> ap (ppT f) (ppT a)
|
||||
R r -> RecordValue (fields (sortRec r))
|
||||
P t l -> projection (ppT t) (lblId l)
|
||||
Vr x -> VarValue (gId x)
|
||||
Cn x -> VarValue (gId x) -- hmm
|
||||
Con c -> ParamConstant (Param (gId c) [])
|
||||
Sort k -> VarValue (gId k)
|
||||
EInt n -> LiteralValue (LInt n)
|
||||
Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gQId m n)
|
||||
QC (m,n) -> ParamConstant (Param (gQId m n) [])
|
||||
K s -> LiteralValue (LStr s)
|
||||
Empty -> LiteralValue (LStr "")
|
||||
FV ts -> VariantValue (map ppT ts)
|
||||
Alts t' vs -> alts vs (ppT t')
|
||||
_ -> error $ "convert' ppT: " ++ show t
|
||||
|
||||
ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t)
|
||||
|
||||
ppPredef n = error "TODO: ppPredef" {-
|
||||
case predef n of
|
||||
Ok BIND -> p "BIND"
|
||||
Ok SOFT_BIND -> p "SOFT_BIND"
|
||||
Ok SOFT_SPACE -> p "SOFT_SPACE"
|
||||
Ok CAPIT -> p "CAPIT"
|
||||
Ok ALL_CAPIT -> p "ALL_CAPIT"
|
||||
_ -> VarValue (gQId cPredef n) -- hmm
|
||||
where
|
||||
p = PredefValue . PredefId . rawIdentS
|
||||
-}
|
||||
ppP p =
|
||||
case p of
|
||||
PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
|
||||
PP (m,c) ps -> ParamPattern (Param (gQId m c) (map ppP ps))
|
||||
PR r -> RecordPattern (fields r) {-
|
||||
PW -> WildPattern
|
||||
PV x -> VarP x
|
||||
PString s -> Lit (show s) -- !!
|
||||
PInt i -> Lit (show i)
|
||||
PFloat x -> Lit (show x)
|
||||
PT _ p -> ppP p
|
||||
PAs x p -> AsP x (ppP p) -}
|
||||
_ -> error $ "convert' ppP: " ++ show p
|
||||
where
|
||||
fields = map field . filter (not.isLockLabel.fst)
|
||||
field (l,p) = RecordRow (lblId l) (ppP p)
|
||||
|
||||
-- patToParam p = case ppP p of ParamPattern pv -> pv
|
||||
|
||||
-- token s = single (c "TK" `Ap` lit s)
|
||||
|
||||
alts vs = PreValue (map alt vs)
|
||||
where
|
||||
alt (t,p) = (pre p,ppT0 t)
|
||||
|
||||
pre (K s) = [s]
|
||||
pre Empty = [""] -- Empty == K ""
|
||||
pre (Strs ts) = concatMap pre ts
|
||||
pre (EPatt _ _ p) = pat p
|
||||
pre t = error $ "convert' alts pre: " ++ show t
|
||||
|
||||
pat (PString s) = [s]
|
||||
pat (PAlt p1 p2) = pat p1++pat p2
|
||||
pat (PSeq _ _ p1 _ _ p2) = [s1++s2 | s1<-pat p1, s2<-pat p2]
|
||||
pat p = error $ "convert' alts pat: "++show p
|
||||
|
||||
fields = map field . filter (not.isLockLabel.fst)
|
||||
field (l,(_,t)) = RecordRow (lblId l) (ppT t)
|
||||
--c = Const
|
||||
--c = VarValue . VarValueId
|
||||
--lit s = c (show s) -- hmm
|
||||
|
||||
ap f a = case f of
|
||||
ParamConstant (Param p ps) ->
|
||||
ParamConstant (Param p (ps++[a]))
|
||||
_ -> error $ "convert' ap: "++render (ppA f <+> ppA a)
|
||||
|
||||
concatValue :: LinValue -> LinValue -> LinValue
|
||||
concatValue v1 v2 =
|
||||
case (v1,v2) of
|
||||
(LiteralValue (LStr ""),_) -> v2
|
||||
(_,LiteralValue (LStr "")) -> v1
|
||||
_ -> ConcatValue v1 v2
|
||||
|
||||
-- | Smart constructor for projections
|
||||
projection :: LinValue -> LabelId -> LinValue
|
||||
projection r l = fromMaybe (Projection r l) (proj r l)
|
||||
|
||||
proj :: LinValue -> LabelId -> Maybe LinValue
|
||||
proj r l =
|
||||
case r of
|
||||
RecordValue r -> case [v | RecordRow l' v <- r, l'==l] of
|
||||
[v] -> Just v
|
||||
_ -> Nothing
|
||||
_ -> Nothing
|
||||
|
||||
-- | Smart constructor for selections
|
||||
selection :: LinValue -> LinValue -> LinValue
|
||||
selection t v =
|
||||
-- Note: impossible cases can become possible after grammar transformation
|
||||
case t of
|
||||
TableValue tt r ->
|
||||
case nub [rv | TableRow _ rv <- keep] of
|
||||
[rv] -> rv
|
||||
_ -> Selection (TableValue tt r') v
|
||||
where
|
||||
-- Don't introduce wildcard patterns, true to the canonical format,
|
||||
-- annotate (or eliminate) rhs in impossible rows
|
||||
r' = map trunc r
|
||||
trunc r@(TableRow p e) = if mightMatchRow v r
|
||||
then r
|
||||
else TableRow p (impossible e)
|
||||
{-
|
||||
-- Creates smaller tables, but introduces wildcard patterns
|
||||
r' = if null discard
|
||||
then r
|
||||
else keep++[TableRow WildPattern impossible]
|
||||
-}
|
||||
(keep,discard) = partition (mightMatchRow v) r
|
||||
_ -> Selection t v
|
||||
|
||||
impossible :: LinValue -> LinValue
|
||||
impossible = CommentedValue "impossible"
|
||||
|
||||
mightMatchRow :: LinValue -> TableRow rhs -> Bool
|
||||
mightMatchRow v (TableRow p _) =
|
||||
case p of
|
||||
WildPattern -> True
|
||||
_ -> mightMatch v p
|
||||
|
||||
mightMatch :: LinValue -> LinPattern -> Bool
|
||||
mightMatch v p =
|
||||
case v of
|
||||
ConcatValue _ _ -> False
|
||||
ParamConstant (Param c1 pvs) ->
|
||||
case p of
|
||||
ParamPattern (Param c2 pps) -> c1==c2 && length pvs==length pps &&
|
||||
and [mightMatch v p|(v,p)<-zip pvs pps]
|
||||
_ -> False
|
||||
RecordValue rv ->
|
||||
case p of
|
||||
RecordPattern rp ->
|
||||
and [maybe False (`mightMatch` p) (proj v l) | RecordRow l p<-rp]
|
||||
_ -> False
|
||||
_ -> True
|
||||
|
||||
patVars :: Patt -> [Ident]
|
||||
patVars p =
|
||||
case p of
|
||||
PV x -> [x]
|
||||
PAs x p -> x:patVars p
|
||||
_ -> collectPattOp patVars p
|
||||
|
||||
convType :: Term -> LinType
|
||||
convType = ppT
|
||||
where
|
||||
ppT t =
|
||||
case t of
|
||||
Table ti tv -> TableType (ppT ti) (ppT tv)
|
||||
RecType rt -> RecordType (convFields rt)
|
||||
-- App tf ta -> TAp (ppT tf) (ppT ta)
|
||||
-- FV [] -> tcon0 (identS "({-empty variant-})")
|
||||
Sort k -> convSort k
|
||||
-- EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal
|
||||
FV (t:ts) -> ppT t -- !!
|
||||
QC (m,n) -> ParamType (ParamTypeId (gQId m n))
|
||||
Q (m,n) -> ParamType (ParamTypeId (gQId m n))
|
||||
_ -> error $ "convType ppT: " ++ show t
|
||||
|
||||
convFields = map convField . filter (not.isLockLabel.fst)
|
||||
convField (l,r) = RecordRow (lblId l) (ppT r)
|
||||
|
||||
convSort k = case showIdent k of
|
||||
"Float" -> FloatType
|
||||
"Int" -> IntType
|
||||
"Str" -> StrType
|
||||
_ -> error $ "convType convSort: " ++ show k
|
||||
|
||||
toParamType :: Term -> ParamType
|
||||
toParamType t = case convType t of
|
||||
ParamType pt -> pt
|
||||
_ -> error $ "toParamType: " ++ show t
|
||||
|
||||
toParamId :: Term -> ParamId
|
||||
toParamId t = case toParamType t of
|
||||
ParamTypeId p -> p
|
||||
|
||||
paramType :: G.Grammar
|
||||
-> (ModuleName, Ident)
|
||||
-> ((S.Set (ModuleName, Ident), S.Set QIdent), [ParamDef])
|
||||
paramType gr q@(_,n) =
|
||||
case lookupOrigInfo gr q of
|
||||
Ok (m,ResParam (Just (L _ ps)) _)
|
||||
{- - | m/=cPredef && m/=moduleNameS "Prelude"-} ->
|
||||
((S.singleton (m,n),argTypes ps),
|
||||
[ParamDef name (map (param m) ps)]
|
||||
)
|
||||
where name = gQId m n
|
||||
Ok (m,ResOper _ (Just (L _ t)))
|
||||
| m==cPredef && n==cInts ->
|
||||
((S.empty,S.empty),[]) {-
|
||||
((S.singleton (m,n),S.empty),
|
||||
[Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-}
|
||||
| otherwise ->
|
||||
((S.singleton (m,n),paramTypes gr t),
|
||||
[ParamAliasDef (gQId m n) (convType t)])
|
||||
_ -> ((S.empty,S.empty),[])
|
||||
where
|
||||
param m (n,ctx) = Param (gQId m n) [toParamId t|(_,_,t)<-ctx]
|
||||
argTypes = S.unions . map argTypes1
|
||||
argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
|
||||
|
||||
lblId :: Label -> C.LabelId
|
||||
lblId (LIdent ri) = LabelId ri
|
||||
lblId (LVar i) = LabelId (rawIdentS (show i)) -- hmm
|
||||
|
||||
modId :: ModuleName -> C.ModId
|
||||
modId (MN m) = ModId (ident2raw m)
|
||||
|
||||
class FromIdent i where
|
||||
gId :: Ident -> i
|
||||
|
||||
instance FromIdent VarId where
|
||||
gId i = if i == identW then Anonymous else VarId (ident2raw i)
|
||||
|
||||
instance FromIdent C.FunId where gId = C.FunId . ident2raw
|
||||
instance FromIdent CatId where gId = CatId . ident2raw
|
||||
instance FromIdent ParamId where gId = ParamId . unqual
|
||||
instance FromIdent VarValueId where gId = VarValueId . unqual
|
||||
|
||||
class FromIdent i => QualIdent i where
|
||||
gQId :: ModuleName -> Ident -> i
|
||||
|
||||
instance QualIdent ParamId where gQId m n = ParamId (qual m n)
|
||||
instance QualIdent VarValueId where gQId m n = VarValueId (qual m n)
|
||||
|
||||
qual :: ModuleName -> Ident -> QualId
|
||||
qual m n = Qual (modId m) (ident2raw n)
|
||||
|
||||
unqual :: Ident -> QualId
|
||||
unqual n = Unqual (ident2raw n)
|
||||
|
||||
convFlags :: G.Grammar -> ModuleName -> Flags
|
||||
convFlags gr mn =
|
||||
Flags [(rawIdentS n,v) |
|
||||
(n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]
|
||||
461
src/compiler/api/GF/Compile/GrammarToPGF.hs
Normal file
461
src/compiler/api/GF/Compile/GrammarToPGF.hs
Normal file
@@ -0,0 +1,461 @@
|
||||
{-# LANGUAGE BangPatterns, FlexibleContexts, MagicHash #-}
|
||||
module GF.Compile.GrammarToPGF (grammar2PGF) where
|
||||
|
||||
import GF.Compile.GeneratePMCFG
|
||||
import GF.Compile.GenerateBC
|
||||
import GF.Compile.OptimizePGF
|
||||
|
||||
import PGF2 hiding (mkType)
|
||||
import PGF2.Transactions
|
||||
import GF.Grammar.Predef
|
||||
import GF.Grammar.Grammar hiding (Production)
|
||||
import qualified GF.Grammar.Lookup as Look
|
||||
import qualified GF.Grammar as A
|
||||
import qualified GF.Grammar.Macros as GM
|
||||
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Option
|
||||
import GF.Infra.UseIO (IOE)
|
||||
import GF.Data.Operations
|
||||
|
||||
import Control.Monad(forM_,foldM)
|
||||
import Data.List
|
||||
import Data.Char
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.IntMap as IntMap
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Array.IArray
|
||||
import Data.Maybe(fromMaybe)
|
||||
import System.FilePath
|
||||
import System.Directory
|
||||
|
||||
grammar2PGF :: Options -> Maybe PGF -> SourceGrammar -> ModuleName -> Map.Map PGF2.Fun Double -> IO PGF
|
||||
grammar2PGF opts mb_pgf gr am probs = do
|
||||
let abs_name = mi2i am
|
||||
pgf <- case mb_pgf of
|
||||
Just pgf | abstractName pgf == abs_name ->
|
||||
do return pgf
|
||||
_ | snd (flag optLinkTargets opts) ->
|
||||
do let fname = maybe id (</>)
|
||||
(flag optOutputDir opts)
|
||||
(fromMaybe abs_name (flag optName opts)<.>"ngf")
|
||||
exists <- doesFileExist fname
|
||||
if exists
|
||||
then removeFile fname
|
||||
else return ()
|
||||
putStr ("(Boot image "++fname++") ")
|
||||
newNGF abs_name (Just fname) 0
|
||||
| otherwise ->
|
||||
do newNGF abs_name Nothing 0
|
||||
|
||||
pgf <- modifyPGF pgf $ do
|
||||
sequence_ [setAbstractFlag name value | (name,value) <- optionsPGF aflags]
|
||||
sequence_ [createCategory c ctxt p | (c,ctxt,p) <- cats]
|
||||
sequence_ [createFunction f ty arity bcode p | (f,ty,arity,bcode,p) <- funs]
|
||||
forM_ (allConcretes gr am) $ \cm ->
|
||||
createConcrete (mi2i cm) $ do
|
||||
let cflags = err (const noOptions) mflags (lookupModule gr cm)
|
||||
sequence_ [setConcreteFlag name value | (name,value) <- optionsPGF cflags]
|
||||
let infos = ( Seq.fromList [Left [SymCat 0 (LParam 0 [])]]
|
||||
, let id_prod = Production [] [PArg [] (LParam 0 [])] (LParam 0 []) [0]
|
||||
prods = ([id_prod],[id_prod])
|
||||
in [(cInt, CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
|
||||
,(cString,CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
|
||||
,(cFloat, CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
|
||||
]
|
||||
)
|
||||
: prepareSeqTbls (Look.allOrigInfos gr cm)
|
||||
infos <- processInfos createCncCats infos
|
||||
infos <- processInfos createCncFuns infos
|
||||
return ()
|
||||
return pgf
|
||||
where
|
||||
aflags = err (const noOptions) mflags (lookupModule gr am)
|
||||
|
||||
adefs =
|
||||
[((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++
|
||||
Look.allOrigInfos gr am
|
||||
|
||||
toLogProb = realToFrac . negate . log
|
||||
|
||||
cats = [(c', snd (mkContext [] cont), toLogProb (fromMaybe 0 (Map.lookup c' probs))) |
|
||||
((m,c),AbsCat (Just (L _ cont))) <- adefs, let c' = i2i c]
|
||||
|
||||
funs = [(f', mkType [] ty, arity, bcode, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) |
|
||||
((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs,
|
||||
let arity = mkArity ma mdef ty,
|
||||
let bcode = mkDef gr arity mdef,
|
||||
let f' = i2i f]
|
||||
|
||||
funs_probs = (Map.fromList . concat . Map.elems . fmap pad . Map.fromListWith (++))
|
||||
[(i2i cat,[(i2i f,Map.lookup f' probs)]) | ((m,f),AbsFun (Just (L _ ty)) _ _ _) <- adefs,
|
||||
let (_,(_,cat),_) = GM.typeForm ty,
|
||||
let f' = i2i f]
|
||||
where
|
||||
pad :: [(a,Maybe Double)] -> [(a,Double)]
|
||||
pad pfs = [(f,fromMaybe deflt mb_p) | (f,mb_p) <- pfs]
|
||||
where
|
||||
deflt = case length [f | (f,Nothing) <- pfs] of
|
||||
0 -> 0
|
||||
n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n)
|
||||
|
||||
prepareSeqTbls infos =
|
||||
(map addSeqTable . Map.toList . Map.fromListWith (++))
|
||||
[(m,[(c,info)]) | ((m,c),info) <- infos]
|
||||
where
|
||||
addSeqTable (m,infos) =
|
||||
case lookupModule gr m of
|
||||
Ok mi -> case mseqs mi of
|
||||
Just seqs -> (fmap Left seqs,infos)
|
||||
Nothing -> (Seq.empty,[])
|
||||
Bad msg -> error msg
|
||||
|
||||
processInfos f [] = return []
|
||||
processInfos f ((seqtbl,infos):rest) = do
|
||||
seqtbl <- foldM f seqtbl infos
|
||||
rest <- processInfos f rest
|
||||
return ((seqtbl,infos):rest)
|
||||
|
||||
createCncCats seqtbl (c,CncCat (Just (L _ ty)) _ _ mprn (Just (lindefs,linrefs))) = do
|
||||
seqtbl <- createLincat (i2i c) (type2fields gr ty) lindefs linrefs seqtbl
|
||||
case mprn of
|
||||
Nothing -> return ()
|
||||
Just (L _ prn) -> setPrintName (i2i c) (unwords (term2tokens prn))
|
||||
return seqtbl
|
||||
createCncCats seqtbl _ = return seqtbl
|
||||
|
||||
createCncFuns seqtbl (f,CncFun _ _ mprn (Just prods)) = do
|
||||
seqtbl <- createLin (i2i f) prods seqtbl
|
||||
case mprn of
|
||||
Nothing -> return ()
|
||||
Just (L _ prn) -> setPrintName (i2i f) (unwords (term2tokens prn))
|
||||
return seqtbl
|
||||
createCncFuns seqtbl _ = return seqtbl
|
||||
|
||||
term2tokens (K tok) = [tok]
|
||||
term2tokens (C t1 t2) = term2tokens t1 ++ term2tokens t2
|
||||
term2tokens (Typed t _) = term2tokens t
|
||||
term2tokens _ = []
|
||||
|
||||
i2i :: Ident -> String
|
||||
i2i = showIdent
|
||||
|
||||
mi2i :: ModuleName -> String
|
||||
mi2i (MN i) = i2i i
|
||||
|
||||
mkType :: [Ident] -> A.Type -> PGF2.Type
|
||||
mkType scope t =
|
||||
case GM.typeForm t of
|
||||
(hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps
|
||||
in DTyp hyps' (i2i cat) (map (mkExp scope') args)
|
||||
|
||||
mkExp :: [Ident] -> A.Term -> Expr
|
||||
mkExp scope t =
|
||||
case t of
|
||||
Q (_,c) -> EFun (i2i c)
|
||||
QC (_,c) -> EFun (i2i c)
|
||||
Vr x -> case lookup x (zip scope [0..]) of
|
||||
Just i -> EVar i
|
||||
Nothing -> EMeta 0
|
||||
Abs b x t-> EAbs b (i2i x) (mkExp (x:scope) t)
|
||||
App t1 t2-> EApp (mkExp scope t1) (mkExp scope t2)
|
||||
EInt i -> ELit (LInt (fromIntegral i))
|
||||
EFloat f -> ELit (LFlt f)
|
||||
K s -> ELit (LStr s)
|
||||
Meta i -> EMeta i
|
||||
_ -> EMeta 0
|
||||
{-
|
||||
mkPatt scope p =
|
||||
case p of
|
||||
A.PP (_,c) ps->let (scope',ps') = mapAccumL mkPatt scope ps
|
||||
in (scope',C.PApp (i2i c) ps')
|
||||
A.PV x -> (x:scope,C.PVar (i2i x))
|
||||
A.PAs x p -> let (scope',p') = mkPatt scope p
|
||||
in (x:scope',C.PAs (i2i x) p')
|
||||
A.PW -> ( scope,C.PWild)
|
||||
A.PInt i -> ( scope,C.PLit (C.LInt (fromIntegral i)))
|
||||
A.PFloat f -> ( scope,C.PLit (C.LFlt f))
|
||||
A.PString s -> ( scope,C.PLit (C.LStr s))
|
||||
A.PImplArg p-> let (scope',p') = mkPatt scope p
|
||||
in (scope',C.PImplArg p')
|
||||
A.PTilde t -> ( scope,C.PTilde (mkExp scope t))
|
||||
-}
|
||||
|
||||
mkContext :: [Ident] -> A.Context -> ([Ident],[PGF2.Hypo])
|
||||
mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
|
||||
in if x == identW
|
||||
then ( scope,(bt,i2i x,ty'))
|
||||
else (x:scope,(bt,i2i x,ty'))) scope hyps
|
||||
|
||||
mkDef gr arity (Just eqs) = generateByteCode gr arity eqs
|
||||
mkDef gr arity Nothing = []
|
||||
|
||||
mkArity (Just a) _ ty = a -- known arity, i.e. defined function
|
||||
mkArity Nothing (Just _) ty = 0 -- defined function with no arity - must be an axiom
|
||||
mkArity Nothing _ ty = let (ctxt, _, _) = GM.typeForm ty -- constructor
|
||||
in length ctxt
|
||||
{-
|
||||
genCncCats gr am cm cdefs = mkCncCats 0 cdefs
|
||||
where
|
||||
mkCncCats index [] = (index,[])
|
||||
mkCncCats index (((m,id),CncCat (Just (L _ lincat)) _ _ _ _):cdefs)
|
||||
| id == cInt =
|
||||
let cc = pgfCncCat gr (i2i id) lincat fidInt
|
||||
(index',cats) = mkCncCats index cdefs
|
||||
in (index', cc : cats)
|
||||
| id == cFloat =
|
||||
let cc = pgfCncCat gr (i2i id) lincat fidFloat
|
||||
(index',cats) = mkCncCats index cdefs
|
||||
in (index', cc : cats)
|
||||
| id == cString =
|
||||
let cc = pgfCncCat gr (i2i id) lincat fidString
|
||||
(index',cats) = mkCncCats index cdefs
|
||||
in (index', cc : cats)
|
||||
| otherwise =
|
||||
let cc@(_, _s, e, _) = pgfCncCat gr (i2i id) lincat index
|
||||
(index',cats) = mkCncCats (e+1) cdefs
|
||||
in (index', cc : cats)
|
||||
mkCncCats index (_ :cdefs) = mkCncCats index cdefs
|
||||
|
||||
genCncFuns :: Grammar
|
||||
-> ModuleName
|
||||
-> ModuleName
|
||||
-> Array SeqId [Symbol]
|
||||
-> ([Symbol] -> [Symbol] -> Ordering)
|
||||
-> Array SeqId [Symbol]
|
||||
-> [(QIdent, Info)]
|
||||
-> FId
|
||||
-> Map.Map PGF2.Cat (Int,Int)
|
||||
-> (FId,
|
||||
[(FId, [Production])],
|
||||
[(FId, [FunId])],
|
||||
[(FId, [FunId])],
|
||||
[(PGF2.Fun,[SeqId])])
|
||||
genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccat_ranges =
|
||||
let (fid_cnt1,funs_cnt1,funs1,lindefs,linrefs) = mkCncCats cdefs fid_cnt 0 [] IntMap.empty IntMap.empty
|
||||
(fid_cnt2,funs_cnt2,funs2,prods0) = mkCncFuns cdefs fid_cnt1 funs_cnt1 funs1 lindefs Map.empty IntMap.empty
|
||||
prods = [(fid,Set.toList prodSet) | (fid,prodSet) <- IntMap.toList prods0]
|
||||
in (fid_cnt2,prods,IntMap.toList lindefs,IntMap.toList linrefs,reverse funs2)
|
||||
where
|
||||
mkCncCats [] fid_cnt funs_cnt funs lindefs linrefs =
|
||||
(fid_cnt,funs_cnt,funs,lindefs,linrefs)
|
||||
mkCncCats (((m,id),CncCat _ _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs linrefs =
|
||||
let !funs_cnt' = let (s_funid, e_funid) = bounds funs0
|
||||
in funs_cnt+(e_funid-s_funid+1)
|
||||
lindefs' = foldl' (toLinDef (am,id) funs_cnt) lindefs prods0
|
||||
linrefs' = foldl' (toLinRef (am,id) funs_cnt) linrefs prods0
|
||||
funs' = foldl' (toCncFun funs_cnt (m,mkLinDefId id)) funs (assocs funs0)
|
||||
in mkCncCats cdefs fid_cnt funs_cnt' funs' lindefs' linrefs'
|
||||
mkCncCats (_ :cdefs) fid_cnt funs_cnt funs lindefs linrefs =
|
||||
mkCncCats cdefs fid_cnt funs_cnt funs lindefs linrefs
|
||||
|
||||
mkCncFuns [] fid_cnt funs_cnt funs lindefs crc prods =
|
||||
(fid_cnt,funs_cnt,funs,prods)
|
||||
mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs crc prods =
|
||||
let ty_C = err error (\x -> x) $ fmap GM.typeForm (Look.lookupFunType gr am id)
|
||||
!funs_cnt' = let (s_funid, e_funid) = bounds funs0
|
||||
in funs_cnt+(e_funid-s_funid+1)
|
||||
!(fid_cnt',crc',prods')
|
||||
= foldl' (toProd lindefs ty_C funs_cnt)
|
||||
(fid_cnt,crc,prods) prods0
|
||||
funs' = foldl' (toCncFun funs_cnt (m,id)) funs (assocs funs0)
|
||||
in mkCncFuns cdefs fid_cnt' funs_cnt' funs' lindefs crc' prods'
|
||||
mkCncFuns (_ :cdefs) fid_cnt funs_cnt funs lindefs crc prods =
|
||||
mkCncFuns cdefs fid_cnt funs_cnt funs lindefs crc prods
|
||||
|
||||
toProd lindefs (ctxt_C,res_C,_) offs st (A.Production fid0 funid0 args0) =
|
||||
let !((fid_cnt,crc,prods),args) = mapAccumL mkArg st (zip ctxt_C args0)
|
||||
set0 = Set.fromList (map (PApply (offs+funid0)) (sequence args))
|
||||
fid = mkFId res_C fid0
|
||||
!prods' = case IntMap.lookup fid prods of
|
||||
Just set -> IntMap.insert fid (Set.union set0 set) prods
|
||||
Nothing -> IntMap.insert fid set0 prods
|
||||
in (fid_cnt,crc,prods')
|
||||
where
|
||||
mkArg st@(fid_cnt,crc,prods) ((_,_,ty),fid0s) =
|
||||
case fid0s of
|
||||
[fid0] -> (st,map (flip PArg (mkFId arg_C fid0)) ctxt)
|
||||
fid0s -> case Map.lookup fids crc of
|
||||
Just fid -> (st,map (flip PArg fid) ctxt)
|
||||
Nothing -> let !crc' = Map.insert fids fid_cnt crc
|
||||
!prods' = IntMap.insert fid_cnt (Set.fromList (map PCoerce fids)) prods
|
||||
in ((fid_cnt+1,crc',prods'),map (flip PArg fid_cnt) ctxt)
|
||||
where
|
||||
(hargs_C,arg_C) = GM.catSkeleton ty
|
||||
ctxt = mapM (mkCtxt lindefs) hargs_C
|
||||
fids = map (mkFId arg_C) fid0s
|
||||
|
||||
mkLinDefId id = prefixIdent "lindef " id
|
||||
|
||||
toLinDef res offs lindefs (A.Production fid0 funid0 args) =
|
||||
if args == [[fidVar]]
|
||||
then IntMap.insertWith (++) fid [offs+funid0] lindefs
|
||||
else lindefs
|
||||
where
|
||||
fid = mkFId res fid0
|
||||
|
||||
toLinRef res offs linrefs (A.Production fid0 funid0 [fargs]) =
|
||||
if fid0 == fidVar
|
||||
then foldr (\fid -> IntMap.insertWith (++) fid [offs+funid0]) linrefs fids
|
||||
else linrefs
|
||||
where
|
||||
fids = map (mkFId res) fargs
|
||||
|
||||
mkFId (_,cat) fid0 =
|
||||
case Map.lookup (i2i cat) cnccat_ranges of
|
||||
Just (s,e) -> s+fid0
|
||||
Nothing -> error ("GrammarToPGF.mkFId: missing category "++showIdent cat)
|
||||
|
||||
mkCtxt lindefs (_,cat) =
|
||||
case Map.lookup (i2i cat) cnccat_ranges of
|
||||
Just (s,e) -> [(fid,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]]
|
||||
Nothing -> error "GrammarToPGF.mkCtxt failed"
|
||||
|
||||
toCncFun offs (m,id) funs (funid0,lins0) =
|
||||
let mseqs = case lookupModule gr m of
|
||||
Ok (ModInfo{mseqs=Just mseqs}) -> mseqs
|
||||
_ -> ex_seqs
|
||||
in (i2i id, map (newIndex mseqs) (elems lins0)):funs
|
||||
where
|
||||
newIndex mseqs i = binSearch (mseqs ! i) seqs (bounds seqs)
|
||||
|
||||
binSearch v arr (i,j)
|
||||
| i <= j = case ciCmp v (arr ! k) of
|
||||
LT -> binSearch v arr (i,k-1)
|
||||
EQ -> k
|
||||
GT -> binSearch v arr (k+1,j)
|
||||
| otherwise = error "binSearch"
|
||||
where
|
||||
k = (i+j) `div` 2
|
||||
|
||||
|
||||
genPrintNames cdefs =
|
||||
[(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info]
|
||||
where
|
||||
prn (CncFun _ _ (Just (L _ tr)) _) = [flatten tr]
|
||||
prn (CncCat _ _ _ (Just (L _ tr)) _) = [flatten tr]
|
||||
prn _ = []
|
||||
|
||||
flatten (K s) = s
|
||||
flatten (Alts x _) = flatten x
|
||||
flatten (C x y) = flatten x +++ flatten y
|
||||
|
||||
mkArray lst = listArray (0,length lst-1) lst
|
||||
mkMapArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
|
||||
mkSetArray set = listArray (0,Set.size set-1) (Set.toList set)
|
||||
|
||||
-- The following is a version of Data.List.sortBy which together
|
||||
-- with the sorting also eliminates duplicate values
|
||||
sortNubBy cmp = mergeAll . sequences
|
||||
where
|
||||
sequences (a:b:xs) =
|
||||
case cmp a b of
|
||||
GT -> descending b [a] xs
|
||||
EQ -> sequences (b:xs)
|
||||
LT -> ascending b (a:) xs
|
||||
sequences xs = [xs]
|
||||
|
||||
descending a as [] = [a:as]
|
||||
descending a as (b:bs) =
|
||||
case cmp a b of
|
||||
GT -> descending b (a:as) bs
|
||||
EQ -> descending a as bs
|
||||
LT -> (a:as) : sequences (b:bs)
|
||||
|
||||
ascending a as [] = let !x = as [a]
|
||||
in [x]
|
||||
ascending a as (b:bs) =
|
||||
case cmp a b of
|
||||
GT -> let !x = as [a]
|
||||
in x : sequences (b:bs)
|
||||
EQ -> ascending a as bs
|
||||
LT -> ascending b (\ys -> as (a:ys)) bs
|
||||
|
||||
mergeAll [x] = x
|
||||
mergeAll xs = mergeAll (mergePairs xs)
|
||||
|
||||
mergePairs (a:b:xs) = let !x = merge a b
|
||||
in x : mergePairs xs
|
||||
mergePairs xs = xs
|
||||
|
||||
merge as@(a:as') bs@(b:bs') =
|
||||
case cmp a b of
|
||||
GT -> b:merge as bs'
|
||||
EQ -> a:merge as' bs'
|
||||
LT -> a:merge as' bs
|
||||
merge [] bs = bs
|
||||
merge as [] = as
|
||||
|
||||
-- The following function does case-insensitive comparison of sequences.
|
||||
-- This is used to allow case-insensitive parsing, while
|
||||
-- the linearizer still has access to the original cases.
|
||||
|
||||
compareCaseInsensitive [] [] = EQ
|
||||
compareCaseInsensitive [] _ = LT
|
||||
compareCaseInsensitive _ [] = GT
|
||||
compareCaseInsensitive (x:xs) (y:ys) =
|
||||
case compareSym x y of
|
||||
EQ -> compareCaseInsensitive xs ys
|
||||
x -> x
|
||||
where
|
||||
compareSym s1 s2 =
|
||||
case s1 of
|
||||
SymCat d1 r1
|
||||
-> case s2 of
|
||||
SymCat d2 r2
|
||||
-> case compare d1 d2 of
|
||||
EQ -> r1 `compare` r2
|
||||
x -> x
|
||||
_ -> LT
|
||||
SymLit d1 r1
|
||||
-> case s2 of
|
||||
SymCat {} -> GT
|
||||
SymLit d2 r2
|
||||
-> case compare d1 d2 of
|
||||
EQ -> r1 `compare` r2
|
||||
x -> x
|
||||
_ -> LT
|
||||
SymVar d1 r1
|
||||
-> if tagToEnum# (getTag s2 ># 2#)
|
||||
then LT
|
||||
else case s2 of
|
||||
SymVar d2 r2
|
||||
-> case compare d1 d2 of
|
||||
EQ -> r1 `compare` r2
|
||||
x -> x
|
||||
_ -> GT
|
||||
SymKS t1
|
||||
-> if tagToEnum# (getTag s2 ># 3#)
|
||||
then LT
|
||||
else case s2 of
|
||||
SymKS t2 -> t1 `compareToken` t2
|
||||
_ -> GT
|
||||
SymKP a1 b1
|
||||
-> if tagToEnum# (getTag s2 ># 4#)
|
||||
then LT
|
||||
else case s2 of
|
||||
SymKP a2 b2
|
||||
-> case compare a1 a2 of
|
||||
EQ -> b1 `compare` b2
|
||||
x -> x
|
||||
_ -> GT
|
||||
_ -> let t1 = getTag s1
|
||||
t2 = getTag s2
|
||||
in if tagToEnum# (t1 <# t2)
|
||||
then LT
|
||||
else if tagToEnum# (t1 ==# t2)
|
||||
then EQ
|
||||
else GT
|
||||
|
||||
compareToken [] [] = EQ
|
||||
compareToken [] _ = LT
|
||||
compareToken _ [] = GT
|
||||
compareToken (x:xs) (y:ys)
|
||||
| x == y = compareToken xs ys
|
||||
| otherwise = case compare (toLower x) (toLower y) of
|
||||
EQ -> case compareToken xs ys of
|
||||
EQ -> compare x y
|
||||
x -> x
|
||||
x -> x
|
||||
-}
|
||||
143
src/compiler/api/GF/Compile/ModDeps.hs
Normal file
143
src/compiler/api/GF/Compile/ModDeps.hs
Normal file
@@ -0,0 +1,143 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : ModDeps
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/11/11 23:24:34 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.14 $
|
||||
--
|
||||
-- Check correctness of module dependencies. Incomplete.
|
||||
--
|
||||
-- AR 13\/5\/2003
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Compile.ModDeps (mkSourceGrammar,
|
||||
moduleDeps,
|
||||
openInterfaces,
|
||||
requiredCanModules
|
||||
) where
|
||||
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Option
|
||||
import GF.Grammar.Printer
|
||||
import GF.Compile.Update
|
||||
import GF.Grammar.Lookup
|
||||
import GF.Infra.Modules
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
import Control.Monad
|
||||
import Data.List
|
||||
|
||||
-- | to check uniqueness of module names and import names, the
|
||||
-- appropriateness of import and extend types,
|
||||
-- to build a dependency graph of modules, and to sort them topologically
|
||||
mkSourceGrammar :: [SourceModule] -> Err SourceGrammar
|
||||
mkSourceGrammar ms = do
|
||||
let ns = map fst ms
|
||||
checkUniqueErr ns
|
||||
mapM (checkUniqueImportNames ns . snd) ms
|
||||
deps <- moduleDeps ms
|
||||
deplist <- either
|
||||
return
|
||||
(\ms -> Bad $ "circular modules" +++ unwords (map show ms)) $
|
||||
topoTest deps
|
||||
return $ MGrammar [(m, maybe undefined id $ lookup m ms) | IdentM m _ <- deplist]
|
||||
|
||||
checkUniqueErr :: (Show i, Eq i) => [i] -> Err ()
|
||||
checkUniqueErr ms = do
|
||||
let msg = checkUnique ms
|
||||
if null msg then return () else Bad $ unlines msg
|
||||
|
||||
-- | check that import names don't clash with module names
|
||||
checkUniqueImportNames :: [Ident] -> SourceModInfo -> Err ()
|
||||
checkUniqueImportNames ns mo = test [n | OQualif n v <- opens mo, n /= v]
|
||||
where
|
||||
test ms = testErr (all (`notElem` ns) ms)
|
||||
("import names clashing with module names among" +++ unwords (map prt ms))
|
||||
|
||||
type Dependencies = [(IdentM Ident,[IdentM Ident])]
|
||||
|
||||
-- | to decide what modules immediately depend on what, and check if the
|
||||
-- dependencies are appropriate
|
||||
moduleDeps :: [SourceModule] -> Err Dependencies
|
||||
moduleDeps ms = mapM deps ms where
|
||||
deps (c,m) = errIn ("checking dependencies of module" +++ prt c) $ case mtype m of
|
||||
MTConcrete a -> do
|
||||
am <- lookupModuleType gr a
|
||||
testErr (mtype am == MTAbstract) "the of-module is not an abstract syntax"
|
||||
chDep (IdentM c (MTConcrete a))
|
||||
(extends m) (MTConcrete a) (opens m) MTResource
|
||||
t -> chDep (IdentM c t) (extends m) t (opens m) t
|
||||
|
||||
chDep it es ety os oty = do
|
||||
ems <- mapM (lookupModuleType gr) es
|
||||
testErr (all (compatMType ety . mtype) ests) "inappropriate extension module type"
|
||||
let ab = case it of
|
||||
IdentM _ (MTConcrete a) -> [IdentM a MTAbstract]
|
||||
_ -> [] ----
|
||||
return (it, ab ++
|
||||
[IdentM e ety | e <- es] ++
|
||||
[IdentM (openedModule o) oty | o <- os])
|
||||
|
||||
-- check for superficial compatibility, not submodule relation etc: what can be extended
|
||||
compatMType mt0 mt = case (mt0,mt) of
|
||||
(MTResource, MTConcrete _) -> True
|
||||
(MTInstance _, MTConcrete _) -> True
|
||||
(MTInterface, MTAbstract) -> True
|
||||
(MTConcrete _, MTConcrete _) -> True
|
||||
(MTInstance _, MTInstance _) -> True
|
||||
(MTInstance _, MTResource) -> True
|
||||
(MTResource, MTInstance _) -> True
|
||||
---- some more?
|
||||
_ -> mt0 == mt
|
||||
-- in the same way; this defines what can be opened
|
||||
compatOType mt0 mt = case mt0 of
|
||||
MTAbstract -> mt == MTAbstract
|
||||
_ -> case mt of
|
||||
MTResource -> True
|
||||
MTInterface -> True
|
||||
MTInstance _ -> True
|
||||
_ -> False
|
||||
|
||||
gr = MGrammar ms --- hack
|
||||
|
||||
openInterfaces :: Dependencies -> Ident -> Err [Ident]
|
||||
openInterfaces ds m = do
|
||||
let deps = [(i,ds) | (IdentM i _,ds) <- ds]
|
||||
let more (c,_) = [(i,mt) | Just is <- [lookup c deps], IdentM i mt <- is]
|
||||
let mods = iterFix (concatMap more) (more (m,undefined))
|
||||
return $ [i | (i,MTInterface) <- mods]
|
||||
|
||||
-- | this function finds out what modules are really needed in the canonical gr.
|
||||
-- its argument is typically a concrete module name
|
||||
requiredCanModules :: (Ord i, Show i) => Bool -> MGrammar i a -> i -> [i]
|
||||
requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where
|
||||
exts = allExtends gr c
|
||||
ops = if isSingle
|
||||
then map fst (modules gr)
|
||||
else iterFix (concatMap more) $ exts
|
||||
more i = errVal [] $ do
|
||||
m <- lookupModule gr i
|
||||
return $ extends m ++ [o | o <- map openedModule (opens m)]
|
||||
notReuse i = errVal True $ do
|
||||
m <- lookupModule gr i
|
||||
return $ isModRes m -- to exclude reused Cnc and Abs from required
|
||||
|
||||
|
||||
{-
|
||||
-- to test
|
||||
exampleDeps = [
|
||||
(ir "Nat",[ii "Gen", ir "Adj"]),
|
||||
(ir "Adj",[ii "Num", ii "Gen", ir "Nou"]),
|
||||
(ir "Nou",[ii "Cas"])
|
||||
]
|
||||
|
||||
ii s = IdentM (IC s) MTInterface
|
||||
ir s = IdentM (IC s) MTResource
|
||||
-}
|
||||
|
||||
165
src/compiler/api/GF/Compile/Multi.hs
Normal file
165
src/compiler/api/GF/Compile/Multi.hs
Normal file
@@ -0,0 +1,165 @@
|
||||
module GF.Compile.Multi (readMulti) where
|
||||
|
||||
import Data.List
|
||||
import Data.Char
|
||||
|
||||
-- AR 29 November 2010
|
||||
-- quick way of writing a multilingual lexicon and (with some more work) a grammar
|
||||
-- also several modules in one file
|
||||
-- file suffix .gfm (GF Multi)
|
||||
|
||||
|
||||
{-
|
||||
-- This multi-line comment is a possible file in the format.
|
||||
-- comments are as in GF, one-liners
|
||||
|
||||
-- always start by declaring lang names as follows
|
||||
> langs Eng Fin Swe
|
||||
|
||||
-- baseline rules: semicolon-separated line-by-line entries update abs and cncs, adding to S
|
||||
cheers ; skål ; terveydeksi
|
||||
|
||||
-- alternatives within a language are comma-separated
|
||||
cheers ; skål ; terveydeksi, kippis
|
||||
|
||||
-- more advanced: verbatim abstract rules prefixed by "> abs"
|
||||
> abs cat Drink ;
|
||||
> abs fun drink : Drink -> S ;
|
||||
|
||||
-- verbatim concrete rules prefixed by ">" and comma-separated language list
|
||||
> Eng,Swe lin Gin = "gin" ;
|
||||
|
||||
-- multiple modules: modules as usual. Each module has to start from a new line.
|
||||
-- Should be UTF-8 encoded.
|
||||
|
||||
-}
|
||||
|
||||
{-
|
||||
main = do
|
||||
xx <- getArgs
|
||||
if null xx then putStrLn usage else do
|
||||
let (opts,file) = (init xx, last xx)
|
||||
(absn,cncns) <- readMulti opts file
|
||||
if elem "-pgf" xx
|
||||
then do
|
||||
system ("gf -make -s -optimize-pgf " ++ unwords (map gfFile cncns))
|
||||
putStrLn $ "wrote " ++ absn ++ ".pgf"
|
||||
else return ()
|
||||
-}
|
||||
|
||||
readMulti :: FilePath -> IO (FilePath,[FilePath])
|
||||
readMulti file = do
|
||||
src <- readFile file
|
||||
let multi = getMulti (takeWhile (/='.') file) src
|
||||
absn = absName multi
|
||||
cncns = cncNames multi
|
||||
raws = rawModules multi
|
||||
writeFile (gfFile absn) (absCode multi)
|
||||
mapM_ (uncurry writeFile)
|
||||
[(gfFile cncn, cncCode absn cncn cod) |
|
||||
cncn <- cncNames multi, let cod = [r | (la,r) <- cncRules multi, la == cncn]]
|
||||
putStrLn $ "wrote " ++ unwords (map gfFile (absn:cncns))
|
||||
mapM_ (uncurry writeFile) [(gfFile n,s) | (n,s) <- raws] --- overwrites those above
|
||||
return (gfFile absn, map gfFile cncns)
|
||||
|
||||
data Multi = Multi {
|
||||
rawModules :: [(String,String)],
|
||||
absName :: String,
|
||||
cncNames :: [String],
|
||||
startCat :: String,
|
||||
absRules :: [String],
|
||||
cncRules :: [(String,String)] -- lang,lin
|
||||
}
|
||||
|
||||
emptyMulti :: Multi
|
||||
emptyMulti = Multi {
|
||||
rawModules = [],
|
||||
absName = "Abs",
|
||||
cncNames = [],
|
||||
startCat = "S",
|
||||
absRules = [],
|
||||
cncRules = []
|
||||
}
|
||||
|
||||
absCode :: Multi -> String
|
||||
absCode multi = unlines $ header : start ++ (reverse (absRules multi)) ++ ["}"] where
|
||||
header = "abstract " ++ absName multi ++ " = {"
|
||||
start = ["flags startcat = " ++ cat ++ " ;", "cat " ++ cat ++ " ;"]
|
||||
cat = startCat multi
|
||||
|
||||
cncCode :: String -> String -> [String] -> String
|
||||
cncCode ab cnc rules = unlines $ header : (reverse rules ++ ["}"]) where
|
||||
header = "concrete " ++ cnc ++ " of " ++ ab ++ " = {"
|
||||
|
||||
getMulti :: String -> String -> Multi
|
||||
getMulti m s = foldl (flip addMulti) (emptyMulti{absName = m}) (modlines (lines s))
|
||||
|
||||
addMulti :: String -> Multi -> Multi
|
||||
addMulti line multi = case line of
|
||||
'-':'-':_ -> multi
|
||||
_ | all isSpace line -> multi
|
||||
'>':s -> case words s of
|
||||
"langs":ws -> let las = [absName multi ++ w | w <- ws] in multi {
|
||||
cncNames = las,
|
||||
cncRules = concat [[(la,"lincat " ++ startCat multi ++ " = Str ;"),
|
||||
(la,"flags coding = utf8 ;")] | la <- las]
|
||||
}
|
||||
"startcat":c:ws -> multi {startCat = c}
|
||||
"abs":ws -> multi {
|
||||
absRules = unwords ws : absRules multi
|
||||
}
|
||||
langs:ws -> multi {
|
||||
cncRules = [(absName multi ++ la, unwords ws) | la <- chop ',' langs] ++ cncRules multi
|
||||
}
|
||||
_ -> case words line of
|
||||
m:name:_ | isModule m -> multi {
|
||||
rawModules = (name,line):rawModules multi
|
||||
}
|
||||
_ -> let (cat,fun,lins) = getRules (startCat multi) line in
|
||||
multi {
|
||||
absRules = ("fun " ++ fun ++ " : " ++ cat ++ " ;") : absRules multi,
|
||||
cncRules = zip (cncNames multi) lins ++ cncRules multi
|
||||
}
|
||||
|
||||
getRules :: String -> String -> (String,String,[String])
|
||||
getRules cat line = (cat, fun, map lin rss) where
|
||||
rss = map (map unspace . chop ',') $ chop ';' line
|
||||
fun = map idChar (head (head rss)) ++ "_" ++ cat
|
||||
lin rs = "lin " ++ fun ++ " = " ++ unwords (intersperse "|" (map quote rs)) ++ " ;"
|
||||
|
||||
chop :: Eq c => c -> [c] -> [[c]]
|
||||
chop c cs = case break (==c) cs of
|
||||
(w,_:cs2) -> w : chop c cs2
|
||||
([],[]) -> []
|
||||
(w,_) -> [w]
|
||||
|
||||
-- remove spaces from beginning and end, leave them in the middle
|
||||
unspace :: String -> String
|
||||
unspace = unwords . words
|
||||
|
||||
quote :: String -> String
|
||||
quote r = "\"" ++ r ++ "\""
|
||||
|
||||
-- to guarantee that the char can be used in an ident
|
||||
idChar :: Char -> Char
|
||||
idChar c =
|
||||
if (n > 47 && n < 58) || (n > 64 && n < 91) || (n > 96 && n < 123)
|
||||
then c
|
||||
else '_'
|
||||
where n = fromEnum c
|
||||
|
||||
|
||||
gfFile :: FilePath -> FilePath
|
||||
gfFile f = f ++ ".gf"
|
||||
|
||||
isModule :: String -> Bool
|
||||
isModule = flip elem
|
||||
["abstract","concrete","incomplete","instance","interface","resource"]
|
||||
|
||||
modlines :: [String] -> [String]
|
||||
modlines ss = case ss of
|
||||
l:ls -> case words l of
|
||||
w:_ | isModule w -> case break (isModule . concat . take 1 . words) ls of
|
||||
(ms,rest) -> unlines (l:ms) : modlines rest
|
||||
_ -> l : modlines ls
|
||||
_ -> []
|
||||
191
src/compiler/api/GF/Compile/OptimizePGF.hs
Normal file
191
src/compiler/api/GF/Compile/OptimizePGF.hs
Normal file
@@ -0,0 +1,191 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
module GF.Compile.OptimizePGF(optimizePGF) where
|
||||
|
||||
import PGF2(Cat,Fun)
|
||||
import PGF2.Transactions
|
||||
import Data.Array.ST
|
||||
import Data.Array.Unboxed
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.IntSet as IntSet
|
||||
import qualified Data.IntMap as IntMap
|
||||
import qualified Data.List as List
|
||||
import Control.Monad.ST
|
||||
|
||||
type ConcrData = ()
|
||||
{-([(FId,[FunId])], -- ^ Lindefs
|
||||
[(FId,[FunId])], -- ^ Linrefs
|
||||
[(FId,[Production])], -- ^ Productions
|
||||
[(Fun,[SeqId])], -- ^ Concrete functions (must be sorted by Fun)
|
||||
[[Symbol]], -- ^ Sequences (must be sorted)
|
||||
[(Cat,FId,FId,[String])]) -- ^ Concrete categories
|
||||
-}
|
||||
optimizePGF :: Cat -> ConcrData -> ConcrData
|
||||
optimizePGF startCat = error "TODO: optimizePGF" {- topDownFilter startCat . bottomUpFilter
|
||||
|
||||
catString = "String"
|
||||
catInt = "Int"
|
||||
catFloat = "Float"
|
||||
catVar = "__gfVar"
|
||||
|
||||
topDownFilter :: Cat -> ConcrData -> ConcrData
|
||||
topDownFilter startCat (lindefs,linrefs,prods,cncfuns,sequences,cnccats) =
|
||||
let env0 = (Map.empty,Map.empty)
|
||||
(env1,lindefs') = List.mapAccumL (\env (fid,funids) -> let (env',funids') = List.mapAccumL (optimizeFun fid [PArg [] fidVar]) env funids in (env',(fid,funids')))
|
||||
env0
|
||||
lindefs
|
||||
(env2,linrefs') = List.mapAccumL (\env (fid,funids) -> let (env',funids') = List.mapAccumL (optimizeFun fidVar [PArg [] fid]) env funids in (env',(fid,funids')))
|
||||
env1
|
||||
linrefs
|
||||
(env3,prods') = List.mapAccumL (\env (fid,set) -> let (env',set') = List.mapAccumL (optimizeProd fid) env set in (env',(fid,set')))
|
||||
env2
|
||||
prods
|
||||
cnccats' = map filterCatLabels cnccats
|
||||
(sequences',cncfuns') = env3
|
||||
in (lindefs',linrefs',prods',mkSetArray cncfuns',mkSetArray sequences',cnccats')
|
||||
where
|
||||
cncfuns_array = listArray (0,length cncfuns-1) cncfuns :: Array FunId (Fun, [SeqId])
|
||||
sequences_array = listArray (0,length sequences-1) sequences :: Array SeqId [Symbol]
|
||||
prods_map = IntMap.fromList prods
|
||||
fid2catMap = IntMap.fromList ((fidVar,catVar) : [(fid,cat) | (cat,start,end,lbls) <- cnccats,
|
||||
fid <- [start..end]])
|
||||
|
||||
fid2cat fid =
|
||||
case IntMap.lookup fid fid2catMap of
|
||||
Just cat -> cat
|
||||
Nothing -> case [fid | Just set <- [IntMap.lookup fid prods_map], PCoerce fid <- set] of
|
||||
(fid:_) -> fid2cat fid
|
||||
_ -> error "unknown forest id"
|
||||
|
||||
starts =
|
||||
[(startCat,lbl) | (cat,_,_,lbls) <- cnccats, cat==startCat, lbl <- [0..length lbls-1]]
|
||||
|
||||
allRelations =
|
||||
Map.unionsWith Set.union
|
||||
[rel fid prod | (fid,set) <- prods, prod <- set]
|
||||
where
|
||||
rel fid (PApply funid args) = Map.fromList [((fid2cat fid,lbl),deps args seqid) | (lbl,seqid) <- zip [0..] lin]
|
||||
where
|
||||
(_,lin) = cncfuns_array ! funid
|
||||
rel fid _ = Map.empty
|
||||
|
||||
deps args seqid = Set.fromList [let PArg _ fid = args !! r in (fid2cat fid,d) | SymCat r d <- seq]
|
||||
where
|
||||
seq = sequences_array ! seqid
|
||||
|
||||
-- here we create a mapping from a category to an array of indices.
|
||||
-- An element of the array is equal to -1 if the corresponding index
|
||||
-- is not going to be used in the optimized grammar, or the new index
|
||||
-- if it will be used
|
||||
closure :: Map.Map Cat [Int]
|
||||
closure = runST $ do
|
||||
set <- initSet
|
||||
addLitCat catString set
|
||||
addLitCat catInt set
|
||||
addLitCat catFloat set
|
||||
addLitCat catVar set
|
||||
closureSet set starts
|
||||
doneSet set
|
||||
where
|
||||
initSet :: ST s (Map.Map Cat (STUArray s Int Int))
|
||||
initSet =
|
||||
fmap Map.fromList $ sequence
|
||||
[fmap ((,) cat) (newArray (0,length lbls-1) (-1))
|
||||
| (cat,_,_,lbls) <- cnccats]
|
||||
|
||||
addLitCat cat set =
|
||||
case Map.lookup cat set of
|
||||
Just indices -> writeArray indices 0 0
|
||||
Nothing -> return ()
|
||||
|
||||
closureSet set [] = return ()
|
||||
closureSet set (x@(cat,index):xs) =
|
||||
case Map.lookup cat set of
|
||||
Just indices -> do v <- readArray indices index
|
||||
writeArray indices index 0
|
||||
if v < 0
|
||||
then case Map.lookup x allRelations of
|
||||
Just ys -> closureSet set (Set.toList ys++xs)
|
||||
Nothing -> closureSet set xs
|
||||
else closureSet set xs
|
||||
Nothing -> error "unknown cat"
|
||||
|
||||
doneSet :: Map.Map Cat (STUArray s Int Int) -> ST s (Map.Map Cat [Int])
|
||||
doneSet set =
|
||||
fmap Map.fromAscList $ mapM done (Map.toAscList set)
|
||||
where
|
||||
done (cat,indices) = do
|
||||
indices <- fmap (reindex 0) (getElems indices)
|
||||
return (cat,indices)
|
||||
|
||||
reindex k [] = []
|
||||
reindex k (v:vs)
|
||||
| v < 0 = v : reindex k vs
|
||||
| otherwise = k : reindex (k+1) vs
|
||||
|
||||
optimizeProd res env (PApply funid args) =
|
||||
let (env',funid') = optimizeFun res args env funid
|
||||
in (env', PApply funid' args)
|
||||
optimizeProd res env prod = (env,prod)
|
||||
|
||||
optimizeFun res args (seqs,funs) funid =
|
||||
let (seqs',lin') = List.mapAccumL addUnique seqs [map updateSymbol (sequences_array ! seqid) |
|
||||
(idx,seqid) <- zip (indicesOf res) lin, idx >= 0]
|
||||
(funs',funid') = addUnique funs (fun, lin')
|
||||
in ((seqs',funs'), funid')
|
||||
where
|
||||
(fun,lin) = cncfuns_array ! funid
|
||||
|
||||
indicesOf fid
|
||||
| fid < 0 = [0]
|
||||
| otherwise =
|
||||
case Map.lookup (fid2cat fid) closure of
|
||||
Just indices -> indices
|
||||
Nothing -> error "unknown category"
|
||||
|
||||
addUnique seqs seq =
|
||||
case Map.lookup seq seqs of
|
||||
Just seqid -> (seqs,seqid)
|
||||
Nothing -> let seqid = Map.size seqs
|
||||
in (Map.insert seq seqid seqs, seqid)
|
||||
|
||||
updateSymbol (SymCat r d) = let PArg _ fid = args !! r in SymCat r (indicesOf fid !! d)
|
||||
updateSymbol s = s
|
||||
|
||||
filterCatLabels (cat,start,end,lbls) =
|
||||
case Map.lookup cat closure of
|
||||
Just indices -> let lbls' = [lbl | (idx,lbl) <- zip indices lbls, idx >= 0]
|
||||
in (cat,start,end,lbls')
|
||||
Nothing -> error ("unknown category")
|
||||
|
||||
mkSetArray map = sortSnd (Map.toList map)
|
||||
where
|
||||
sortSnd = List.map fst . List.sortBy (\(_,i) (_,j) -> compare i j)
|
||||
|
||||
|
||||
bottomUpFilter :: ConcrData -> ConcrData
|
||||
bottomUpFilter (lindefs,linrefs,prods,cncfuns,sequences,cnccats) =
|
||||
(lindefs,linrefs,filterProductions IntMap.empty IntSet.empty prods,cncfuns,sequences,cnccats)
|
||||
|
||||
filterProductions prods0 hoc0 prods
|
||||
| prods0 == prods1 = IntMap.toList prods0
|
||||
| otherwise = filterProductions prods1 hoc1 prods
|
||||
where
|
||||
(prods1,hoc1) = foldl foldProdSet (IntMap.empty,IntSet.empty) prods
|
||||
|
||||
foldProdSet (!prods,!hoc) (fid,set)
|
||||
| null set1 = (prods,hoc)
|
||||
| otherwise = (IntMap.insert fid set1 prods,hoc1)
|
||||
where
|
||||
set1 = filter filterRule set
|
||||
hoc1 = foldl accumHOC hoc set1
|
||||
|
||||
filterRule (PApply funid args) = all (\(PArg _ fid) -> isLive fid) args
|
||||
filterRule (PCoerce fid) = isLive fid
|
||||
filterRule _ = True
|
||||
|
||||
isLive fid = isPredefFId fid || IntMap.member fid prods0 || IntSet.member fid hoc0
|
||||
|
||||
accumHOC hoc (PApply funid args) = List.foldl' (\hoc (PArg hypos _) -> List.foldl' (\hoc fid -> IntSet.insert fid hoc) hoc (map snd hypos)) hoc args
|
||||
accumHOC hoc _ = hoc
|
||||
-}
|
||||
353
src/compiler/api/GF/Compile/PGFtoHaskell.hs
Normal file
353
src/compiler/api/GF/Compile/PGFtoHaskell.hs
Normal file
@@ -0,0 +1,353 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : PGFtoHaskell
|
||||
-- Maintainer : Aarne Ranta
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/06/17 12:39:07 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.8 $
|
||||
--
|
||||
-- to write a GF abstract grammar into a Haskell module with translations from
|
||||
-- data objects into GF trees. Example: GSyntax for Agda.
|
||||
-- AR 11/11/1999 -- 7/12/2000 -- 18/5/2004
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Compile.PGFtoHaskell (grammar2haskell) where
|
||||
|
||||
import PGF2
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Infra.Option
|
||||
|
||||
import Data.List(isPrefixOf,find,intercalate,intersperse,groupBy,sortBy)
|
||||
import Data.Maybe(mapMaybe)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
type Prefix = String -> String
|
||||
type DerivingClause = String
|
||||
|
||||
-- | the main function
|
||||
grammar2haskell :: Options
|
||||
-> String -- ^ Module name.
|
||||
-> PGF
|
||||
-> String
|
||||
grammar2haskell opts name gr = foldr (++++) [] $
|
||||
pragmas ++ haskPreamble gadt name derivingClause (extraImports ++ pgfImports) ++
|
||||
[types, gfinstances gId lexical gr'] ++ compos
|
||||
where gr' = hSkeleton gr
|
||||
gadt = haskellOption opts HaskellGADT
|
||||
dataExt = haskellOption opts HaskellData
|
||||
pgf2 = haskellOption opts HaskellPGF2
|
||||
lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat
|
||||
gId | haskellOption opts HaskellNoPrefix = rmForbiddenChars
|
||||
| otherwise = ("G"++) . rmForbiddenChars
|
||||
-- GF grammars allow weird identifier names inside '', e.g. 'VP/Object'
|
||||
rmForbiddenChars = filter (`notElem` "'!#$%&*+./<=>?@\\^|-~")
|
||||
pragmas | gadt = ["{-# LANGUAGE GADTs, FlexibleInstances, KindSignatures, RankNTypes, TypeSynonymInstances #-}"]
|
||||
| dataExt = ["{-# LANGUAGE DeriveDataTypeable #-}"]
|
||||
| otherwise = []
|
||||
derivingClause
|
||||
| dataExt = "deriving (Show,Data)"
|
||||
| otherwise = "deriving Show"
|
||||
extraImports | gadt = ["import Control.Monad.Identity", "import Data.Monoid"]
|
||||
| dataExt = ["import Data.Data"]
|
||||
| otherwise = []
|
||||
pgfImports | pgf2 = ["import PGF2 hiding (Tree)", "", "showCId :: CId -> String", "showCId = id"]
|
||||
| otherwise = ["import PGF hiding (Tree)"]
|
||||
types | gadt = datatypesGADT gId lexical gr'
|
||||
| otherwise = datatypes gId derivingClause lexical gr'
|
||||
compos | gadt = prCompos gId lexical gr' ++ composClass
|
||||
| otherwise = []
|
||||
|
||||
haskPreamble :: Bool -> String -> String -> [String] -> [String]
|
||||
haskPreamble gadt name derivingClause imports =
|
||||
[
|
||||
"module " ++ name ++ " where",
|
||||
""
|
||||
] ++ imports ++ [
|
||||
"",
|
||||
"----------------------------------------------------",
|
||||
"-- automatic translation from GF to Haskell",
|
||||
"----------------------------------------------------",
|
||||
"",
|
||||
"class Gf a where",
|
||||
" gf :: a -> Expr",
|
||||
" fg :: Expr -> a",
|
||||
"",
|
||||
predefInst gadt derivingClause "GString" "String" "unStr" "mkStr",
|
||||
"",
|
||||
predefInst gadt derivingClause "GInt" "Int" "unInt" "mkInt",
|
||||
"",
|
||||
predefInst gadt derivingClause "GFloat" "Double" "unFloat" "mkFloat",
|
||||
"",
|
||||
"----------------------------------------------------",
|
||||
"-- below this line machine-generated",
|
||||
"----------------------------------------------------",
|
||||
""
|
||||
]
|
||||
|
||||
predefInst :: Bool -> String -> String -> String -> String -> String -> String
|
||||
predefInst gadt derivingClause gtyp typ destr consr =
|
||||
(if gadt
|
||||
then []
|
||||
else "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n"
|
||||
)
|
||||
++
|
||||
"instance Gf" +++ gtyp +++ "where" ++++
|
||||
" gf (" ++ gtyp +++ "x) =" +++ consr +++ "x" ++++
|
||||
" fg t =" ++++
|
||||
" case "++destr++" t of" ++++
|
||||
" Just x -> " +++ gtyp +++ "x" ++++
|
||||
" Nothing -> error (\"no" +++ gtyp +++ "\" ++ show t)"
|
||||
|
||||
type OIdent = String
|
||||
|
||||
type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
|
||||
|
||||
datatypes :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (String,HSkeleton) -> String
|
||||
datatypes gId derivingClause lexical = foldr (+++++) "" . filter (/="") . map (hDatatype gId derivingClause lexical) . snd
|
||||
|
||||
gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
|
||||
gfinstances gId lexical (m,g) = foldr (+++++) "" $ filter (/="") $ map (gfInstance gId lexical m) g
|
||||
|
||||
|
||||
hDatatype :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String
|
||||
hDatatype _ _ _ ("Cn",_) = "" ---
|
||||
hDatatype gId _ _ (cat,[]) = "data" +++ gId cat
|
||||
hDatatype gId derivingClause _ (cat,rules) | isListCat (cat,rules) =
|
||||
"newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]"
|
||||
+++ derivingClause
|
||||
hDatatype gId derivingClause lexical (cat,rules) =
|
||||
"data" +++ gId cat +++ "=" ++
|
||||
(if length rules == 1 then "" else "\n ") +++
|
||||
foldr1 (\x y -> x ++ "\n |" +++ y) constructors ++++
|
||||
" " +++ derivingClause
|
||||
where
|
||||
constructors = [gId f +++ foldr (+++) "" (map (gId) xx) | (f,xx) <- nonLexicalRules (lexical cat) rules]
|
||||
++ if lexical cat then [lexicalConstructor cat +++ "String"] else []
|
||||
|
||||
nonLexicalRules :: Bool -> [(OIdent, [OIdent])] -> [(OIdent, [OIdent])]
|
||||
nonLexicalRules False rules = rules
|
||||
nonLexicalRules True rules = [r | r@(f,t) <- rules, not (null t)]
|
||||
|
||||
lexicalConstructor :: OIdent -> String
|
||||
lexicalConstructor cat = "Lex" ++ cat
|
||||
|
||||
predefTypeSkel :: HSkeleton
|
||||
predefTypeSkel = [(c,[]) | c <- ["String", "Int", "Float"]]
|
||||
|
||||
-- GADT version of data types
|
||||
datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
|
||||
datatypesGADT gId lexical (_,skel) = unlines $
|
||||
concatMap (hCatTypeGADT gId) (skel ++ predefTypeSkel) ++
|
||||
[
|
||||
"",
|
||||
"data Tree :: * -> * where"
|
||||
] ++
|
||||
concatMap (map (" "++) . hDatatypeGADT gId lexical) skel ++
|
||||
[
|
||||
" GString :: String -> Tree GString_",
|
||||
" GInt :: Int -> Tree GInt_",
|
||||
" GFloat :: Double -> Tree GFloat_",
|
||||
"",
|
||||
"instance Eq (Tree a) where",
|
||||
" i == j = case (i,j) of"
|
||||
] ++
|
||||
concatMap (map (" "++) . hEqGADT gId lexical) skel ++
|
||||
[
|
||||
" (GString x, GString y) -> x == y",
|
||||
" (GInt x, GInt y) -> x == y",
|
||||
" (GFloat x, GFloat y) -> x == y",
|
||||
" _ -> False"
|
||||
]
|
||||
|
||||
hCatTypeGADT :: Prefix -> (OIdent, [(OIdent, [OIdent])]) -> [String]
|
||||
hCatTypeGADT gId (cat,rules)
|
||||
= ["type"+++gId cat+++"="+++"Tree"+++gId cat++"_",
|
||||
"data"+++gId cat++"_"]
|
||||
|
||||
hDatatypeGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
|
||||
hDatatypeGADT gId lexical (cat, rules)
|
||||
| isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t]
|
||||
| otherwise =
|
||||
[ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t
|
||||
| (f,args) <- nonLexicalRules (lexical cat) rules ]
|
||||
++ if lexical cat then [lexicalConstructor cat +++ ":: String ->"+++ t] else []
|
||||
where t = "Tree" +++ gId cat ++ "_"
|
||||
|
||||
hEqGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
|
||||
hEqGADT gId lexical (cat, rules)
|
||||
| isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs]
|
||||
| otherwise = ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ eqs r | r <- nonLexicalRules (lexical cat) rules]
|
||||
++ if lexical cat then ["(" ++ lexicalConstructor cat +++ "x" ++ "," ++ lexicalConstructor cat +++ "y" ++ ") -> x == y"] else []
|
||||
|
||||
where
|
||||
patt s (f,xs) = unwords (gId f : mkSVars s (length xs))
|
||||
eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y |
|
||||
(x,y) <- zip (mkSVars "x" (length xs)) (mkSVars "y" (length xs)) ] ++ ["]"])
|
||||
listr c = (c,["foo"]) -- foo just for length = 1
|
||||
listeqs = "and [x == y | (x,y) <- zip x1 y1]"
|
||||
|
||||
prCompos :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> [String]
|
||||
prCompos gId lexical (_,catrules) =
|
||||
["instance Compos Tree where",
|
||||
" compos r a f t = case t of"]
|
||||
++
|
||||
[" " ++ prComposCons (gId f) xs | (c,rs) <- catrules, not (isListCat (c,rs)),
|
||||
(f,xs) <- rs, not (null xs)]
|
||||
++
|
||||
[" " ++ prComposCons (gId c) ["x1"] | (c,rs) <- catrules, isListCat (c,rs)]
|
||||
++
|
||||
[" _ -> r t"]
|
||||
where
|
||||
prComposCons f xs = let vs = mkVars (length xs) in
|
||||
f +++ unwords vs +++ "->" +++ rhs f (zip vs xs)
|
||||
rhs f vcs = "r" +++ f +++ unwords (map (prRec f) vcs)
|
||||
prRec f (v,c)
|
||||
| isList f = "`a` foldr (a . a (r (:)) . f) (r [])" +++ v
|
||||
| otherwise = "`a`" +++ "f" +++ v
|
||||
isList f = gId "List" `isPrefixOf` f
|
||||
|
||||
gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String
|
||||
gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs
|
||||
|
||||
hInstance :: (String -> String) -> (String -> Bool) -> String -> (String, [(OIdent, [OIdent])]) -> String
|
||||
----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
|
||||
hInstance gId _ m (cat,[]) = unlines [
|
||||
"instance Show" +++ gId cat,
|
||||
"",
|
||||
"instance Gf" +++ gId cat +++ "where",
|
||||
" gf _ = undefined",
|
||||
" fg _ = undefined"
|
||||
]
|
||||
hInstance gId lexical m (cat,rules)
|
||||
| isListCat (cat,rules) =
|
||||
"instance Gf" +++ gId cat +++ "where" ++++
|
||||
" gf (" ++ gId cat +++ "[" ++ intercalate "," baseVars ++ "])"
|
||||
+++ "=" +++ mkRHS ("Base"++ec) baseVars ++++
|
||||
" gf (" ++ gId cat +++ "(x:xs)) = "
|
||||
++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")]
|
||||
-- no show for GADTs
|
||||
-- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)"
|
||||
| otherwise =
|
||||
"instance Gf" +++ gId cat +++ "where\n" ++
|
||||
unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules]
|
||||
++ if lexical cat then [" gf (" ++ lexicalConstructor cat +++ "x) = mkApp (mkCId x) []"] else [])
|
||||
where
|
||||
ec = elemCat cat
|
||||
baseVars = mkVars (baseSize (cat,rules))
|
||||
mkInst f xx = let xx' = mkVars (length xx) in " gf " ++
|
||||
(if null xx then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
|
||||
"=" +++ mkRHS f xx'
|
||||
mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++
|
||||
"[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
|
||||
|
||||
mkVars :: Int -> [String]
|
||||
mkVars = mkSVars "x"
|
||||
|
||||
mkSVars :: String -> Int -> [String]
|
||||
mkSVars s n = [s ++ show i | i <- [1..n]]
|
||||
|
||||
----fInstance m ("Cn",_) = "" ---
|
||||
fInstance _ _ m (cat,[]) = ""
|
||||
fInstance gId lexical m (cat,rules) =
|
||||
" fg t =" ++++
|
||||
(if isList
|
||||
then " " ++ gId cat ++ " (fgs t) where\n fgs t = case unApp t of"
|
||||
else " case unApp t of") ++++
|
||||
unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++
|
||||
(if lexical cat then " Just (i,[]) -> " ++ lexicalConstructor cat +++ "i" else "") ++++
|
||||
" _ -> error (\"no" +++ cat ++ " \" ++ show t)"
|
||||
where
|
||||
isList = isListCat (cat,rules)
|
||||
mkInst f xx =
|
||||
" Just (i," ++
|
||||
"[" ++ prTList "," xx' ++ "])" +++
|
||||
"| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx'
|
||||
where
|
||||
xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
|
||||
mkRHS f vars
|
||||
| isList =
|
||||
if "Base" `isPrefixOf` f
|
||||
then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
|
||||
else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1)
|
||||
| otherwise =
|
||||
gId f +++
|
||||
prTList " " [prParenth ("fg" +++ x) | x <- vars]
|
||||
|
||||
--type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
|
||||
hSkeleton :: PGF -> (String,HSkeleton)
|
||||
hSkeleton gr =
|
||||
(abstractName gr,
|
||||
let fs =
|
||||
[(c, [(f, cs) | (f, cs,_) <- fs]) |
|
||||
fs@((_, _,c):_) <- fns]
|
||||
in fs ++ [(c, []) | c <- cts, notElem c (["Int", "Float", "String"] ++ map fst fs)]
|
||||
)
|
||||
where
|
||||
cts = categories gr
|
||||
fns = groupBy valtypg (sortBy valtyps (mapMaybe jty (functions gr)))
|
||||
valtyps (_,_,x) (_,_,y) = compare x y
|
||||
valtypg (_,_,x) (_,_,y) = x == y
|
||||
jty f = case functionType gr f of
|
||||
Just ty -> let (hypos,valcat,_) = unType ty
|
||||
in Just (f,[argcat | (_,_,ty) <- hypos, let (_,argcat,_) = unType ty],valcat)
|
||||
Nothing -> Nothing
|
||||
{-
|
||||
updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton
|
||||
updateSkeleton cat skel rule =
|
||||
case skel of
|
||||
(cat0,rules):rr | cat0 == cat -> (cat0, rule:rules) : rr
|
||||
(cat0,rules):rr -> (cat0, rules) : updateSkeleton cat rr rule
|
||||
-}
|
||||
isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool
|
||||
isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2
|
||||
&& ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
|
||||
where
|
||||
c = elemCat cat
|
||||
fs = map fst rules
|
||||
|
||||
-- | Gets the element category of a list category.
|
||||
elemCat :: OIdent -> OIdent
|
||||
elemCat = drop 4
|
||||
{-
|
||||
isBaseFun :: OIdent -> Bool
|
||||
isBaseFun f = "Base" `isPrefixOf` f
|
||||
|
||||
isConsFun :: OIdent -> Bool
|
||||
isConsFun f = "Cons" `isPrefixOf` f
|
||||
-}
|
||||
baseSize :: (OIdent, [(OIdent, [OIdent])]) -> Int
|
||||
baseSize (_,rules) = length bs
|
||||
where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules
|
||||
|
||||
composClass :: [String]
|
||||
composClass =
|
||||
[
|
||||
"",
|
||||
"class Compos t where",
|
||||
" compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b)",
|
||||
" -> (forall a. t a -> m (t a)) -> t c -> m (t c)",
|
||||
"",
|
||||
"composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c",
|
||||
"composOp f = runIdentity . composOpM (Identity . f)",
|
||||
"",
|
||||
"composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c)",
|
||||
"composOpM = compos return ap",
|
||||
"",
|
||||
"composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m ()",
|
||||
"composOpM_ = composOpFold (return ()) (>>)",
|
||||
"",
|
||||
"composOpMonoid :: (Compos t, Monoid m) => (forall a. t a -> m) -> t c -> m",
|
||||
"composOpMonoid = composOpFold mempty mappend",
|
||||
"",
|
||||
"composOpMPlus :: (Compos t, MonadPlus m) => (forall a. t a -> m b) -> t c -> m b",
|
||||
"composOpMPlus = composOpFold mzero mplus",
|
||||
"",
|
||||
"composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b",
|
||||
"composOpFold z c f = unC . compos (\\_ -> C z) (\\(C x) (C y) -> C (c x y)) (C . f)",
|
||||
"",
|
||||
"newtype C b a = C { unC :: b }"
|
||||
]
|
||||
43
src/compiler/api/GF/Compile/PGFtoJava.hs
Normal file
43
src/compiler/api/GF/Compile/PGFtoJava.hs
Normal file
@@ -0,0 +1,43 @@
|
||||
module GF.Compile.PGFtoJava (grammar2java) where
|
||||
|
||||
import PGF2
|
||||
import Data.Maybe(maybe)
|
||||
import Data.List(intercalate)
|
||||
import GF.Infra.Option
|
||||
|
||||
-- | the main function
|
||||
grammar2java :: Options
|
||||
-> String -- ^ Module name.
|
||||
-> PGF
|
||||
-> String
|
||||
grammar2java opts name gr = unlines $
|
||||
javaPreamble name ++ methods ++ javaEnding
|
||||
where
|
||||
methods = [javaMethod gr fun | fun <- functions gr]
|
||||
|
||||
javaPreamble name =
|
||||
[
|
||||
"import org.grammaticalframework.pgf.*;",
|
||||
"",
|
||||
"public class " ++ name ++ " {",
|
||||
""
|
||||
]
|
||||
|
||||
javaMethod gr fun =
|
||||
" public static Expr "++fun++"("++arg_decls++") { return new Expr("++show fun++args++"); }"
|
||||
where
|
||||
arity = maybe 0 getArrity (functionType gr fun)
|
||||
vars = ['e':show i | i <- [1..arity]]
|
||||
|
||||
arg_decls = intercalate "," ["Expr "++v | v <- vars]
|
||||
args = if null vars then ",new Expr[] {}" else ","++intercalate "," vars
|
||||
|
||||
getArrity ty = length hypos
|
||||
where
|
||||
(hypos,_,_) = unType ty
|
||||
|
||||
javaEnding =
|
||||
[
|
||||
"",
|
||||
"}"
|
||||
]
|
||||
277
src/compiler/api/GF/Compile/ReadFiles.hs
Normal file
277
src/compiler/api/GF/Compile/ReadFiles.hs
Normal file
@@ -0,0 +1,277 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : ReadFiles
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/11/11 23:24:34 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.26 $
|
||||
--
|
||||
-- Decide what files to read as function of dependencies and time stamps.
|
||||
--
|
||||
-- make analysis for GF grammar modules. AR 11\/6\/2003--24\/2\/2004
|
||||
--
|
||||
-- to find all files that have to be read, put them in dependency order, and
|
||||
-- decide which files need recompilation. Name @file.gf@ is returned for them,
|
||||
-- and @file.gfo@ otherwise.
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Compile.ReadFiles
|
||||
( getAllFiles,ModName,ModEnv,importsOfModule,
|
||||
findFile,gfImports,gfoImports,VersionTagged(..),
|
||||
parseSource,getOptionsFromFile,getPragmas) where
|
||||
|
||||
import Prelude hiding (catch)
|
||||
import GF.System.Catch
|
||||
import GF.Infra.UseIO
|
||||
import GF.Infra.Option
|
||||
import GF.Infra.Ident
|
||||
import GF.Data.Operations
|
||||
import GF.Grammar.Lexer
|
||||
import GF.Grammar.Parser
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Binary(VersionTagged(..),decodeModuleHeader)
|
||||
|
||||
import System.IO(mkTextEncoding)
|
||||
import GF.Text.Coding(decodeUnicodeIO)
|
||||
|
||||
import qualified Data.ByteString.UTF8 as UTF8
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
|
||||
import Control.Monad
|
||||
import Data.Maybe(isJust)
|
||||
import Data.Char(isSpace)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Time(UTCTime)
|
||||
import GF.System.Directory(getModificationTime,doesFileExist,canonicalizePath)
|
||||
import System.FilePath
|
||||
import GF.Text.Pretty
|
||||
|
||||
type ModName = String
|
||||
type ModEnv = Map.Map ModName (UTCTime,[ModName])
|
||||
|
||||
|
||||
-- | Returns a list of all files to be compiled in topological order i.e.
|
||||
-- the low level (leaf) modules are first.
|
||||
--getAllFiles :: (MonadIO m,ErrorMonad m) => Options -> [InitPath] -> ModEnv -> FileName -> m [FullPath]
|
||||
getAllFiles opts ps env file = do
|
||||
-- read module headers from all files recursively
|
||||
ds <- reverse `fmap` get [] [] (justModuleName file)
|
||||
putIfVerb opts $ "all modules:" +++ show [name | (name,_,_,_,_,_) <- ds]
|
||||
return $ paths ds
|
||||
where
|
||||
-- construct list of paths to read
|
||||
paths ds = concatMap mkFile ds
|
||||
where
|
||||
mkFile (f,st,time,has_src,imps,p) =
|
||||
case st of
|
||||
CSComp -> [p </> gfFile f]
|
||||
CSRead | has_src -> [gf2gfo opts (p </> gfFile f)]
|
||||
| otherwise -> [p </> gfoFile f]
|
||||
CSEnv -> []
|
||||
|
||||
-- | traverses the dependency graph and returns a topologicaly sorted
|
||||
-- list of ModuleInfo. An error is raised if there is circular dependency
|
||||
{- get :: [ModName] -- ^ keeps the current path in the dependency graph to avoid cycles
|
||||
-> [ModuleInfo] -- ^ a list of already traversed modules
|
||||
-> ModName -- ^ the current module
|
||||
-> IOE [ModuleInfo] -- ^ the final -}
|
||||
get trc ds name
|
||||
| name `elem` trc = raise $ "circular modules" +++ unwords trc
|
||||
| (not . null) [n | (n,_,_,_,_,_) <- ds, name == n] --- file already read
|
||||
= return ds
|
||||
| otherwise = do
|
||||
(name,st0,t0,has_src,imps,p) <- findModule name
|
||||
ds <- foldM (get (name:trc)) ds imps
|
||||
let (st,t) | has_src &&
|
||||
flag optRecomp opts == RecompIfNewer &&
|
||||
(not . null) [f | (f,st,t1,_,_,_) <- ds, elem f imps && liftM2 (>=) t0 t1 /= Just True]
|
||||
= (CSComp,Nothing)
|
||||
| otherwise = (st0,t0)
|
||||
return ((name,st,t,has_src,imps,p):ds)
|
||||
|
||||
gfoDir = flag optGFODir opts
|
||||
|
||||
-- searches for module in the search path and if it is found
|
||||
-- returns 'ModuleInfo'. It fails if there is no such module
|
||||
--findModule :: ModName -> IOE ModuleInfo
|
||||
findModule name = do
|
||||
(file,gfTime,gfoTime) <- findFile gfoDir ps name
|
||||
|
||||
let mb_envmod = Map.lookup name env
|
||||
(st,t) = selectFormat opts (fmap fst mb_envmod) gfTime gfoTime
|
||||
|
||||
(st,(mname,imps)) <-
|
||||
case st of
|
||||
CSEnv -> return (st, (name, maybe [] snd mb_envmod))
|
||||
CSRead -> do let gfo = if isGFO file then file else gf2gfo opts file
|
||||
t_imps <- gfoImports gfo
|
||||
case t_imps of
|
||||
Tagged imps -> return (st,imps)
|
||||
WrongVersion
|
||||
| isGFO file -> raise (file ++ " is compiled with different GF version and I can't find the source file")
|
||||
| otherwise -> do imps <- gfImports opts file
|
||||
return (CSComp,imps)
|
||||
CSComp -> do imps <- gfImports opts file
|
||||
return (st,imps)
|
||||
testErr (mname == name)
|
||||
("module name" +++ mname +++ "differs from file name" +++ name)
|
||||
return (name,st,t,isJust gfTime,imps,dropFileName file)
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
findFile gfoDir ps name =
|
||||
maybe noSource haveSource =<< getFilePath ps (gfFile name)
|
||||
where
|
||||
haveSource gfFile =
|
||||
do gfTime <- getModificationTime gfFile
|
||||
mb_gfoTime <- maybeIO $ getModificationTime (gf2gfo' gfoDir gfFile)
|
||||
return (gfFile, Just gfTime, mb_gfoTime)
|
||||
|
||||
noSource =
|
||||
maybe noGFO haveGFO =<< getFilePath gfoPath (gfoFile name)
|
||||
where
|
||||
gfoPath = maybe id (:) gfoDir ps
|
||||
|
||||
haveGFO gfoFile =
|
||||
do gfoTime <- getModificationTime gfoFile
|
||||
return (gfoFile, Nothing, Just gfoTime)
|
||||
|
||||
noGFO = raise (render ("File" <+> gfFile name <+> "does not exist." $$
|
||||
"searched in:" <+> vcat ps))
|
||||
|
||||
gfImports opts file = importsOfModule `fmap` parseModHeader opts file
|
||||
|
||||
gfoImports gfo = fmap importsOfModule `fmap` decodeModuleHeader gfo
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- From the given Options and the time stamps computes
|
||||
-- whether the module have to be computed, read from .gfo or
|
||||
-- the environment version have to be used
|
||||
selectFormat :: Options -> Maybe UTCTime -> Maybe UTCTime -> Maybe UTCTime -> (CompStatus,Maybe UTCTime)
|
||||
selectFormat opts mtenv mtgf mtgfo =
|
||||
case (mtenv,mtgfo,mtgf) of
|
||||
(_,_,Just tgf) | fromSrc -> (CSComp,Nothing)
|
||||
(Just tenv,_,_) | fromComp -> (CSEnv, Just tenv)
|
||||
(_,Just tgfo,_) | fromComp -> (CSRead,Just tgfo)
|
||||
(Just tenv,_,Just tgf) | tenv > tgf -> (CSEnv, Just tenv)
|
||||
(_,Just tgfo,Just tgf) | tgfo > tgf -> (CSRead,Just tgfo)
|
||||
(Just tenv,_,Nothing) -> (CSEnv,Just tenv) -- source does not exist
|
||||
(_,Just tgfo,Nothing) -> (CSRead,Just tgfo) -- source does not exist
|
||||
_ -> (CSComp,Nothing)
|
||||
where
|
||||
fromComp = flag optRecomp opts == NeverRecomp
|
||||
fromSrc = flag optRecomp opts == AlwaysRecomp
|
||||
|
||||
|
||||
-- internal module dep information
|
||||
|
||||
|
||||
data CompStatus =
|
||||
CSComp -- compile: read gf
|
||||
| CSRead -- read gfo
|
||||
| CSEnv -- gfo is in env
|
||||
deriving Eq
|
||||
|
||||
type ModuleInfo = (ModName,CompStatus,Maybe UTCTime,Bool,[ModName],InitPath)
|
||||
|
||||
importsOfModule :: SourceModule -> (ModName,[ModName])
|
||||
importsOfModule (m,mi) = (modName m,depModInfo mi [])
|
||||
where
|
||||
depModInfo mi =
|
||||
depModType (mtype mi) .
|
||||
depExtends (mextend mi) .
|
||||
depWith (mwith mi) .
|
||||
depExDeps (mexdeps mi).
|
||||
depOpens (mopens mi)
|
||||
|
||||
depModType (MTAbstract) xs = xs
|
||||
depModType (MTResource) xs = xs
|
||||
depModType (MTInterface) xs = xs
|
||||
depModType (MTConcrete m2) xs = modName m2:xs
|
||||
depModType (MTInstance (m2,_)) xs = modName m2:xs
|
||||
|
||||
depExtends es xs = foldr depInclude xs es
|
||||
|
||||
depWith (Just (m,_,is)) xs = modName m : depInsts is xs
|
||||
depWith Nothing xs = xs
|
||||
|
||||
depExDeps eds xs = map modName eds ++ xs
|
||||
|
||||
depOpens os xs = foldr depOpen xs os
|
||||
|
||||
depInsts is xs = foldr depInst xs is
|
||||
|
||||
depInclude (m,_) xs = modName m:xs
|
||||
|
||||
depOpen (OSimple n ) xs = modName n:xs
|
||||
depOpen (OQualif _ n) xs = modName n:xs
|
||||
|
||||
depInst (m,n) xs = modName m:modName n:xs
|
||||
|
||||
modName (MN m) = showIdent m
|
||||
|
||||
|
||||
parseModHeader opts file =
|
||||
do --ePutStrLn file
|
||||
(_,parsed) <- parseSource opts pModHeader =<< liftIO (BS.readFile file)
|
||||
case parsed of
|
||||
Right mo -> return mo
|
||||
Left (Pn l c,msg) ->
|
||||
raise (file ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg)
|
||||
|
||||
parseSource opts p raw =
|
||||
do (coding,utf8) <- toUTF8 opts raw
|
||||
return (coding,runP p utf8)
|
||||
|
||||
toUTF8 opts0 raw =
|
||||
do opts <- getPragmas raw
|
||||
let given = flag optEncoding opts -- explicitly given encoding
|
||||
coding = getEncoding $ opts0 `addOptions` opts
|
||||
utf8 <- if coding=="UTF-8"
|
||||
then return raw
|
||||
else if coding=="CP1252" -- Latin1
|
||||
then return . UTF8.fromString $ BS.unpack raw -- faster
|
||||
else do --ePutStrLn $ "toUTF8 from "++coding
|
||||
recodeToUTF8 coding raw
|
||||
return (given,utf8)
|
||||
|
||||
recodeToUTF8 coding raw =
|
||||
liftIO $
|
||||
do enc <- mkTextEncoding coding
|
||||
-- decodeUnicodeIO uses a lot of stack space,
|
||||
-- so we need to split the file into smaller pieces
|
||||
ls <- mapM (decodeUnicodeIO enc) (BS.lines raw)
|
||||
return $ UTF8.fromString (unlines ls)
|
||||
|
||||
-- | options can be passed to the compiler by comments in @--#@, in the main file
|
||||
--getOptionsFromFile :: (MonadIO m,ErrorMonad m) => FilePath -> m Options
|
||||
getOptionsFromFile file = do
|
||||
opts <- either failed getPragmas =<< (liftIO $ try $ BS.readFile file)
|
||||
-- The coding flag should not be inherited by other files
|
||||
return (addOptions opts (modifyFlags $ \ f -> f{optEncoding=Nothing}))
|
||||
where
|
||||
failed _ = raise $ "File " ++ file ++ " does not exist"
|
||||
|
||||
|
||||
getPragmas :: (ErrorMonad m) => BS.ByteString -> m Options
|
||||
getPragmas = parseModuleOptions .
|
||||
map (BS.unpack . BS.unwords . BS.words . BS.drop 3) .
|
||||
filter (BS.isPrefixOf (BS.pack "--#")) .
|
||||
-- takeWhile (BS.isPrefixOf (BS.pack "--")) .
|
||||
-- filter (not . BS.null) .
|
||||
map (BS.dropWhile isSpace) .
|
||||
BS.lines
|
||||
|
||||
getFilePath :: MonadIO m => [FilePath] -> String -> m (Maybe FilePath)
|
||||
getFilePath paths file = get paths
|
||||
where
|
||||
get [] = return Nothing
|
||||
get (p:ps) = do let pfile = p </> file
|
||||
exist <- doesFileExist pfile
|
||||
if not exist
|
||||
then get ps
|
||||
else do pfile <- canonicalizePath pfile
|
||||
return (Just pfile)
|
||||
345
src/compiler/api/GF/Compile/Rename.hs
Normal file
345
src/compiler/api/GF/Compile/Rename.hs
Normal file
@@ -0,0 +1,345 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Rename
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/05/30 18:39:44 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.19 $
|
||||
--
|
||||
-- AR 14\/5\/2003
|
||||
-- The top-level function 'renameGrammar' does several things:
|
||||
--
|
||||
-- - extends each module symbol table by indirections to extended module
|
||||
--
|
||||
-- - changes unqualified and as-qualified imports to absolutely qualified
|
||||
--
|
||||
-- - goes through the definitions and resolves names
|
||||
--
|
||||
-- Dependency analysis between modules has been performed before this pass.
|
||||
-- Hence we can proceed by @fold@ing "from left to right".
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Compile.Rename (
|
||||
renameSourceTerm,
|
||||
renameModule
|
||||
) where
|
||||
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.CheckM
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Values
|
||||
import GF.Grammar.Predef
|
||||
import GF.Grammar.Lookup
|
||||
import GF.Grammar.Macros
|
||||
import GF.Grammar.Printer
|
||||
import GF.Data.Operations
|
||||
|
||||
import Control.Monad
|
||||
import Data.List (nub,(\\))
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe(mapMaybe)
|
||||
import GF.Text.Pretty
|
||||
|
||||
-- | this gives top-level access to renaming term input in the cc command
|
||||
renameSourceTerm :: Grammar -> ModuleName -> Term -> Check Term
|
||||
renameSourceTerm g m t = do
|
||||
mi <- lookupModule g m
|
||||
status <- buildStatus "" g (m,mi)
|
||||
renameTerm status [] t
|
||||
|
||||
renameModule :: FilePath -> Grammar -> Module -> Check Module
|
||||
renameModule cwd gr mo@(m,mi) = do
|
||||
status <- buildStatus cwd gr mo
|
||||
js <- checkMapRecover (renameInfo cwd status mo) (jments mi)
|
||||
return (m, mi{jments = js})
|
||||
|
||||
type Status = (StatusMap, [(OpenSpec, StatusMap)])
|
||||
|
||||
type StatusMap = Map.Map Ident StatusInfo
|
||||
|
||||
type StatusInfo = Ident -> Term
|
||||
|
||||
-- Delays errors, allowing many errors to be detected and reported
|
||||
renameIdentTerm env = accumulateError (renameIdentTerm' env)
|
||||
|
||||
-- Fails immediately on error, makes it possible to try other possibilities
|
||||
renameIdentTerm' :: Status -> Term -> Check Term
|
||||
renameIdentTerm' env@(act,imps) t0 =
|
||||
case t0 of
|
||||
Vr c -> ident predefAbs c
|
||||
Cn c -> ident (\_ s -> checkError s) c
|
||||
Q (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0
|
||||
Q (m',c) -> do
|
||||
m <- lookupErr m' qualifs
|
||||
f <- lookupIdent c m
|
||||
return $ f c
|
||||
QC (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0
|
||||
QC (m',c) -> do
|
||||
m <- lookupErr m' qualifs
|
||||
f <- lookupIdent c m
|
||||
return $ f c
|
||||
_ -> return t0
|
||||
where
|
||||
opens = [st | (OSimple _,st) <- imps]
|
||||
qualifs = [(m, st) | (OQualif m _, st) <- imps] ++
|
||||
[(m, st) | (OQualif _ m, st) <- imps] ++
|
||||
[(m, st) | (OSimple m, st) <- imps] -- qualif is always possible
|
||||
|
||||
-- this facility is mainly for BWC with GF1: you need not import PredefAbs
|
||||
predefAbs c s
|
||||
| isPredefCat c = return (Q (cPredefAbs,c))
|
||||
| otherwise = checkError s
|
||||
|
||||
ident alt c =
|
||||
case Map.lookup c act of
|
||||
Just f -> return (f c)
|
||||
_ -> case mapMaybe (Map.lookup c) opens of
|
||||
[f] -> return (f c)
|
||||
[] -> alt c ("constant not found:" <+> c $$
|
||||
"given" <+> fsep (punctuate ',' (map fst qualifs)))
|
||||
fs -> case nub [f c | f <- fs] of
|
||||
[tr] -> return tr
|
||||
ts@(t:_) -> do checkWarn ("atomic term" <+> ppTerm Qualified 0 t0 $$
|
||||
"conflict" <+> hsep (punctuate ',' (map (ppTerm Qualified 0) ts)) $$
|
||||
"given" <+> fsep (punctuate ',' (map fst qualifs)))
|
||||
return (bestTerm ts) -- Heuristic for resource grammar. Returns t for all others.
|
||||
where
|
||||
-- Hotfix for https://github.com/GrammaticalFramework/gf-core/issues/56
|
||||
-- Real bug is probably somewhere deeper in recognising excluded functions. /IL 2020-06-06
|
||||
notFromCommonModule :: Term -> Bool
|
||||
notFromCommonModule term =
|
||||
let t = render $ ppTerm Qualified 0 term :: String
|
||||
in not $ any (\moduleName -> moduleName `L.isPrefixOf` t)
|
||||
["CommonX", "ConstructX", "ExtendFunctor"
|
||||
,"MarkHTMLX", "ParamX", "TenseX", "TextX"]
|
||||
|
||||
-- If one of the terms comes from the common modules,
|
||||
-- we choose the other one, because that's defined in the grammar.
|
||||
bestTerm :: [Term] -> Term
|
||||
bestTerm [] = error "constant not found" -- not reached: bestTerm is only called for case ts@(t:_)
|
||||
bestTerm ts@(t:_) =
|
||||
let notCommon = [t | t <- ts, notFromCommonModule t]
|
||||
in case notCommon of
|
||||
[] -> t -- All terms are from common modules, return first of original list
|
||||
(u:_) -> u -- ≥1 terms are not from common modules, return first of those
|
||||
|
||||
info2status :: Maybe ModuleName -> Ident -> Info -> StatusInfo
|
||||
info2status mq c i = case i of
|
||||
AbsFun _ _ Nothing _ -> maybe Con (curry QC) mq
|
||||
ResValue _ _ -> maybe Con (curry QC) mq
|
||||
ResParam _ _ -> maybe Con (curry QC) mq
|
||||
AnyInd True m -> maybe Con (const (curry QC m)) mq
|
||||
AnyInd False m -> maybe Cn (const (curry Q m)) mq
|
||||
_ -> maybe Cn (curry Q) mq
|
||||
|
||||
tree2status :: OpenSpec -> Map.Map Ident Info -> StatusMap
|
||||
tree2status o = case o of
|
||||
OSimple i -> Map.mapWithKey (info2status (Just i))
|
||||
OQualif i j -> Map.mapWithKey (info2status (Just j))
|
||||
|
||||
buildStatus :: FilePath -> Grammar -> Module -> Check Status
|
||||
buildStatus cwd gr mo@(m,mi) = checkInModule cwd mi NoLoc empty $ do
|
||||
let gr1 = prependModule gr mo
|
||||
exts = [(OSimple m,mi) | (m,mi) <- allExtends gr1 m]
|
||||
ops <- mapM (\o -> lookupModule gr1 (openedModule o) >>= \mi -> return (o,mi)) (mopens mi)
|
||||
let sts = map modInfo2status (exts++ops)
|
||||
return (if isModCnc mi
|
||||
then (Map.empty, reverse sts) -- the module itself does not define any names
|
||||
else (self2status m mi,reverse sts)) -- so the empty ident is not needed
|
||||
|
||||
modInfo2status :: (OpenSpec,ModuleInfo) -> (OpenSpec, StatusMap)
|
||||
modInfo2status (o,mo) = (o,tree2status o (jments mo))
|
||||
|
||||
self2status :: ModuleName -> ModuleInfo -> StatusMap
|
||||
self2status c m = Map.mapWithKey (info2status (Just c)) (jments m)
|
||||
|
||||
|
||||
renameInfo :: FilePath -> Status -> Module -> Ident -> Info -> Check Info
|
||||
renameInfo cwd status (m,mi) i info =
|
||||
case info of
|
||||
AbsCat pco -> liftM AbsCat (renPerh (renameContext status) pco)
|
||||
AbsFun pty pa ptr poper -> liftM4 AbsFun (renTerm pty) (return pa) (renMaybe (mapM (renLoc (renEquation status))) ptr) (return poper)
|
||||
ResOper pty ptr -> liftM2 ResOper (renTerm pty) (renTerm ptr)
|
||||
ResOverload os tysts -> liftM (ResOverload os) (mapM (renPair (renameTerm status [])) tysts)
|
||||
ResParam (Just pp) m -> do
|
||||
pp' <- renLoc (mapM (renParam status)) pp
|
||||
return (ResParam (Just pp') m)
|
||||
ResValue t i -> do
|
||||
t <- renLoc (renameTerm status []) t
|
||||
return (ResValue t i)
|
||||
CncCat mcat mdef mref mpr mpmcfg -> liftM5 CncCat (renTerm mcat) (renTerm mdef) (renTerm mref) (renTerm mpr) (return mpmcfg)
|
||||
CncFun mty mtr mpr mpmcfg -> liftM3 (CncFun mty) (renTerm mtr) (renTerm mpr) (return mpmcfg)
|
||||
_ -> return info
|
||||
where
|
||||
renTerm = renPerh (renameTerm status [])
|
||||
|
||||
renPerh ren = renMaybe (renLoc ren)
|
||||
|
||||
renMaybe ren (Just x) = ren x >>= return . Just
|
||||
renMaybe ren Nothing = return Nothing
|
||||
|
||||
renLoc ren (L loc x) =
|
||||
checkInModule cwd mi loc ("Happened in the renaming of" <+> i) $ do
|
||||
x <- ren x
|
||||
return (L loc x)
|
||||
|
||||
renPair ren (x, y) = do x <- renLoc ren x
|
||||
y <- renLoc ren y
|
||||
return (x, y)
|
||||
|
||||
renEquation :: Status -> Equation -> Check Equation
|
||||
renEquation b (ps,t) = do
|
||||
(ps',vs) <- liftM unzip $ mapM (renamePattern b) ps
|
||||
t' <- renameTerm b (concat vs) t
|
||||
return (ps',t')
|
||||
|
||||
renParam :: Status -> Param -> Check Param
|
||||
renParam env (c,co) = do
|
||||
co' <- renameContext env co
|
||||
return (c,co')
|
||||
|
||||
renameTerm :: Status -> [Ident] -> Term -> Check Term
|
||||
renameTerm env vars = ren vars where
|
||||
ren vs trm = case trm of
|
||||
Abs b x t -> liftM (Abs b x) (ren (x:vs) t)
|
||||
Prod bt x a b -> liftM2 (Prod bt x) (ren vs a) (ren (x:vs) b)
|
||||
Typed a b -> liftM2 Typed (ren vs a) (ren vs b)
|
||||
Vr x
|
||||
| elem x vs -> return trm
|
||||
| otherwise -> renid trm
|
||||
Cn _ -> renid trm
|
||||
Con _ -> renid trm
|
||||
Q _ -> renid trm
|
||||
QC _ -> renid trm
|
||||
T i cs -> do
|
||||
i' <- case i of
|
||||
TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source
|
||||
_ -> return i
|
||||
liftM (T i') $ mapM (renCase vs) cs
|
||||
|
||||
Let (x,(m,a)) b -> do
|
||||
m' <- case m of
|
||||
Just ty -> liftM Just $ ren vs ty
|
||||
_ -> return m
|
||||
a' <- ren vs a
|
||||
b' <- ren (x:vs) b
|
||||
return $ Let (x,(m',a')) b'
|
||||
|
||||
P t@(Vr r) l -- Here we have $r.l$ and this is ambiguous it could be either
|
||||
-- record projection from variable or constant $r$ or qualified expression with module $r$
|
||||
| elem r vs -> return trm -- try var proj first ..
|
||||
| otherwise -> checks [ renid' (Q (MN r,label2ident l)) -- .. and qualified expression second.
|
||||
, renid' t >>= \t -> return (P t l) -- try as a constant at the end
|
||||
, checkError ("unknown qualified constant" <+> trm)
|
||||
]
|
||||
|
||||
EPatt minp maxp p -> do
|
||||
(p',_) <- renpatt p
|
||||
return $ EPatt minp maxp p'
|
||||
|
||||
_ -> composOp (ren vs) trm
|
||||
|
||||
renid = renameIdentTerm env
|
||||
renid' = renameIdentTerm' env
|
||||
renCase vs (p,t) = do
|
||||
(p',vs') <- renpatt p
|
||||
t' <- ren (vs' ++ vs) t
|
||||
return (p',t')
|
||||
renpatt = renamePattern env
|
||||
|
||||
-- | vars not needed in env, since patterns always overshadow old vars
|
||||
renamePattern :: Status -> Patt -> Check (Patt,[Ident])
|
||||
renamePattern env patt =
|
||||
do r@(p',vs) <- renp patt
|
||||
let dupl = vs \\ nub vs
|
||||
unless (null dupl) $ checkError (hang ("[C.4.13] Pattern is not linear. All variable names on the left-hand side must be distinct.") 4
|
||||
patt)
|
||||
return r
|
||||
where
|
||||
renp patt = case patt of
|
||||
PMacro c -> do
|
||||
c' <- renid $ Vr c
|
||||
case c' of
|
||||
Q d -> renp $ PM d
|
||||
_ -> checkError ("unresolved pattern" <+> patt)
|
||||
|
||||
PC c ps -> do
|
||||
c' <- renid $ Cn c
|
||||
case c' of
|
||||
QC c -> do psvss <- mapM renp ps
|
||||
let (ps,vs) = unzip psvss
|
||||
return (PP c ps, concat vs)
|
||||
Q _ -> checkError ("data constructor expected but" <+> ppTerm Qualified 0 c' <+> "is found instead")
|
||||
_ -> checkError ("unresolved data constructor" <+> ppTerm Qualified 0 c')
|
||||
|
||||
PP c ps -> do
|
||||
(QC c') <- renid (QC c)
|
||||
psvss <- mapM renp ps
|
||||
let (ps',vs) = unzip psvss
|
||||
return (PP c' ps', concat vs)
|
||||
|
||||
PM c -> do
|
||||
x <- renid (Q c)
|
||||
c' <- case x of
|
||||
(Q c') -> return c'
|
||||
_ -> checkError ("not a pattern macro" <+> ppPatt Qualified 0 patt)
|
||||
return (PM c', [])
|
||||
|
||||
PV x -> checks [ renid' (Vr x) >>= \t' -> case t' of
|
||||
QC c -> return (PP c [],[])
|
||||
_ -> checkError (pp "not a constructor")
|
||||
, return (patt, [x])
|
||||
]
|
||||
|
||||
PR r -> do
|
||||
let (ls,ps) = unzip r
|
||||
psvss <- mapM renp ps
|
||||
let (ps',vs') = unzip psvss
|
||||
return (PR (zip ls ps'), concat vs')
|
||||
|
||||
PAlt p q -> do
|
||||
(p',vs) <- renp p
|
||||
(q',ws) <- renp q
|
||||
return (PAlt p' q', vs ++ ws)
|
||||
|
||||
PSeq minp maxp p minq maxq q -> do
|
||||
(p',vs) <- renp p
|
||||
(q',ws) <- renp q
|
||||
return (PSeq minp maxp p' minq maxq q', vs ++ ws)
|
||||
|
||||
PRep minp maxp p -> do
|
||||
(p',vs) <- renp p
|
||||
return (PRep minp maxp p', vs)
|
||||
|
||||
PNeg p -> do
|
||||
(p',vs) <- renp p
|
||||
return (PNeg p', vs)
|
||||
|
||||
PAs x p -> do
|
||||
(p',vs) <- renp p
|
||||
return (PAs x p', x:vs)
|
||||
|
||||
_ -> return (patt,[])
|
||||
|
||||
renid = renameIdentTerm env
|
||||
renid' = renameIdentTerm' env
|
||||
|
||||
renameContext :: Status -> Context -> Check Context
|
||||
renameContext b = renc [] where
|
||||
renc vs cont = case cont of
|
||||
(bt,x,t) : xts
|
||||
| x == identW -> do
|
||||
t' <- ren vs t
|
||||
xts' <- renc vs xts
|
||||
return $ (bt,x,t') : xts'
|
||||
| otherwise -> do
|
||||
t' <- ren vs t
|
||||
let vs' = x:vs
|
||||
xts' <- renc vs' xts
|
||||
return $ (bt,x,t') : xts'
|
||||
_ -> return cont
|
||||
ren = renameTerm b
|
||||
141
src/compiler/api/GF/Compile/SubExOpt.hs
Normal file
141
src/compiler/api/GF/Compile/SubExOpt.hs
Normal file
@@ -0,0 +1,141 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : SubExOpt
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- This module implements a simple common subexpression elimination
|
||||
-- for .gfo grammars, to factor out shared subterms in lin rules.
|
||||
-- It works in three phases:
|
||||
--
|
||||
-- (1) collectSubterms collects recursively all subterms of forms table and (P x..y)
|
||||
-- from lin definitions (experience shows that only these forms
|
||||
-- tend to get shared) and counts how many times they occur
|
||||
-- (2) addSubexpConsts takes those subterms t that occur more than once
|
||||
-- and creates definitions of form "oper A''n = t" where n is a
|
||||
-- fresh number; notice that we assume no ids of this form are in
|
||||
-- scope otherwise
|
||||
-- (3) elimSubtermsMod goes through lins and the created opers by replacing largest
|
||||
-- possible subterms by the newly created identifiers
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module GF.Compile.SubExOpt (subexpModule,unsubexpModule) where
|
||||
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Lookup(lookupResDef)
|
||||
import GF.Infra.Ident
|
||||
import qualified GF.Grammar.Macros as C
|
||||
import GF.Data.ErrM(fromErr)
|
||||
|
||||
import Control.Monad.State.Strict(State,evalState,get,put)
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
|
||||
--subexpModule :: SourceModule -> SourceModule
|
||||
subexpModule (n,mo) =
|
||||
let ljs = Map.toList (jments mo)
|
||||
tree = evalState (getSubtermsMod n ljs) (Map.empty,0)
|
||||
js2 = Map.fromList $ addSubexpConsts n tree $ ljs
|
||||
in (n,mo{jments=js2})
|
||||
|
||||
--unsubexpModule :: SourceModule -> SourceModule
|
||||
unsubexpModule sm@(i,mo)
|
||||
| hasSub ljs = (i,mo{jments=rebuild (map unparInfo ljs)})
|
||||
| otherwise = sm
|
||||
where
|
||||
ljs = Map.toList (jments mo)
|
||||
|
||||
-- perform this iff the module has opers
|
||||
hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs]
|
||||
unparInfo (c,info) = case info of
|
||||
CncFun xs (Just (L loc t)) m pf -> [(c, CncFun xs (Just (L loc (unparTerm t))) m pf)]
|
||||
ResOper (Just (L loc (EInt 8))) _ -> [] -- subexp-generated opers
|
||||
ResOper pty (Just (L loc t)) -> [(c, ResOper pty (Just (L loc (unparTerm t))))]
|
||||
_ -> [(c,info)]
|
||||
unparTerm t = case t of
|
||||
Q (m,c) | isOperIdent c -> --- name convention of subexp opers
|
||||
fromErr t $ fmap unparTerm $ lookupResDef gr (m,c)
|
||||
_ -> C.composSafeOp unparTerm t
|
||||
gr = mGrammar [sm]
|
||||
rebuild = Map.fromList . concat
|
||||
|
||||
-- implementation
|
||||
|
||||
type TermList = Map Term (Int,Int) -- number of occs, id
|
||||
type TermM a = State (TermList,Int) a
|
||||
|
||||
addSubexpConsts ::
|
||||
ModuleName -> Map Term (Int,Int) -> [(Ident,Info)] -> [(Ident,Info)]
|
||||
addSubexpConsts mo tree lins = do
|
||||
let opers = [oper id trm | (trm,(_,id)) <- list]
|
||||
map mkOne $ opers ++ lins
|
||||
where
|
||||
mkOne (f,def) = case def of
|
||||
CncFun xs (Just (L loc trm)) pn pf ->
|
||||
let trm' = recomp f trm
|
||||
in (f,CncFun xs (Just (L loc trm')) pn pf)
|
||||
ResOper ty (Just (L loc trm)) ->
|
||||
let trm' = recomp f trm
|
||||
in (f,ResOper ty (Just (L loc trm')))
|
||||
_ -> (f,def)
|
||||
recomp f t = case Map.lookup t tree of
|
||||
Just (_,id) | operIdent id /= f -> Q (mo, operIdent id)
|
||||
_ -> C.composSafeOp (recomp f) t
|
||||
|
||||
list = Map.toList tree
|
||||
|
||||
oper id trm = (operIdent id, ResOper (Just (L NoLoc (EInt 8))) (Just (L NoLoc trm)))
|
||||
--- impossible type encoding generated opers
|
||||
|
||||
getSubtermsMod :: ModuleName -> [(Ident,Info)] -> TermM (Map Term (Int,Int))
|
||||
getSubtermsMod mo js = do
|
||||
mapM (getInfo (collectSubterms mo)) js
|
||||
(tree0,_) <- get
|
||||
return $ Map.filter (\ (nu,_) -> nu > 1) tree0
|
||||
where
|
||||
getInfo get fi@(f,i) = case i of
|
||||
CncFun xs (Just (L _ trm)) pn _ -> do
|
||||
get trm
|
||||
return $ fi
|
||||
ResOper ty (Just (L _ trm)) -> do
|
||||
get trm
|
||||
return $ fi
|
||||
_ -> return fi
|
||||
|
||||
collectSubterms :: ModuleName -> Term -> TermM Term
|
||||
collectSubterms mo t = case t of
|
||||
App f a -> do
|
||||
collect f
|
||||
collect a
|
||||
add t
|
||||
T ty cs -> do
|
||||
let (_,ts) = unzip cs
|
||||
mapM collect ts
|
||||
add t
|
||||
V ty ts -> do
|
||||
mapM collect ts
|
||||
add t
|
||||
---- K (KP _ _) -> add t
|
||||
_ -> C.composOp (collectSubterms mo) t
|
||||
where
|
||||
collect = collectSubterms mo
|
||||
add t = do
|
||||
(ts,i) <- get
|
||||
let
|
||||
((count,id),next) = case Map.lookup t ts of
|
||||
Just (nu,id) -> ((nu+1,id), i)
|
||||
_ -> ((1, i ), i+1)
|
||||
put (Map.insert t (count,id) ts, next)
|
||||
return t --- only because of composOp
|
||||
|
||||
operIdent :: Int -> Ident
|
||||
operIdent i = identC (operPrefix `prefixRawIdent` (rawIdentS (show i))) ---
|
||||
|
||||
isOperIdent :: Ident -> Bool
|
||||
isOperIdent id = isPrefixOf operPrefix (ident2raw id)
|
||||
|
||||
operPrefix = rawIdentS ("A''")
|
||||
89
src/compiler/api/GF/Compile/Tags.hs
Normal file
89
src/compiler/api/GF/Compile/Tags.hs
Normal file
@@ -0,0 +1,89 @@
|
||||
module GF.Compile.Tags
|
||||
( writeTags
|
||||
, gf2gftags
|
||||
) where
|
||||
|
||||
import GF.Infra.Option
|
||||
import GF.Infra.UseIO
|
||||
import GF.Data.Operations
|
||||
import GF.Grammar
|
||||
|
||||
--import Data.List
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
--import Control.Monad
|
||||
import GF.Text.Pretty
|
||||
import System.FilePath
|
||||
|
||||
writeTags opts gr file mo = do
|
||||
let imports = getImports opts gr mo
|
||||
locals = getLocalTags [] mo
|
||||
txt = unlines ((Set.toList . Set.fromList) (imports++locals))
|
||||
putPointE Normal opts (" write file" +++ file) $ liftIO $ writeFile file txt
|
||||
|
||||
getLocalTags x (m,mi) =
|
||||
[showIdent i ++ "\t" ++ k ++ "\t" ++ l ++ "\t" ++ t
|
||||
| (i,jment) <- Map.toList (jments mi),
|
||||
(k,l,t) <- getLocations jment] ++ x
|
||||
where
|
||||
getLocations :: Info -> [(String,String,String)]
|
||||
getLocations (AbsCat mb_ctxt) = maybe (loc "cat") mb_ctxt
|
||||
getLocations (AbsFun mb_type _ mb_eqs _) = maybe (ltype "fun") mb_type ++
|
||||
maybe (list (loc "def")) mb_eqs
|
||||
getLocations (ResParam mb_params _) = maybe (loc "param") mb_params
|
||||
getLocations (ResValue mb_type _) = ltype "param-value" mb_type
|
||||
getLocations (ResOper mb_type mb_def) = maybe (ltype "oper-type") mb_type ++
|
||||
maybe (loc "oper-def") mb_def
|
||||
getLocations (ResOverload _ defs) = list (\(x,y) -> ltype "overload-type" x ++
|
||||
loc "overload-def" y) defs
|
||||
getLocations (CncCat mty md mr mprn _) = maybe (loc "lincat") mty ++
|
||||
maybe (loc "lindef") md ++
|
||||
maybe (loc "linref") mr ++
|
||||
maybe (loc "printname") mprn
|
||||
getLocations (CncFun _ mlin mprn _) = maybe (loc "lin") mlin ++
|
||||
maybe (loc "printname") mprn
|
||||
getLocations _ = []
|
||||
|
||||
loc kind (L loc _) = [(kind,render (ppLocation (msrc mi) loc),"")]
|
||||
|
||||
ltype kind (L loc ty) = [(kind,render (ppLocation (msrc mi) loc),render (ppTerm Unqualified 0 ty))]
|
||||
|
||||
maybe f (Just x) = f x
|
||||
maybe f Nothing = []
|
||||
|
||||
list f xs = concatMap f xs
|
||||
|
||||
render = renderStyle style{mode=OneLineMode}
|
||||
|
||||
|
||||
getImports opts gr mo@(m,mi) = concatMap toDep allOpens
|
||||
where
|
||||
allOpens = [(OSimple m,incl) | (m,incl) <- mextend mi] ++
|
||||
[(o,MIAll) | o <- mopens mi]
|
||||
|
||||
toDep (OSimple m,incl) =
|
||||
let Ok mi = lookupModule gr m
|
||||
in [showIdent id ++ "\t" ++ "indir" ++ "\t" ++ render m ++ "\t\t" ++ gf2gftags opts (orig mi info)
|
||||
| (id,info) <- Map.toList (jments mi), filter incl id]
|
||||
toDep (OQualif m1 m2,incl) =
|
||||
let Ok mi = lookupModule gr m2
|
||||
in [showIdent id ++ "\t" ++ "indir" ++ "\t" ++ render m2 ++ "\t" ++ render m1 ++ "\t" ++ gf2gftags opts (orig mi info)
|
||||
| (id,info) <- Map.toList (jments mi), filter incl id]
|
||||
|
||||
filter MIAll id = True
|
||||
filter (MIOnly ids) id = elem id ids
|
||||
filter (MIExcept ids) id = not (elem id ids)
|
||||
|
||||
orig mi info =
|
||||
case info of
|
||||
AnyInd _ m0 -> let Ok mi0 = lookupModule gr m0
|
||||
in msrc mi0
|
||||
_ -> msrc mi
|
||||
|
||||
gftagsFile :: FilePath -> FilePath
|
||||
gftagsFile f = addExtension f "gf-tags"
|
||||
|
||||
gf2gftags :: Options -> FilePath -> FilePath
|
||||
gf2gftags opts file = maybe (gftagsFile (dropExtension file))
|
||||
(\dir -> dir </> gftagsFile (dropExtension (takeFileName file)))
|
||||
(flag optOutputDir opts)
|
||||
213
src/compiler/api/GF/Compile/ToAPI.hs
Normal file
213
src/compiler/api/GF/Compile/ToAPI.hs
Normal file
File diff suppressed because one or more lines are too long
82
src/compiler/api/GF/Compile/TypeCheck/Abstract.hs
Normal file
82
src/compiler/api/GF/Compile/TypeCheck/Abstract.hs
Normal file
@@ -0,0 +1,82 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : TypeCheck
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/09/15 16:22:02 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.16 $
|
||||
--
|
||||
-- (Description of the module)
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Compile.TypeCheck.Abstract (-- * top-level type checking functions; TC should not be called directly.
|
||||
checkContext,
|
||||
checkTyp,
|
||||
checkDef,
|
||||
checkConstrs,
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
import GF.Infra.CheckM
|
||||
import GF.Grammar
|
||||
import GF.Grammar.Lookup
|
||||
import GF.Grammar.Unify
|
||||
--import GF.Compile.Refresh
|
||||
--import GF.Compile.Compute.Abstract
|
||||
import GF.Compile.TypeCheck.TC
|
||||
|
||||
import GF.Text.Pretty
|
||||
--import Control.Monad (foldM, liftM, liftM2)
|
||||
|
||||
-- | invariant way of creating TCEnv from context
|
||||
initTCEnv gamma =
|
||||
(length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma)
|
||||
|
||||
-- interface to TC type checker
|
||||
|
||||
type2val :: Type -> Val
|
||||
type2val = VClos []
|
||||
|
||||
cont2exp :: Context -> Term
|
||||
cont2exp c = mkProd c eType [] -- to check a context
|
||||
|
||||
cont2val :: Context -> Val
|
||||
cont2val = type2val . cont2exp
|
||||
|
||||
-- some top-level batch-mode checkers for the compiler
|
||||
|
||||
justTypeCheck :: SourceGrammar -> Term -> Val -> Err Constraints
|
||||
justTypeCheck gr e v = do
|
||||
(_,constrs0) <- checkExp (grammar2theory gr) (initTCEnv []) e v
|
||||
(constrs1,_) <- unifyVal constrs0
|
||||
return $ filter notJustMeta constrs1
|
||||
|
||||
notJustMeta (c,k) = case (c,k) of
|
||||
(VClos g1 (Meta m1), VClos g2 (Meta m2)) -> False
|
||||
_ -> True
|
||||
|
||||
grammar2theory :: SourceGrammar -> Theory
|
||||
grammar2theory gr (m,f) = case lookupFunType gr m f of
|
||||
Ok t -> return $ type2val t
|
||||
Bad s -> case lookupCatContext gr m f of
|
||||
Ok cont -> return $ cont2val cont
|
||||
_ -> Bad s
|
||||
|
||||
checkContext :: SourceGrammar -> Context -> [Message]
|
||||
checkContext st = checkTyp st . cont2exp
|
||||
|
||||
checkTyp :: SourceGrammar -> Type -> [Message]
|
||||
checkTyp gr typ = err (\x -> [pp x]) ppConstrs $ justTypeCheck gr typ vType
|
||||
|
||||
checkDef :: SourceGrammar -> Fun -> Type -> Equation -> [Message]
|
||||
checkDef gr (m,fun) typ eq = err (\x -> [pp x]) ppConstrs $ do
|
||||
(b,cs) <- checkBranch (grammar2theory gr) (initTCEnv []) eq (type2val typ)
|
||||
(constrs,_) <- unifyVal cs
|
||||
return $ filter notJustMeta constrs
|
||||
|
||||
checkConstrs :: SourceGrammar -> Cat -> [Ident] -> [String]
|
||||
checkConstrs gr cat _ = [] ---- check constructors!
|
||||
852
src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
Normal file
852
src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
Normal file
@@ -0,0 +1,852 @@
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
module GF.Compile.TypeCheck.Concrete( checkLType, inferLType, computeLType, ppType ) where
|
||||
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
|
||||
|
||||
import GF.Infra.CheckM
|
||||
import GF.Data.Operations
|
||||
|
||||
import GF.Grammar
|
||||
import GF.Grammar.Lookup
|
||||
import GF.Grammar.Predef
|
||||
import GF.Grammar.PatternMatch
|
||||
import GF.Grammar.Lockfield (isLockLabel, lockRecType, unlockRecord)
|
||||
import GF.Compile.Compute.Concrete(normalForm)
|
||||
import GF.Compile.TypeCheck.Primitives
|
||||
|
||||
import Data.List
|
||||
import Data.Maybe(fromMaybe,isJust,isNothing)
|
||||
import Control.Monad
|
||||
import GF.Text.Pretty
|
||||
|
||||
computeLType :: SourceGrammar -> Context -> Type -> Check Type
|
||||
computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
|
||||
where
|
||||
comp g ty = case ty of
|
||||
_ | Just _ <- isTypeInts ty -> return ty ---- shouldn't be needed
|
||||
| isPredefConstant ty -> return ty ---- shouldn't be needed
|
||||
|
||||
Q (m,ident) -> checkIn ("module" <+> m) $ do
|
||||
ty' <- lookupResDef gr (m,ident)
|
||||
if ty' == ty then return ty else comp g ty' --- is this necessary to test?
|
||||
|
||||
AdHocOverload ts -> do
|
||||
over <- getOverload gr g (Just typeType) t
|
||||
case over of
|
||||
Just (tr,_) -> return tr
|
||||
_ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 t)
|
||||
|
||||
Vr ident -> checkLookup ident g -- never needed to compute!
|
||||
|
||||
App f a -> do
|
||||
f' <- comp g f
|
||||
a' <- comp g a
|
||||
case f' of
|
||||
Abs b x t -> comp ((b,x,a'):g) t
|
||||
_ -> return $ App f' a'
|
||||
|
||||
Prod bt x a b -> do
|
||||
a' <- comp g a
|
||||
b' <- comp ((bt,x,Vr x) : g) b
|
||||
return $ Prod bt x a' b'
|
||||
|
||||
Abs bt x b -> do
|
||||
b' <- comp ((bt,x,Vr x):g) b
|
||||
return $ Abs bt x b'
|
||||
|
||||
Let (x,(_,a)) b -> comp ((Explicit,x,a):g) b
|
||||
|
||||
ExtR r s -> do
|
||||
r' <- comp g r
|
||||
s' <- comp g s
|
||||
case (r',s') of
|
||||
(RecType rs, RecType ss) -> plusRecType r' s' >>= comp g
|
||||
_ -> return $ ExtR r' s'
|
||||
|
||||
RecType fs -> do
|
||||
let fs' = sortRec fs
|
||||
liftM RecType $ mapPairsM (comp g) fs'
|
||||
|
||||
ELincat c t -> do
|
||||
t' <- comp g t
|
||||
lockRecType c t' ---- locking to be removed AR 20/6/2009
|
||||
|
||||
_ | ty == typeTok -> return typeStr
|
||||
|
||||
_ -> composOp (comp g) ty
|
||||
|
||||
-- the underlying algorithms
|
||||
|
||||
inferLType :: SourceGrammar -> Context -> Term -> Check (Term, Type)
|
||||
inferLType gr g trm = case trm of
|
||||
|
||||
Q (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of
|
||||
Just ty -> return ty
|
||||
Nothing -> checkError ("unknown in Predef:" <+> ident)
|
||||
|
||||
Q ident -> checks [
|
||||
termWith trm $ lookupResType gr ident >>= computeLType gr g
|
||||
,
|
||||
lookupResDef gr ident >>= inferLType gr g
|
||||
,
|
||||
checkError ("cannot infer type of constant" <+> ppTerm Unqualified 0 trm)
|
||||
]
|
||||
|
||||
QC (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of
|
||||
Just ty -> return ty
|
||||
Nothing -> checkError ("unknown in Predef:" <+> ident)
|
||||
|
||||
QC ident -> checks [
|
||||
termWith trm $ lookupResType gr ident >>= computeLType gr g
|
||||
,
|
||||
lookupResDef gr ident >>= inferLType gr g
|
||||
,
|
||||
checkError ("cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm)
|
||||
]
|
||||
|
||||
Vr ident -> termWith trm $ checkLookup ident g
|
||||
|
||||
Typed e t -> do
|
||||
t' <- computeLType gr g t
|
||||
checkLType gr g e t'
|
||||
|
||||
AdHocOverload ts -> do
|
||||
over <- getOverload gr g Nothing trm
|
||||
case over of
|
||||
Just trty -> return trty
|
||||
_ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm)
|
||||
|
||||
App f a -> do
|
||||
over <- getOverload gr g Nothing trm
|
||||
case over of
|
||||
Just trty -> return trty
|
||||
_ -> do
|
||||
(f',fty) <- inferLType gr g f
|
||||
fty' <- computeLType gr g fty
|
||||
case fty' of
|
||||
Prod bt z arg val -> do
|
||||
a' <- justCheck g a arg
|
||||
ty <- if z == identW
|
||||
then return val
|
||||
else substituteLType [(bt,z,a')] val
|
||||
return (App f' a',ty)
|
||||
_ ->
|
||||
let term = ppTerm Unqualified 0 f
|
||||
funName = pp . head . words .render $ term
|
||||
in checkError ("A function type is expected for" <+> term <+> "instead of type" <+> ppType fty $$
|
||||
"\n ** Maybe you gave too many arguments to" <+> funName <+> "\n")
|
||||
|
||||
S f x -> do
|
||||
(f', fty) <- inferLType gr g f
|
||||
case fty of
|
||||
Table arg val -> do
|
||||
x'<- justCheck g x arg
|
||||
return (S f' x', val)
|
||||
_ -> checkError ("table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm))
|
||||
|
||||
P t i -> do
|
||||
(t',ty) <- inferLType gr g t --- ??
|
||||
ty' <- computeLType gr g ty
|
||||
let tr2 = P t' i
|
||||
termWith tr2 $ case ty' of
|
||||
RecType ts -> case lookup i ts of
|
||||
Nothing -> checkError ("unknown label" <+> i <+> "in" $$ nest 2 (ppTerm Unqualified 0 ty'))
|
||||
Just x -> return x
|
||||
_ -> checkError ("record type expected for:" <+> ppTerm Unqualified 0 t $$
|
||||
" instead of the inferred:" <+> ppTerm Unqualified 0 ty')
|
||||
|
||||
R r -> do
|
||||
let (ls,fs) = unzip r
|
||||
fsts <- mapM inferM fs
|
||||
let ts = [ty | (Just ty,_) <- fsts]
|
||||
checkCond ("cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 trm)) (length ts == length fsts)
|
||||
return $ (R (zip ls fsts), RecType (zip ls ts))
|
||||
|
||||
T (TTyped arg) pts -> do
|
||||
(_,val) <- checks $ map (inferCase (Just arg)) pts
|
||||
checkLType gr g trm (Table arg val)
|
||||
T (TComp arg) pts -> do
|
||||
(_,val) <- checks $ map (inferCase (Just arg)) pts
|
||||
checkLType gr g trm (Table arg val)
|
||||
T ti pts -> do -- tries to guess: good in oper type inference
|
||||
let pts' = [pt | pt@(p,_) <- pts, isConstPatt p]
|
||||
case pts' of
|
||||
[] -> checkError ("cannot infer table type of" <+> ppTerm Unqualified 0 trm)
|
||||
---- PInt k : _ -> return $ Ints $ max [i | PInt i <- pts']
|
||||
_ -> do
|
||||
(arg,val) <- checks $ map (inferCase Nothing) pts'
|
||||
checkLType gr g trm (Table arg val)
|
||||
V arg pts -> do
|
||||
(_,val) <- checks $ map (inferLType gr g) pts
|
||||
-- return (trm, Table arg val) -- old, caused issue 68
|
||||
checkLType gr g trm (Table arg val)
|
||||
|
||||
K s ->
|
||||
let trm' = case words s of
|
||||
[] -> Empty
|
||||
[w] -> K w
|
||||
(w:ws) -> foldl (\t -> C t . K) (K w) ws
|
||||
in return (trm', typeStr)
|
||||
|
||||
EInt i -> return (trm, typeInt)
|
||||
|
||||
EFloat i -> return (trm, typeFloat)
|
||||
|
||||
Empty -> return (trm, typeStr)
|
||||
|
||||
C s1 s2 ->
|
||||
check2 (flip (justCheck g) typeStr) C s1 s2 typeStr
|
||||
|
||||
Glue s1 s2 ->
|
||||
check2 (flip (justCheck g) typeStr) Glue s1 s2 typeStr ---- typeTok
|
||||
|
||||
---- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007
|
||||
Strs (Cn c : ts) | c == cConflict -> do
|
||||
checkWarn ("unresolved constant, could be any of" <+> hcat (map (ppTerm Unqualified 0) ts))
|
||||
inferLType gr g (head ts)
|
||||
|
||||
Strs ts -> do
|
||||
ts' <- mapM (\t -> justCheck g t typeStr) ts
|
||||
return (Strs ts', typeStrs)
|
||||
|
||||
Alts t aa -> do
|
||||
t' <- justCheck g t typeStr
|
||||
aa' <- flip mapM aa (\ (c,v) -> do
|
||||
c' <- justCheck g c typeStr
|
||||
v' <- checks $ map (justCheck g v) [typeStrs, EPattType typeStr]
|
||||
v' <- case v' of
|
||||
Q q -> do t <- lookupResDef gr q
|
||||
t <- normalForm gr t
|
||||
case t of
|
||||
EPatt _ _ p -> mkStrs p
|
||||
_ -> return v'
|
||||
_ -> return v'
|
||||
return (c',v'))
|
||||
return (Alts t' aa', typeStr)
|
||||
|
||||
RecType r -> do
|
||||
let (ls,ts) = unzip r
|
||||
ts' <- mapM (flip (justCheck g) typeType) ts
|
||||
return (RecType (zip ls ts'), typeType)
|
||||
|
||||
ExtR r s -> do
|
||||
(r',rT) <- inferLType gr g r
|
||||
rT' <- computeLType gr g rT
|
||||
|
||||
(s',sT) <- inferLType gr g s
|
||||
sT' <- computeLType gr g sT
|
||||
|
||||
let trm' = ExtR r' s'
|
||||
case (rT', sT') of
|
||||
(RecType rs, RecType ss) -> do
|
||||
let rt = RecType ([field | field@(l,_) <- rs, notElem l (map fst ss)] ++ ss) -- select types of later fields
|
||||
checkLType gr g trm' rt ---- return (trm', rt)
|
||||
_ | rT' == typeType && sT' == typeType -> do
|
||||
return (trm', typeType)
|
||||
_ -> checkError ("records or record types expected in" <+> ppTerm Unqualified 0 trm)
|
||||
|
||||
Sort _ ->
|
||||
termWith trm $ return typeType
|
||||
|
||||
Prod bt x a b -> do
|
||||
a' <- justCheck g a typeType
|
||||
b' <- justCheck ((bt,x,a'):g) b typeType
|
||||
return (Prod bt x a' b', typeType)
|
||||
|
||||
Table p t -> do
|
||||
p' <- justCheck g p typeType --- check p partype!
|
||||
t' <- justCheck g t typeType
|
||||
return $ (Table p' t', typeType)
|
||||
|
||||
FV vs -> do
|
||||
(_,ty) <- checks $ map (inferLType gr g) vs
|
||||
--- checkIfComplexVariantType trm ty
|
||||
checkLType gr g trm ty
|
||||
|
||||
EPattType ty -> do
|
||||
ty' <- justCheck g ty typeType
|
||||
return (EPattType ty',typeType)
|
||||
EPatt _ _ p -> do
|
||||
ty <- inferPatt p
|
||||
(minp,maxp,p') <- measurePatt gr p
|
||||
return (EPatt minp maxp p', EPattType ty)
|
||||
|
||||
ELin c trm -> do
|
||||
(trm',ty) <- inferLType gr g trm
|
||||
ty' <- lockRecType c ty ---- lookup c; remove lock AR 20/6/2009
|
||||
return $ (ELin c trm', ty')
|
||||
|
||||
_ -> checkError ("cannot infer lintype of" <+> ppTerm Unqualified 0 trm)
|
||||
|
||||
where
|
||||
isPredef m = elem m [cPredef,cPredefAbs]
|
||||
|
||||
justCheck g ty te = checkLType gr g ty te >>= return . fst
|
||||
|
||||
-- for record fields, which may be typed
|
||||
inferM (mty, t) = do
|
||||
(t', ty') <- case mty of
|
||||
Just ty -> checkLType gr g t ty
|
||||
_ -> inferLType gr g t
|
||||
return (Just ty',t')
|
||||
|
||||
inferCase mty (patt,term) = do
|
||||
arg <- maybe (inferPatt patt) return mty
|
||||
cont <- pattContext gr g arg patt
|
||||
(term',val) <- inferLType gr (reverse cont ++ g) term
|
||||
return (arg,val)
|
||||
isConstPatt p = case p of
|
||||
PC _ ps -> True --- all isConstPatt ps
|
||||
PP _ ps -> True --- all isConstPatt ps
|
||||
PR ps -> all (isConstPatt . snd) ps
|
||||
PT _ p -> isConstPatt p
|
||||
PString _ -> True
|
||||
PInt _ -> True
|
||||
PFloat _ -> True
|
||||
PChar -> True
|
||||
PChars _ -> True
|
||||
PSeq _ _ p _ _ q -> isConstPatt p && isConstPatt q
|
||||
PAlt p q -> isConstPatt p && isConstPatt q
|
||||
PRep _ _ p -> isConstPatt p
|
||||
PNeg p -> isConstPatt p
|
||||
PAs _ p -> isConstPatt p
|
||||
_ -> False
|
||||
|
||||
inferPatt p = case p of
|
||||
PP (q,c) ps | q /= cPredef -> liftM valTypeCnc (lookupResType gr (q,c))
|
||||
PAs _ p -> inferPatt p
|
||||
PNeg p -> inferPatt p
|
||||
PAlt p q -> checks [inferPatt p, inferPatt q]
|
||||
PSeq _ _ _ _ _ _ -> return $ typeStr
|
||||
PRep _ _ _ -> return $ typeStr
|
||||
PChar -> return $ typeStr
|
||||
PChars _ -> return $ typeStr
|
||||
_ -> inferLType gr g (patt2term p) >>= return . snd
|
||||
|
||||
measurePatt gr p =
|
||||
case p of
|
||||
PM q -> do t <- lookupResDef gr q
|
||||
t <- normalForm gr t
|
||||
case t of
|
||||
EPatt minp maxp _ -> return (minp,maxp,p)
|
||||
_ -> checkError ("Expected pattern macro, but found:" $$ nest 2 (pp t))
|
||||
PR ass -> do ass <- mapM (\(lbl,p) -> measurePatt gr p >>= \(_,_,p') -> return (lbl,p')) ass
|
||||
return (0,Nothing,PR ass)
|
||||
PString s -> do let len=length s
|
||||
return (len,Just len,p)
|
||||
PT t p -> do (min,max,p') <- measurePatt gr p
|
||||
return (min,max,PT t p')
|
||||
PAs x p -> do (min,max,p) <- measurePatt gr p
|
||||
case p of
|
||||
PW -> return (0,Nothing,PV x)
|
||||
_ -> return (min,max,PAs x p)
|
||||
PImplArg p -> do (min,max,p') <- measurePatt gr p
|
||||
return (min,max,PImplArg p')
|
||||
PNeg p -> do (_,_,p') <- measurePatt gr p
|
||||
return (0,Nothing,PNeg p')
|
||||
PAlt p1 p2 -> do (min1,max1,p1) <- measurePatt gr p1
|
||||
(min2,max2,p2) <- measurePatt gr p2
|
||||
case (p1,p2) of
|
||||
(PString [c1],PString [c2]) -> return (1,Just 1,PChars [c1,c2])
|
||||
(PString [c], PChars cs) -> return (1,Just 1,PChars ([c]++cs))
|
||||
(PChars cs, PString [c]) -> return (1,Just 1,PChars (cs++[c]))
|
||||
(PChars cs1, PChars cs2) -> return (1,Just 1,PChars (cs1++cs2))
|
||||
_ -> return (min min1 min2,liftM2 max max1 max2,PAlt p1 p2)
|
||||
PSeq _ _ p1 _ _ p2
|
||||
-> do (min1,max1,p1) <- measurePatt gr p1
|
||||
(min2,max2,p2) <- measurePatt gr p2
|
||||
case (p1,p2) of
|
||||
(PW, PW ) -> return (0,Nothing,PW)
|
||||
(PString s1,PString s2) -> return (min1+min2,liftM2 (+) max1 max2,PString (s1++s2))
|
||||
_ -> return (min1+min2,liftM2 (+) max1 max2,PSeq min1 max1 p1 min2 max2 p2)
|
||||
PRep _ _ p -> do (minp,maxp,p) <- measurePatt gr p
|
||||
case p of
|
||||
PW -> return (0,Nothing,PW)
|
||||
PChar -> return (0,Nothing,PW)
|
||||
_ -> return (0,Nothing,PRep minp maxp p)
|
||||
PChar -> return (1,Just 1,p)
|
||||
PChars _ -> return (1,Just 1,p)
|
||||
_ -> return (0,Nothing,p)
|
||||
|
||||
-- type inference: Nothing, type checking: Just t
|
||||
-- the latter permits matching with value type
|
||||
getOverload :: SourceGrammar -> Context -> Maybe Type -> Term -> Check (Maybe (Term,Type))
|
||||
getOverload gr g mt ot = case appForm ot of
|
||||
(f@(Q c), ts) -> case lookupOverload gr c of
|
||||
Ok typs -> do
|
||||
ttys <- mapM (inferLType gr g) ts
|
||||
v <- matchOverload f typs ttys
|
||||
return $ Just v
|
||||
_ -> return Nothing
|
||||
(AdHocOverload cs@(f:_), ts) -> do --- the function name f is only used in error messages
|
||||
let typs = concatMap collectOverloads cs
|
||||
ttys <- mapM (inferLType gr g) ts
|
||||
v <- matchOverload f typs ttys
|
||||
return $ Just v
|
||||
_ -> return Nothing
|
||||
|
||||
where
|
||||
collectOverloads tr@(Q c) = case lookupOverload gr c of
|
||||
Ok typs -> typs
|
||||
_ -> case lookupResType gr c of
|
||||
Ok ty -> let (args,val) = typeFormCnc ty in [(map (\(b,x,t) -> t) args,(val,tr))]
|
||||
_ -> []
|
||||
collectOverloads _ = [] --- constructors QC
|
||||
|
||||
matchOverload f typs ttys = do
|
||||
let (tts,tys) = unzip ttys
|
||||
let vfs = lookupOverloadInstance tys typs
|
||||
let matches = [vf | vf@((_,v,_),_) <- vfs, matchVal mt v]
|
||||
let showTypes ty = hsep (map ppType ty)
|
||||
|
||||
|
||||
let (stys,styps) = (showTypes tys, [showTypes ty | (ty,_) <- typs])
|
||||
|
||||
-- to avoid strange error msg e.g. in case of unmatch record extension, show whole types if needed AR 28/1/2013
|
||||
let (stysError,stypsError) = if elem (render stys) (map render styps)
|
||||
then (hsep (map (ppTerm Unqualified 0) tys), [hsep (map (ppTerm Unqualified 0) ty) | (ty,_) <- typs])
|
||||
else (stys,styps)
|
||||
|
||||
case ([vf | (vf,True) <- matches],[vf | (vf,False) <- matches]) of
|
||||
([(_,val,fun)],_) -> return (mkApp fun tts, val)
|
||||
([],[(pre,val,fun)]) -> do
|
||||
checkWarn $ "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot $$
|
||||
"for" $$
|
||||
nest 2 (showTypes tys) $$
|
||||
"using" $$
|
||||
nest 2 (showTypes pre)
|
||||
return (mkApp fun tts, val)
|
||||
([],[]) -> do
|
||||
checkError $ "no overload instance of" <+> ppTerm Qualified 0 f $$
|
||||
maybe empty (\x -> "with value type" <+> ppType x) mt $$
|
||||
"for argument list" $$
|
||||
nest 2 stysError $$
|
||||
"among alternatives" $$
|
||||
nest 2 (vcat stypsError)
|
||||
|
||||
|
||||
(vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of
|
||||
([(val,fun)],_) -> do
|
||||
return (mkApp fun tts, val)
|
||||
([],[(val,fun)]) -> do
|
||||
checkWarn ("ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot)
|
||||
return (mkApp fun tts, val)
|
||||
|
||||
----- unsafely exclude irritating warning AR 24/5/2008
|
||||
----- checkWarn $ "overloading of" +++ prt f +++
|
||||
----- "resolved by excluding partial applications:" ++++
|
||||
----- unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)]
|
||||
|
||||
--- now forgiving ambiguity with a warning AR 1/2/2014
|
||||
-- This gives ad hoc overloading the same behaviour as the choice of the first match in renaming did before.
|
||||
-- But it also gives a chance to ambiguous overloadings that were banned before.
|
||||
(nps1,nps2) -> do
|
||||
checkWarn $ "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+>
|
||||
---- "with argument types" <+> hsep (map (ppTerm Qualified 0) tys) $$
|
||||
"resolved by selecting the first of the alternatives" $$
|
||||
nest 2 (vcat [ppTerm Qualified 0 fun | (_,ty,fun) <- vfs1 ++ if null vfs1 then vfs2 else []])
|
||||
case [(mkApp fun tts,val) | (val,fun) <- nps1 ++ nps2] of
|
||||
[] -> checkError $ "no alternatives left when resolving" <+> ppTerm Unqualified 0 f
|
||||
h:_ -> return h
|
||||
|
||||
matchVal mt v = elem mt [Nothing,Just v,Just (unlocked v)]
|
||||
|
||||
unlocked v = case v of
|
||||
RecType fs -> RecType $ filter (not . isLockLabel . fst) (sortRec fs)
|
||||
_ -> v
|
||||
---- TODO: accept subtypes
|
||||
---- TODO: use a trie
|
||||
lookupOverloadInstance tys typs =
|
||||
[((pre,mkFunType rest val, t),isExact) |
|
||||
let lt = length tys,
|
||||
(ty,(val,t)) <- typs, length ty >= lt,
|
||||
let (pre,rest) = splitAt lt ty,
|
||||
let isExact = pre == tys,
|
||||
isExact || map unlocked pre == map unlocked tys
|
||||
]
|
||||
|
||||
noProds vfs = [(v,f) | (_,v,f) <- vfs, noProd v]
|
||||
|
||||
noProd ty = case ty of
|
||||
Prod _ _ _ _ -> False
|
||||
_ -> True
|
||||
|
||||
checkLType :: SourceGrammar -> Context -> Term -> Type -> Check (Term, Type)
|
||||
checkLType gr g trm typ0 = do
|
||||
typ <- computeLType gr g typ0
|
||||
|
||||
case trm of
|
||||
|
||||
Abs bt x c -> do
|
||||
case typ of
|
||||
Prod bt' z a b -> do
|
||||
(c',b') <- if z == identW
|
||||
then checkLType gr ((bt,x,a):g) c b
|
||||
else do b' <- checkIn (pp "abs") $ substituteLType [(bt',z,Vr x)] b
|
||||
checkLType gr ((bt,x,a):g) c b'
|
||||
return $ (Abs bt x c', Prod bt' z a b')
|
||||
_ -> checkError $ "function type expected instead of" <+> ppType typ $$
|
||||
"\n ** Double-check that the type signature of the operation" $$
|
||||
"matches the number of arguments given to it.\n"
|
||||
|
||||
App f a -> do
|
||||
over <- getOverload gr g (Just typ) trm
|
||||
case over of
|
||||
Just trty -> return trty
|
||||
_ -> do
|
||||
(trm',ty') <- inferLType gr g trm
|
||||
termWith trm' $ checkEqLType gr g typ ty' trm'
|
||||
|
||||
AdHocOverload ts -> do
|
||||
over <- getOverload gr g Nothing trm
|
||||
case over of
|
||||
Just trty -> return trty
|
||||
_ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm)
|
||||
|
||||
Q _ -> do
|
||||
over <- getOverload gr g (Just typ) trm
|
||||
case over of
|
||||
Just trty -> return trty
|
||||
_ -> do
|
||||
(trm',ty') <- inferLType gr g trm
|
||||
termWith trm' $ checkEqLType gr g typ ty' trm'
|
||||
|
||||
T _ [] ->
|
||||
checkError ("found empty table in type" <+> ppTerm Unqualified 0 typ)
|
||||
T _ cs -> case typ of
|
||||
Table arg val -> do
|
||||
case allParamValues gr arg of
|
||||
Ok vs -> do
|
||||
let ps0 = map fst cs
|
||||
ps <- testOvershadow ps0 vs
|
||||
if null ps
|
||||
then return ()
|
||||
else checkWarn ("patterns never reached:" $$
|
||||
nest 2 (vcat (map (ppPatt Unqualified 0) ps)))
|
||||
_ -> return () -- happens with variable types
|
||||
cs' <- mapM (checkCase arg val) cs
|
||||
return (T (TTyped arg) cs', typ)
|
||||
_ -> checkError $ "table type expected for table instead of" $$ nest 2 (ppType typ)
|
||||
V arg0 vs ->
|
||||
case typ of
|
||||
Table arg1 val ->
|
||||
do arg' <- checkEqLType gr g arg0 arg1 trm
|
||||
vs1 <- allParamValues gr arg1
|
||||
if length vs1 == length vs
|
||||
then return ()
|
||||
else checkError $ "wrong number of values in table" <+> ppTerm Unqualified 0 trm
|
||||
vs' <- map fst `fmap` sequence [checkLType gr g v val|v<-vs]
|
||||
return (V arg' vs',typ)
|
||||
|
||||
R r -> case typ of --- why needed? because inference may be too difficult
|
||||
RecType rr -> do
|
||||
--let (ls,_) = unzip rr -- labels of expected type
|
||||
fsts <- mapM (checkM r) rr -- check that they are found in the record
|
||||
return $ (R fsts, typ) -- normalize record
|
||||
|
||||
_ -> checkError ("record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ))
|
||||
|
||||
ExtR r s -> case typ of
|
||||
_ | typ == typeType -> do
|
||||
trm' <- computeLType gr g trm
|
||||
case trm' of
|
||||
RecType _ -> termWith trm' $ return typeType
|
||||
ExtR (Vr _) (RecType _) -> termWith trm' $ return typeType
|
||||
-- ext t = t ** ...
|
||||
_ -> checkError ("invalid record type extension" <+> nest 2 (ppTerm Unqualified 0 trm))
|
||||
|
||||
RecType rr -> do
|
||||
|
||||
(fields1,fields2) <- case s of
|
||||
R ss -> return (partition (\(l,_) -> isNothing (lookup l ss)) rr)
|
||||
_ -> do
|
||||
(s',typ2) <- inferLType gr g s
|
||||
case typ2 of
|
||||
RecType ss -> return (partition (\(l,_) -> isNothing (lookup l ss)) rr)
|
||||
_ -> checkError ("cannot get labels from" $$ nest 2 (ppTerm Unqualified 0 typ2))
|
||||
|
||||
(r',_) <- checkLType gr g r (RecType fields1)
|
||||
(s',_) <- checkLType gr g s (RecType fields2)
|
||||
|
||||
let withProjection t fields g f =
|
||||
case t of
|
||||
R rs -> f g (\l -> case lookup l rs of
|
||||
Just (_,t) -> t
|
||||
Nothing -> error (render ("no value for label" <+> l)))
|
||||
QC _ -> f g (\l -> P t l)
|
||||
Vr _ -> f g (\l -> P t l)
|
||||
_ -> if length fields == 1
|
||||
then f g (\l -> P t l)
|
||||
else let x = mkFreshVar (map (\(_,x,_) -> x) g) (identS "x")
|
||||
in Let (x, (Nothing, t)) (f ((Explicit,x,RecType fields):g) (\l -> P (Vr x) l))
|
||||
|
||||
rec = withProjection r' fields1 g $ \g p_r' ->
|
||||
withProjection s' fields2 g $ \g p_s' ->
|
||||
R ([(l,(Nothing,p_r' l)) | (l,_) <- fields1] ++ [(l,(Nothing,p_s' l)) | (l,_) <- fields2])
|
||||
return (rec, typ)
|
||||
|
||||
ExtR ty ex -> do
|
||||
r' <- justCheck g r ty
|
||||
s' <- justCheck g s ex
|
||||
return $ (ExtR r' s', typ) --- is this all? it assumes the same division in trm and typ
|
||||
|
||||
_ -> checkError ("record extension not meaningful for" <+> ppTerm Unqualified 0 typ)
|
||||
|
||||
FV vs -> do
|
||||
ttys <- mapM (flip (checkLType gr g) typ) vs
|
||||
--- checkIfComplexVariantType trm typ
|
||||
return (FV (map fst ttys), typ) --- typ' ?
|
||||
|
||||
S tab arg -> checks [ do
|
||||
(tab',ty) <- inferLType gr g tab
|
||||
ty' <- computeLType gr g ty
|
||||
case ty' of
|
||||
Table p t -> do
|
||||
(arg',val) <- checkLType gr g arg p
|
||||
checkEqLType gr g typ t trm
|
||||
return (S tab' arg', t)
|
||||
_ -> checkError ("table type expected for applied table instead of" <+> ppType ty')
|
||||
, do
|
||||
(arg',ty) <- inferLType gr g arg
|
||||
ty' <- computeLType gr g ty
|
||||
(tab',_) <- checkLType gr g tab (Table ty' typ)
|
||||
return (S tab' arg', typ)
|
||||
]
|
||||
Let (x,(mty,def)) body -> case mty of
|
||||
Just ty -> do
|
||||
(ty0,_) <- checkLType gr g ty typeType
|
||||
(def',ty') <- checkLType gr g def ty0
|
||||
body' <- justCheck ((Explicit,x,ty'):g) body typ
|
||||
return (Let (x,(Just ty',def')) body', typ)
|
||||
_ -> do
|
||||
(def',ty) <- inferLType gr g def -- tries to infer type of local constant
|
||||
checkLType gr g (Let (x,(Just ty,def')) body) typ
|
||||
|
||||
ELin c tr -> do
|
||||
tr1 <- unlockRecord c tr
|
||||
checkLType gr g tr1 typ
|
||||
|
||||
_ -> do
|
||||
(trm',ty') <- inferLType gr g trm
|
||||
termWith trm' $ checkEqLType gr g typ ty' trm'
|
||||
where
|
||||
justCheck g ty te = checkLType gr g ty te >>= return . fst
|
||||
{-
|
||||
recParts rr t = (RecType rr1,RecType rr2) where
|
||||
(rr1,rr2) = partition (flip elem (map fst t) . fst) rr
|
||||
-}
|
||||
checkM rms (l,ty) = case lookup l rms of
|
||||
Just (Just ty0,t) -> do
|
||||
checkEqLType gr g ty ty0 t
|
||||
(t',ty') <- checkLType gr g t ty
|
||||
return (l,(Just ty',t'))
|
||||
Just (_,t) -> do
|
||||
(t',ty') <- checkLType gr g t ty
|
||||
return (l,(Just ty',t'))
|
||||
_ -> checkError $
|
||||
if isLockLabel l
|
||||
then let cat = drop 5 (showIdent (label2ident l))
|
||||
in ppTerm Unqualified 0 (R rms) <+> "is not in the lincat of" <+> cat <>
|
||||
"; try wrapping it with lin" <+> cat
|
||||
else "cannot find value for label" <+> l <+> "in" <+> ppTerm Unqualified 0 (R rms)
|
||||
|
||||
checkCase arg val (p,t) = do
|
||||
cont <- pattContext gr g arg p
|
||||
t' <- justCheck (reverse cont ++ g) t val
|
||||
(_,_,p') <- measurePatt gr p
|
||||
return (p',t')
|
||||
|
||||
pattContext :: SourceGrammar -> Context -> Type -> Patt -> Check Context
|
||||
pattContext env g typ p = case p of
|
||||
PV x -> return [(Explicit,x,typ)]
|
||||
PP (q,c) ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006
|
||||
t <- lookupResType env (q,c)
|
||||
let (cont,v) = typeFormCnc t
|
||||
checkCond ("wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p)
|
||||
(length cont == length ps)
|
||||
checkEqLType env g typ v (patt2term p)
|
||||
mapM (\((_,_,ty),p) -> pattContext env g ty p) (zip cont ps) >>= return . concat
|
||||
PR r -> do
|
||||
typ' <- computeLType env g typ
|
||||
case typ' of
|
||||
RecType t -> do
|
||||
let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]]
|
||||
----- checkWarn $ prt p ++++ show pts ----- debug
|
||||
mapM (uncurry (pattContext env g)) pts >>= return . concat
|
||||
_ -> checkError ("record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ')
|
||||
PT t p' -> do
|
||||
checkEqLType env g typ t (patt2term p')
|
||||
pattContext env g typ p'
|
||||
|
||||
PAs x p -> do
|
||||
g' <- pattContext env g typ p
|
||||
return ((Explicit,x,typ):g')
|
||||
|
||||
PAlt p' q -> do
|
||||
g1 <- pattContext env g typ p'
|
||||
g2 <- pattContext env g typ q
|
||||
let pts = nub ([x | pt@(_,x,_) <- g1, notElem pt g2] ++ [x | pt@(_,x,_) <- g2, notElem pt g1])
|
||||
checkCond
|
||||
("incompatible bindings of" <+>
|
||||
fsep pts <+>
|
||||
"in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts)
|
||||
return g1 -- must be g1 == g2
|
||||
PSeq _ _ p _ _ q -> do
|
||||
g1 <- pattContext env g typ p
|
||||
g2 <- pattContext env g typ q
|
||||
return $ g1 ++ g2
|
||||
PRep _ _ p' -> noBind typeStr p'
|
||||
PNeg p' -> noBind typ p'
|
||||
|
||||
_ -> return [] ---- check types!
|
||||
where
|
||||
noBind typ p' = do
|
||||
co <- pattContext env g typ p'
|
||||
if not (null co)
|
||||
then checkWarn ("no variable bound inside pattern" <+> ppPatt Unqualified 0 p)
|
||||
>> return []
|
||||
else return []
|
||||
|
||||
checkEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check Type
|
||||
checkEqLType gr g t u trm = do
|
||||
(b,t',u',s) <- checkIfEqLType gr g t u trm
|
||||
case b of
|
||||
True -> return t'
|
||||
False ->
|
||||
let inferredType = ppTerm Qualified 0 u
|
||||
expectedType = ppTerm Qualified 0 t
|
||||
term = ppTerm Unqualified 0 trm
|
||||
funName = pp . head . words .render $ term
|
||||
helpfulMsg =
|
||||
case (arrows inferredType, arrows expectedType) of
|
||||
(0,0) -> pp "" -- None of the types is a function
|
||||
_ -> "\n **" <+>
|
||||
if expectedType `isLessApplied` inferredType
|
||||
then "Maybe you gave too few arguments to" <+> funName
|
||||
else pp "Double-check that type signature and number of arguments match."
|
||||
in checkError $ s <+> "type of" <+> term $$
|
||||
"expected:" <+> expectedType $$ -- ppqType t u $$
|
||||
"inferred:" <+> inferredType $$ -- ppqType u t
|
||||
helpfulMsg
|
||||
where
|
||||
-- count the number of arrows in the prettyprinted term
|
||||
arrows :: Doc -> Int
|
||||
arrows = length . filter (=="->") . words . render
|
||||
|
||||
-- If prettyprinted type t has fewer arrows then prettyprinted type u,
|
||||
-- then t is "less applied", and we can print out more helpful error msg.
|
||||
isLessApplied :: Doc -> Doc -> Bool
|
||||
isLessApplied t u = arrows t < arrows u
|
||||
|
||||
checkIfEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check (Bool,Type,Type,String)
|
||||
checkIfEqLType gr g t u trm = do
|
||||
t' <- computeLType gr g t
|
||||
u' <- computeLType gr g u
|
||||
case t' == u' || alpha [] t' u' of
|
||||
True -> return (True,t',u',[])
|
||||
-- forgive missing lock fields by only generating a warning.
|
||||
--- better: use a flag to forgive? (AR 31/1/2006)
|
||||
_ -> case missingLock [] t' u' of
|
||||
Ok lo -> do
|
||||
checkWarn $ "missing lock field" <+> fsep lo
|
||||
return (True,t',u',[])
|
||||
Bad s -> return (False,t',u',s)
|
||||
|
||||
where
|
||||
|
||||
-- check that u is a subtype of t
|
||||
--- quick hack version of TC.eqVal
|
||||
alpha g t u = case (t,u) of
|
||||
|
||||
-- error (the empty type!) is subtype of any other type
|
||||
(_,u) | u == typeError -> True
|
||||
|
||||
-- contravariance
|
||||
(Prod _ x a b, Prod _ y c d) -> alpha g c a && alpha ((x,y):g) b d
|
||||
|
||||
-- record subtyping
|
||||
(RecType rs, RecType ts) -> all (\ (l,a) ->
|
||||
any (\ (k,b) -> l == k && alpha g a b) ts) rs
|
||||
(ExtR r s, ExtR r' s') -> alpha g r r' && alpha g s s'
|
||||
(ExtR r s, t) -> alpha g r t || alpha g s t
|
||||
|
||||
-- the following say that Ints n is a subset of Int and of Ints m >= n
|
||||
-- But why does it also allow Int as a subtype of Ints m? /TH 2014-04-04
|
||||
(t,u) | Just m <- isTypeInts t, Just n <- isTypeInts u -> m >= n
|
||||
| Just _ <- isTypeInts t, u == typeInt -> True ---- check size!
|
||||
| t == typeInt, Just _ <- isTypeInts u -> True ---- why this ???? AR 11/12/2005
|
||||
|
||||
---- this should be made in Rename
|
||||
(Q (m,a), Q (n,b)) | a == b -> elem m (allExtendsPlus gr n)
|
||||
|| elem n (allExtendsPlus gr m)
|
||||
|| m == n --- for Predef
|
||||
(QC (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n)
|
||||
|| elem n (allExtendsPlus gr m)
|
||||
(QC (m,a), Q (n,b)) | a == b -> elem m (allExtendsPlus gr n)
|
||||
|| elem n (allExtendsPlus gr m)
|
||||
(Q (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n)
|
||||
|| elem n (allExtendsPlus gr m)
|
||||
|
||||
-- contravariance
|
||||
(Table a b, Table c d) -> alpha g c a && alpha g b d
|
||||
(Vr x, Vr y) -> x == y || elem (x,y) g || elem (y,x) g
|
||||
_ -> t == u
|
||||
--- the following should be one-way coercions only. AR 4/1/2001
|
||||
|| elem t sTypes && elem u sTypes
|
||||
|| (t == typeType && u == typePType)
|
||||
|| (u == typeType && t == typePType)
|
||||
|
||||
missingLock g t u = case (t,u) of
|
||||
(RecType rs, RecType ts) ->
|
||||
let
|
||||
ls = [l | (l,a) <- rs,
|
||||
not (any (\ (k,b) -> alpha g a b && l == k) ts)]
|
||||
(locks,others) = partition isLockLabel ls
|
||||
in case others of
|
||||
_:_ -> Bad $ render ("missing record fields:" <+> fsep (punctuate ',' (others)))
|
||||
_ -> return locks
|
||||
-- contravariance
|
||||
(Prod _ x a b, Prod _ y c d) -> do
|
||||
ls1 <- missingLock g c a
|
||||
ls2 <- missingLock g b d
|
||||
return $ ls1 ++ ls2
|
||||
|
||||
_ -> Bad ""
|
||||
|
||||
sTypes = [typeStr, typeTok, typeString]
|
||||
|
||||
-- auxiliaries
|
||||
|
||||
-- | light-weight substitution for dep. types
|
||||
substituteLType :: Context -> Type -> Check Type
|
||||
substituteLType g t = case t of
|
||||
Vr x -> return $ maybe t id $ lookup x [(x,t) | (_,x,t) <- g]
|
||||
_ -> composOp (substituteLType g) t
|
||||
|
||||
termWith :: Term -> Check Type -> Check (Term, Type)
|
||||
termWith t ct = do
|
||||
ty <- ct
|
||||
return (t,ty)
|
||||
|
||||
-- | compositional check\/infer of binary operations
|
||||
check2 :: (Term -> Check Term) -> (Term -> Term -> Term) ->
|
||||
Term -> Term -> Type -> Check (Term,Type)
|
||||
check2 chk con a b t = do
|
||||
a' <- chk a
|
||||
b' <- chk b
|
||||
return (con a' b', t)
|
||||
|
||||
-- printing a type with a lock field lock_C as C
|
||||
ppType :: Type -> Doc
|
||||
ppType ty =
|
||||
case ty of
|
||||
RecType fs -> case filter isLockLabel $ map fst fs of
|
||||
[lock] -> pp (drop 5 (showIdent (label2ident lock)))
|
||||
_ -> ppTerm Unqualified 0 ty
|
||||
Prod _ x a b -> ppType a <+> "->" <+> ppType b
|
||||
_ -> ppTerm Unqualified 0 ty
|
||||
|
||||
checkLookup :: Ident -> Context -> Check Type
|
||||
checkLookup x g =
|
||||
case [ty | (b,y,ty) <- g, x == y] of
|
||||
[] -> checkError ("unknown variable" <+> x)
|
||||
(ty:_) -> return ty
|
||||
1092
src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
Normal file
1092
src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
Normal file
File diff suppressed because it is too large
Load Diff
84
src/compiler/api/GF/Compile/TypeCheck/Primitives.hs
Normal file
84
src/compiler/api/GF/Compile/TypeCheck/Primitives.hs
Normal file
@@ -0,0 +1,84 @@
|
||||
module GF.Compile.TypeCheck.Primitives(typPredefined,predefMod) where
|
||||
|
||||
import GF.Infra.Option
|
||||
import GF.Grammar
|
||||
import GF.Grammar.Predef
|
||||
import qualified Data.Map as Map
|
||||
|
||||
typPredefined :: Ident -> Maybe Type
|
||||
typPredefined f = case Map.lookup f primitives of
|
||||
Just (ResOper (Just (L _ ty)) _) -> Just ty
|
||||
Just (ResParam _ _) -> Just typePType
|
||||
Just (ResValue (L _ ty) _) -> Just ty
|
||||
_ -> Nothing
|
||||
|
||||
predefMod = (cPredef, modInfo)
|
||||
where
|
||||
modInfo = ModInfo {
|
||||
mtype = MTResource,
|
||||
mstatus = MSComplete,
|
||||
mflags = noOptions,
|
||||
mextend = [],
|
||||
mwith = Nothing,
|
||||
mopens = [],
|
||||
mexdeps = [],
|
||||
msrc = "Predef.gfo",
|
||||
mseqs = Nothing,
|
||||
jments = primitives
|
||||
}
|
||||
|
||||
primitives = Map.fromList
|
||||
[ (cErrorType, ResOper (Just (noLoc typeType)) Nothing)
|
||||
, (cInt , ResOper (Just (noLoc typePType)) Nothing)
|
||||
, (cFloat , ResOper (Just (noLoc typePType)) Nothing)
|
||||
, (cInts , fun [typeInt] typePType)
|
||||
, (cPBool , ResParam (Just (noLoc [(cPTrue,[]),(cPFalse,[])])) (Just ([QC (cPredef,cPTrue), QC (cPredef,cPFalse)],2)))
|
||||
, (cPTrue , ResValue (noLoc typePBool) 0)
|
||||
, (cPFalse , ResValue (noLoc typePBool) 1)
|
||||
, (cError , fun [typeStr] typeError) -- non-can. of empty set
|
||||
, (cLength , fun [typeTok] typeInt)
|
||||
, (cDrop , fun [typeInt,typeTok] typeTok)
|
||||
, (cTake , fun [typeInt,typeTok] typeTok)
|
||||
, (cTk , fun [typeInt,typeTok] typeTok)
|
||||
, (cDp , fun [typeInt,typeTok] typeTok)
|
||||
, (cEqInt , fun [typeInt,typeInt] typePBool)
|
||||
, (cLessInt , fun [typeInt,typeInt] typePBool)
|
||||
, (cPlus , fun [typeInt,typeInt] typeInt)
|
||||
, (cEqStr , fun [typeTok,typeTok] typePBool)
|
||||
, (cOccur , fun [typeTok,typeTok] typePBool)
|
||||
, (cOccurs , fun [typeTok,typeTok] typePBool)
|
||||
|
||||
, (cToUpper , fun [typeTok] typeTok)
|
||||
, (cToLower , fun [typeTok] typeTok)
|
||||
, (cIsUpper , fun [typeTok] typePBool)
|
||||
|
||||
---- "read" ->
|
||||
, (cRead , ResOper (Just (noLoc (mkProd -- (P : Type) -> Tok -> P
|
||||
[(Explicit,varP,typePType),(Explicit,identW,typeStr)] (Vr varP) []))) Nothing)
|
||||
, (cShow , ResOper (Just (noLoc (mkProd -- (P : PType) -> P -> Tok
|
||||
[(Explicit,varP,typePType),(Explicit,identW,Vr varP)] typeStr []))) Nothing)
|
||||
, (cEqVal , ResOper (Just (noLoc (mkProd -- (P : PType) -> P -> P -> PBool
|
||||
[(Explicit,varP,typePType),(Explicit,identW,Vr varP),(Explicit,identW,Vr varP)] typePBool []))) Nothing)
|
||||
, (cToStr , ResOper (Just (noLoc (mkProd -- (L : Type) -> L -> Str
|
||||
[(Explicit,varL,typeType),(Explicit,identW,Vr varL)] typeStr []))) Nothing)
|
||||
, (cMapStr , ResOper (Just (noLoc (mkProd -- (L : Type) -> (Str -> Str) -> L -> L
|
||||
[(Explicit,varL,typeType),(Explicit,identW,mkFunType [typeStr] typeStr),(Explicit,identW,Vr varL)] (Vr varL) []))) Nothing)
|
||||
, (cNonExist , ResOper (Just (noLoc (mkProd -- Str
|
||||
[] typeStr []))) Nothing)
|
||||
, (cBIND , ResOper (Just (noLoc (mkProd -- Str
|
||||
[] typeStr []))) Nothing)
|
||||
, (cSOFT_BIND, ResOper (Just (noLoc (mkProd -- Str
|
||||
[] typeStr []))) Nothing)
|
||||
, (cSOFT_SPACE,ResOper (Just (noLoc (mkProd -- Str
|
||||
[] typeStr []))) Nothing)
|
||||
, (cCAPIT , ResOper (Just (noLoc (mkProd -- Str
|
||||
[] typeStr []))) Nothing)
|
||||
, (cALL_CAPIT, ResOper (Just (noLoc (mkProd -- Str
|
||||
[] typeStr []))) Nothing)
|
||||
]
|
||||
where
|
||||
fun from to = oper (mkFunType from to)
|
||||
oper ty = ResOper (Just (noLoc ty)) Nothing
|
||||
|
||||
varL = identS "L"
|
||||
varP = identS "P"
|
||||
324
src/compiler/api/GF/Compile/TypeCheck/TC.hs
Normal file
324
src/compiler/api/GF/Compile/TypeCheck/TC.hs
Normal file
@@ -0,0 +1,324 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : TC
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/10/02 20:50:19 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.11 $
|
||||
--
|
||||
-- Thierry Coquand's type checking algorithm that creates a trace
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Compile.TypeCheck.TC (
|
||||
AExp(..),
|
||||
Theory,
|
||||
checkExp,
|
||||
inferExp,
|
||||
checkBranch,
|
||||
eqVal,
|
||||
whnf
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Grammar
|
||||
import GF.Grammar.Predef
|
||||
|
||||
import Control.Monad
|
||||
--import Data.List (sortBy)
|
||||
import Data.Maybe
|
||||
import GF.Text.Pretty
|
||||
|
||||
data AExp =
|
||||
AVr Ident Val
|
||||
| ACn QIdent Val
|
||||
| AType
|
||||
| AInt Integer
|
||||
| AFloat Double
|
||||
| AStr String
|
||||
| AMeta MetaId Val
|
||||
| ALet (Ident,(Val,AExp)) AExp
|
||||
| AApp AExp AExp Val
|
||||
| AAbs Ident Val AExp
|
||||
| AProd Ident AExp AExp
|
||||
-- -- | AEqs [([Exp],AExp)] --- not used
|
||||
| ARecType [ALabelling]
|
||||
| AR [AAssign]
|
||||
| AP AExp Label Val
|
||||
| AGlue AExp AExp
|
||||
| AData Val
|
||||
deriving (Eq,Show)
|
||||
|
||||
type ALabelling = (Label, AExp)
|
||||
type AAssign = (Label, (Val, AExp))
|
||||
|
||||
type Theory = QIdent -> Err Val
|
||||
|
||||
lookupConst :: Theory -> QIdent -> Err Val
|
||||
lookupConst th f = th f
|
||||
|
||||
lookupVar :: Env -> Ident -> Err Val
|
||||
lookupVar g x = maybe (Bad (render ("unknown variable" <+> x))) return $ lookup x ((identW,VClos [] (Meta 0)):g)
|
||||
-- wild card IW: no error produced, ?0 instead.
|
||||
|
||||
type TCEnv = (Int,Env,Env)
|
||||
|
||||
--emptyTCEnv :: TCEnv
|
||||
--emptyTCEnv = (0,[],[])
|
||||
|
||||
whnf :: Val -> Err Val
|
||||
whnf v = ---- errIn ("whnf" +++ prt v) $ ---- debug
|
||||
case v of
|
||||
VApp u w -> do
|
||||
u' <- whnf u
|
||||
w' <- whnf w
|
||||
app u' w'
|
||||
VClos env e -> eval env e
|
||||
_ -> return v
|
||||
|
||||
app :: Val -> Val -> Err Val
|
||||
app u v = case u of
|
||||
VClos env (Abs _ x e) -> eval ((x,v):env) e
|
||||
_ -> return $ VApp u v
|
||||
|
||||
eval :: Env -> Term -> Err Val
|
||||
eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
|
||||
case e of
|
||||
Vr x -> lookupVar env x
|
||||
Q c -> return $ VCn c
|
||||
QC c -> return $ VCn c ---- == Q ?
|
||||
Sort c -> return $ VType --- the only sort is Type
|
||||
App f a -> join $ liftM2 app (eval env f) (eval env a)
|
||||
RecType xs -> do xs <- mapM (\(l,e) -> eval env e >>= \e -> return (l,e)) xs
|
||||
return (VRecType xs)
|
||||
_ -> return $ VClos env e
|
||||
|
||||
eqVal :: Int -> Val -> Val -> Err [(Val,Val)]
|
||||
eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $
|
||||
do
|
||||
w1 <- whnf u1
|
||||
w2 <- whnf u2
|
||||
let v = VGen k
|
||||
case (w1,w2) of
|
||||
(VApp f1 a1, VApp f2 a2) -> liftM2 (++) (eqVal k f1 f2) (eqVal k a1 a2)
|
||||
(VClos env1 (Abs _ x1 e1), VClos env2 (Abs _ x2 e2)) ->
|
||||
eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2)
|
||||
(VClos env1 (Prod _ x1 a1 e1), VClos env2 (Prod _ x2 a2 e2)) ->
|
||||
liftM2 (++)
|
||||
(eqVal k (VClos env1 a1) (VClos env2 a2))
|
||||
(eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2))
|
||||
(VGen i _, VGen j _) -> return [(w1,w2) | i /= j]
|
||||
(VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j]
|
||||
--- thus ignore qualifications; valid because inheritance cannot
|
||||
--- be qualified. Simplifies annotation. AR 17/3/2005
|
||||
_ -> return [(w1,w2) | w1 /= w2]
|
||||
-- invariant: constraints are in whnf
|
||||
|
||||
checkType :: Theory -> TCEnv -> Term -> Err (AExp,[(Val,Val)])
|
||||
checkType th tenv e = checkExp th tenv e vType
|
||||
|
||||
checkExp :: Theory -> TCEnv -> Term -> Val -> Err (AExp, [(Val,Val)])
|
||||
checkExp th tenv@(k,rho,gamma) e ty = do
|
||||
typ <- whnf ty
|
||||
let v = VGen k
|
||||
case e of
|
||||
Meta m -> return $ (AMeta m typ,[])
|
||||
|
||||
Abs _ x t -> case typ of
|
||||
VClos env (Prod _ y a b) -> do
|
||||
a' <- whnf $ VClos env a ---
|
||||
(t',cs) <- checkExp th
|
||||
(k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
|
||||
return (AAbs x a' t', cs)
|
||||
_ -> Bad (render ("function type expected for" <+> ppTerm Unqualified 0 e <+> "instead of" <+> ppValue Unqualified 0 typ))
|
||||
|
||||
Let (x, (mb_typ, e1)) e2 -> do
|
||||
(val,e1,cs1) <- case mb_typ of
|
||||
Just typ -> do (_,cs1) <- checkType th tenv typ
|
||||
val <- eval rho typ
|
||||
(e1,cs2) <- checkExp th tenv e1 val
|
||||
return (val,e1,cs1++cs2)
|
||||
Nothing -> do (e1,val,cs) <- inferExp th tenv e1
|
||||
return (val,e1,cs)
|
||||
(e2,cs2) <- checkExp th (k,rho,(x,val):gamma) e2 typ
|
||||
return (ALet (x,(val,e1)) e2, cs1++cs2)
|
||||
|
||||
Prod _ x a b -> do
|
||||
testErr (typ == vType) "expected Type"
|
||||
(a',csa) <- checkType th tenv a
|
||||
(b',csb) <- checkType th (k+1, (x,v x):rho, (x,VClos rho a):gamma) b
|
||||
return (AProd x a' b', csa ++ csb)
|
||||
|
||||
R xs ->
|
||||
case typ of
|
||||
VRecType ys -> do case [l | (l,_) <- ys, isNothing (lookup l xs)] of
|
||||
[] -> return ()
|
||||
ls -> fail (render ("no value given for label:" <+> fsep (punctuate ',' ls)))
|
||||
r <- mapM (checkAssign th tenv ys) xs
|
||||
let (xs,css) = unzip r
|
||||
return (AR xs, concat css)
|
||||
_ -> Bad (render ("record type expected for" <+> ppTerm Unqualified 0 e <+> "instead of" <+> ppValue Unqualified 0 typ))
|
||||
|
||||
P r l -> do (r',cs) <- checkExp th tenv r (VRecType [(l,typ)])
|
||||
return (AP r' l typ,cs)
|
||||
|
||||
Glue x y -> do cs1 <- eqVal k valAbsFloat typ
|
||||
(x,cs2) <- checkExp th tenv x typ
|
||||
(y,cs3) <- checkExp th tenv y typ
|
||||
return (AGlue x y,cs1++cs2++cs3)
|
||||
_ -> checkInferExp th tenv e typ
|
||||
|
||||
checkInferExp :: Theory -> TCEnv -> Term -> Val -> Err (AExp, [(Val,Val)])
|
||||
checkInferExp th tenv@(k,_,_) e typ = do
|
||||
(e',w,cs1) <- inferExp th tenv e
|
||||
cs2 <- eqVal k w typ
|
||||
return (e',cs1 ++ cs2)
|
||||
|
||||
inferExp :: Theory -> TCEnv -> Term -> Err (AExp, Val, [(Val,Val)])
|
||||
inferExp th tenv@(k,rho,gamma) e = case e of
|
||||
Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x
|
||||
Q (m,c) | m == cPredefAbs && isPredefCat c
|
||||
-> return (ACn (m,c) vType, vType, [])
|
||||
| otherwise -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c)
|
||||
QC c -> mkAnnot (ACn c) $ noConstr $ lookupConst th c ----
|
||||
EInt i -> return (AInt i, valAbsInt, [])
|
||||
EFloat i -> return (AFloat i, valAbsFloat, [])
|
||||
K i -> return (AStr i, valAbsString, [])
|
||||
Sort _ -> return (AType, vType, [])
|
||||
RecType xs -> do r <- mapM (checkLabelling th tenv) xs
|
||||
let (xs,css) = unzip r
|
||||
return (ARecType xs, vType, concat css)
|
||||
Let (x, (mb_typ, e1)) e2 -> do
|
||||
(val1,e1,cs1) <- case mb_typ of
|
||||
Just typ -> do (_,cs1) <- checkType th tenv typ
|
||||
val <- eval rho typ
|
||||
(e1,cs2) <- checkExp th tenv e1 val
|
||||
return (val,e1,cs1++cs2)
|
||||
Nothing -> do (e1,val,cs) <- inferExp th tenv e1
|
||||
return (val,e1,cs)
|
||||
(e2,val2,cs2) <- inferExp th (k,rho,(x,val1):gamma) e2
|
||||
return (ALet (x,(val1,e1)) e2, val2, cs1++cs2)
|
||||
App f t -> do
|
||||
(f',w,csf) <- inferExp th tenv f
|
||||
typ <- whnf w
|
||||
case typ of
|
||||
VClos env (Prod _ x a b) -> do
|
||||
(a',csa) <- checkExp th tenv t (VClos env a)
|
||||
b' <- whnf $ VClos ((x,VClos rho t):env) b
|
||||
return $ (AApp f' a' b', b', csf ++ csa)
|
||||
_ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
|
||||
_ -> Bad (render ("cannot infer type of expression" <+> ppTerm Unqualified 0 e))
|
||||
|
||||
checkLabelling :: Theory -> TCEnv -> Labelling -> Err (ALabelling, [(Val,Val)])
|
||||
checkLabelling th tenv (lbl,typ) = do
|
||||
(atyp,cs) <- checkType th tenv typ
|
||||
return ((lbl,atyp),cs)
|
||||
|
||||
checkAssign :: Theory -> TCEnv -> [(Label,Val)] -> Assign -> Err (AAssign, [(Val,Val)])
|
||||
checkAssign th tenv@(k,rho,gamma) typs (lbl,(Just typ,exp)) = do
|
||||
(atyp,cs1) <- checkType th tenv typ
|
||||
val <- eval rho typ
|
||||
cs2 <- case lookup lbl typs of
|
||||
Nothing -> return []
|
||||
Just val0 -> eqVal k val val0
|
||||
(aexp,cs3) <- checkExp th tenv exp val
|
||||
return ((lbl,(val,aexp)),cs1++cs2++cs3)
|
||||
checkAssign th tenv@(k,rho,gamma) typs (lbl,(Nothing,exp)) = do
|
||||
case lookup lbl typs of
|
||||
Nothing -> do (aexp,val,cs) <- inferExp th tenv exp
|
||||
return ((lbl,(val,aexp)),cs)
|
||||
Just val -> do (aexp,cs) <- checkExp th tenv exp val
|
||||
return ((lbl,(val,aexp)),cs)
|
||||
|
||||
checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Term],AExp),[(Val,Val)])
|
||||
checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
|
||||
chB tenv' ps' ty
|
||||
where
|
||||
|
||||
(ps',_,rho2,k') = ps2ts k ps
|
||||
tenv' = (k, rho2++rho, gamma) ---- k' ?
|
||||
(k,rho,gamma) = tenv
|
||||
|
||||
chB tenv@(k,rho,gamma) ps ty = case ps of
|
||||
p:ps2 -> do
|
||||
typ <- whnf ty
|
||||
case typ of
|
||||
VClos env (Prod _ y a b) -> do
|
||||
a' <- whnf $ VClos env a
|
||||
(p', sigma, binds, cs1) <- checkP tenv p y a'
|
||||
let tenv' = (length binds, sigma ++ rho, binds ++ gamma)
|
||||
((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b)
|
||||
return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
|
||||
_ -> Bad (render ("Product expected for definiens" <+> ppTerm Unqualified 0 t <+> "instead of" <+> ppValue Unqualified 0 typ))
|
||||
[] -> do
|
||||
(e,cs) <- checkExp th tenv t ty
|
||||
return (([],e),cs)
|
||||
checkP env@(k,rho,gamma) t x a = do
|
||||
(delta,cs) <- checkPatt th env t a
|
||||
let sigma = [(x, VGen i x) | ((x,_),i) <- zip delta [k..]]
|
||||
return (VClos sigma t, sigma, delta, cs)
|
||||
|
||||
ps2ts k = foldr p2t ([],0,[],k)
|
||||
p2t p (ps,i,g,k) = case p of
|
||||
PW -> (Meta i : ps, i+1,g,k)
|
||||
PV x -> (Vr x : ps, i, upd x k g,k+1)
|
||||
PAs x p -> p2t p (ps,i,g,k)
|
||||
PString s -> (K s : ps, i, g, k)
|
||||
PInt n -> (EInt n : ps, i, g, k)
|
||||
PFloat n -> (EFloat n : ps, i, g, k)
|
||||
PP c xs -> (mkApp (Q c) xss : ps, j, g',k')
|
||||
where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
|
||||
PImplArg p -> p2t p (ps,i,g,k)
|
||||
PTilde t -> (t : ps, i, g, k)
|
||||
_ -> error $ render ("undefined p2t case" <+> ppPatt Unqualified 0 p <+> "in checkBranch")
|
||||
|
||||
upd x k g = (x, VGen k x) : g --- hack to recognize pattern variables
|
||||
|
||||
|
||||
checkPatt :: Theory -> TCEnv -> Term -> Val -> Err (Binds,[(Val,Val)])
|
||||
checkPatt th tenv exp val = do
|
||||
(aexp,_,cs) <- checkExpP tenv exp val
|
||||
let binds = extrBinds aexp
|
||||
return (binds,cs)
|
||||
where
|
||||
extrBinds aexp = case aexp of
|
||||
AVr i v -> [(i,v)]
|
||||
AApp f a _ -> extrBinds f ++ extrBinds a
|
||||
_ -> [] -- no other cases are possible
|
||||
|
||||
--- ad hoc, to find types of variables
|
||||
checkExpP tenv@(k,rho,gamma) exp val = case exp of
|
||||
Meta m -> return $ (AMeta m val, val, [])
|
||||
Vr x -> return $ (AVr x val, val, [])
|
||||
EInt i -> return (AInt i, valAbsInt, [])
|
||||
EFloat i -> return (AFloat i, valAbsFloat, [])
|
||||
K s -> return (AStr s, valAbsString, [])
|
||||
|
||||
Q c -> do
|
||||
typ <- lookupConst th c
|
||||
return $ (ACn c typ, typ, [])
|
||||
QC c -> do
|
||||
typ <- lookupConst th c
|
||||
return $ (ACn c typ, typ, []) ----
|
||||
App f t -> do
|
||||
(f',w,csf) <- checkExpP tenv f val
|
||||
typ <- whnf w
|
||||
case typ of
|
||||
VClos env (Prod _ x a b) -> do
|
||||
(a',_,csa) <- checkExpP tenv t (VClos env a)
|
||||
b' <- whnf $ VClos ((x,VClos rho t):env) b
|
||||
return $ (AApp f' a' b', b', csf ++ csa)
|
||||
_ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
|
||||
_ -> Bad (render ("cannot typecheck pattern" <+> ppTerm Unqualified 0 exp))
|
||||
|
||||
-- auxiliaries
|
||||
|
||||
noConstr :: Err Val -> Err (Val,[(Val,Val)])
|
||||
noConstr er = er >>= (\v -> return (v,[]))
|
||||
|
||||
mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)])
|
||||
mkAnnot a ti = do
|
||||
(v,cs) <- ti
|
||||
return (a v, v, cs)
|
||||
234
src/compiler/api/GF/Compile/Update.hs
Normal file
234
src/compiler/api/GF/Compile/Update.hs
Normal file
@@ -0,0 +1,234 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Update
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/05/30 18:39:44 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.8 $
|
||||
--
|
||||
-- (Description of the module)
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Compile.Update (buildAnyTree, extendModule, rebuildModule) where
|
||||
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Option
|
||||
import GF.Infra.CheckM
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Printer
|
||||
import GF.Grammar.Lookup
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
import Data.List
|
||||
import qualified Data.Map as Map
|
||||
import Control.Monad
|
||||
import GF.Text.Pretty
|
||||
import qualified Control.Monad.Fail as Fail
|
||||
|
||||
-- | combine a list of definitions into a balanced binary search tree
|
||||
buildAnyTree :: Fail.MonadFail m => ModuleName -> [(Ident,Info)] -> m (Map.Map Ident Info)
|
||||
buildAnyTree m = go Map.empty
|
||||
where
|
||||
go map [] = return map
|
||||
go map ((c,j):is) =
|
||||
case Map.lookup c map of
|
||||
Just i -> case unifyAnyInfo m i j of
|
||||
Ok k -> go (Map.insert c k map) is
|
||||
Bad _ -> fail $ render ("conflicting information in module"<+>m $$
|
||||
nest 4 (ppJudgement Qualified (c,i)) $$
|
||||
"and" $+$
|
||||
nest 4 (ppJudgement Qualified (c,j)))
|
||||
Nothing -> go (Map.insert c j map) is
|
||||
|
||||
extendModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
|
||||
extendModule cwd gr (name,m)
|
||||
---- Just to allow inheritance in incomplete concrete (which are not
|
||||
---- compiled anyway), extensions are not built for them.
|
||||
---- Should be replaced by real control. AR 4/2/2005
|
||||
| mstatus m == MSIncomplete && isModCnc m = return (name,m)
|
||||
| otherwise = checkInModule cwd m NoLoc empty $ do
|
||||
m' <- foldM extOne m (mextend m)
|
||||
return (name,m')
|
||||
where
|
||||
extOne mo (n,cond) = do
|
||||
m0 <- lookupModule gr n
|
||||
|
||||
-- test that the module types match, and find out if the old is complete
|
||||
unless (sameMType (mtype m) (mtype mo))
|
||||
(checkError ("illegal extension type to module" <+> name))
|
||||
|
||||
let isCompl = isCompleteModule m0
|
||||
|
||||
-- build extension in a way depending on whether the old module is complete
|
||||
js1 <- extendMod gr isCompl ((n,m0), isInherited cond) name (jments mo)
|
||||
|
||||
-- if incomplete, throw away extension information
|
||||
return $
|
||||
if isCompl
|
||||
then mo {jments = js1}
|
||||
else mo {mextend= filter ((/=n) . fst) (mextend mo)
|
||||
,mexdeps= nub (n : mexdeps mo)
|
||||
,jments = js1
|
||||
}
|
||||
|
||||
-- | rebuilding instance + interface, and "with" modules, prior to renaming.
|
||||
-- AR 24/10/2003
|
||||
rebuildModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
|
||||
rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ mseqs js_)) =
|
||||
checkInModule cwd mi NoLoc empty $ do
|
||||
|
||||
---- deps <- moduleDeps ms
|
||||
---- is <- openInterfaces deps i
|
||||
let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005
|
||||
mi' <- case mw of
|
||||
|
||||
-- add the information given in interface into an instance module
|
||||
Nothing -> do
|
||||
unless (null is || mstatus mi == MSIncomplete)
|
||||
(checkError ("module" <+> i <+>
|
||||
"has open interfaces and must therefore be declared incomplete"))
|
||||
case mt of
|
||||
MTInstance (i0,mincl) -> do
|
||||
m1 <- lookupModule gr i0
|
||||
unless (isModRes m1)
|
||||
(checkError ("interface expected instead of" <+> i0))
|
||||
js' <- extendMod gr False ((i0,m1), isInherited mincl) i (jments mi)
|
||||
--- to avoid double inclusions, in instance I of I0 = J0 ** ...
|
||||
case extends mi of
|
||||
[] -> return mi{jments=js'}
|
||||
j0s -> do
|
||||
m0s <- mapM (lookupModule gr) j0s
|
||||
let notInM0 c _ = all (not . Map.member c . jments) m0s
|
||||
let js2 = Map.filterWithKey notInM0 js'
|
||||
return mi{jments=js2}
|
||||
_ -> return mi
|
||||
|
||||
-- add the instance opens to an incomplete module "with" instances
|
||||
Just (ext,incl,ops) -> do
|
||||
let (infs,insts) = unzip ops
|
||||
let stat' = if all (flip elem infs) is
|
||||
then MSComplete
|
||||
else MSIncomplete
|
||||
unless (stat' == MSComplete || stat == MSIncomplete)
|
||||
(checkError ("module" <+> i <+> "remains incomplete"))
|
||||
ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext
|
||||
let ops1 = nub $
|
||||
ops_ ++ -- N.B. js has been name-resolved already
|
||||
[OQualif i j | (i,j) <- ops] ++
|
||||
[o | o <- ops0, notElem (openedModule o) infs] ++
|
||||
[OQualif i i | i <- insts] ++
|
||||
[OSimple i | i <- insts]
|
||||
|
||||
--- check if me is incomplete
|
||||
let fs1 = fs `addOptions` fs_ -- new flags have priority
|
||||
let js0 = Map.mapMaybeWithKey (\c j -> if isInherited incl c
|
||||
then Just (globalizeLoc fpath j)
|
||||
else Nothing)
|
||||
js
|
||||
let js1 = Map.union js0 js_
|
||||
let med1= nub (ext : infs ++ insts ++ med_)
|
||||
return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ mseqs js1
|
||||
|
||||
return (i,mi')
|
||||
|
||||
-- | When extending a complete module: new information is inserted,
|
||||
-- and the process is interrupted if unification fails.
|
||||
-- If the extended module is incomplete, its judgements are just copied.
|
||||
extendMod :: Grammar ->
|
||||
Bool -> (Module,Ident -> Bool) -> ModuleName ->
|
||||
Map.Map Ident Info -> Check (Map.Map Ident Info)
|
||||
extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi)
|
||||
where
|
||||
try new (c,i0)
|
||||
| not (cond c) = return new
|
||||
| otherwise = case Map.lookup c new of
|
||||
Just j -> case unifyAnyInfo name i j of
|
||||
Ok k -> return $ Map.insert c k new
|
||||
Bad _ -> do (base,j) <- case j of
|
||||
AnyInd _ m -> lookupOrigInfo gr (m,c)
|
||||
_ -> return (base,j)
|
||||
(name,i) <- case i of
|
||||
AnyInd _ m -> lookupOrigInfo gr (m,c)
|
||||
_ -> return (name,i)
|
||||
checkError ("cannot unify the information" $$
|
||||
nest 4 (ppJudgement Qualified (c,i)) $$
|
||||
"in module" <+> name <+> "with" $$
|
||||
nest 4 (ppJudgement Qualified (c,j)) $$
|
||||
"in module" <+> base)
|
||||
Nothing-> if isCompl
|
||||
then return $ Map.insert c (indirInfo name i) new
|
||||
else return $ Map.insert c i new
|
||||
where
|
||||
i = globalizeLoc (msrc mi) i0
|
||||
|
||||
indirInfo :: ModuleName -> Info -> Info
|
||||
indirInfo n info = AnyInd b n' where
|
||||
(b,n') = case info of
|
||||
ResValue _ _ -> (True,n)
|
||||
ResParam _ _ -> (True,n)
|
||||
AbsFun _ _ Nothing _ -> (True,n)
|
||||
AnyInd b k -> (b,k)
|
||||
_ -> (False,n) ---- canonical in Abs
|
||||
|
||||
globalizeLoc fpath i =
|
||||
case i of
|
||||
AbsCat mc -> AbsCat (fmap gl mc)
|
||||
AbsFun mt ma md moper -> AbsFun (fmap gl mt) ma (fmap (fmap gl) md) moper
|
||||
ResParam mt mv -> ResParam (fmap gl mt) mv
|
||||
ResValue t i -> ResValue (gl t) i
|
||||
ResOper mt m -> ResOper (fmap gl mt) (fmap gl m)
|
||||
ResOverload ms os -> ResOverload ms (map (\(x,y) -> (gl x,gl y)) os)
|
||||
CncCat mc md mr mp mpmcfg-> CncCat (fmap gl mc) (fmap gl md) (fmap gl mr) (fmap gl mp) mpmcfg
|
||||
CncFun m mt md mpmcfg-> CncFun m (fmap gl mt) (fmap gl md) mpmcfg
|
||||
AnyInd b m -> AnyInd b m
|
||||
where
|
||||
gl (L loc0 x) = loc `seq` L (External fpath loc) x
|
||||
where
|
||||
loc = case loc0 of
|
||||
External _ loc -> loc
|
||||
loc -> loc
|
||||
|
||||
unifyAnyInfo :: ModuleName -> Info -> Info -> Err Info
|
||||
unifyAnyInfo m i j = case (i,j) of
|
||||
(AbsCat mc1, AbsCat mc2) ->
|
||||
liftM AbsCat (unifyMaybeL mc1 mc2)
|
||||
(AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) ->
|
||||
liftM4 AbsFun (unifyMaybeL mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) (unifyMaybe moper1 moper2) -- adding defs
|
||||
|
||||
(ResParam mt1 mv1, ResParam mt2 mv2) ->
|
||||
liftM2 ResParam (unifyMaybeL mt1 mt2) (unifyMaybe mv1 mv2)
|
||||
(ResValue (L l1 t1) i1, ResValue (L l2 t2) i2)
|
||||
| t1==t2 && i1 == i2 -> return (ResValue (L l1 t1) i1)
|
||||
| otherwise -> fail ""
|
||||
(_, ResOverload ms t) | elem m ms ->
|
||||
return $ ResOverload ms t
|
||||
(ResOper mt1 m1, ResOper mt2 m2) ->
|
||||
liftM2 ResOper (unifyMaybeL mt1 mt2) (unifyMaybeL m1 m2)
|
||||
|
||||
(CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) ->
|
||||
liftM5 CncCat (unifyMaybeL mc1 mc2) (unifyMaybeL md1 md2) (unifyMaybeL mr1 mr2) (unifyMaybeL mp1 mp2) (unifyMaybe mpmcfg1 mpmcfg2)
|
||||
(CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) ->
|
||||
liftM3 (CncFun m) (unifyMaybeL mt1 mt2) (unifyMaybeL md1 md2) (unifyMaybe mpmcfg1 mpmcfg2)
|
||||
|
||||
(AnyInd b1 m1, AnyInd b2 m2) -> do
|
||||
testErr (b1 == b2) $ "indirection status"
|
||||
testErr (m1 == m2) $ "different sources of indirection"
|
||||
return i
|
||||
|
||||
_ -> fail "informations"
|
||||
|
||||
-- | this is what happens when matching two values in the same module
|
||||
unifyMaybeL :: Eq a => Maybe (L a) -> Maybe (L a) -> Err (Maybe (L a))
|
||||
unifyMaybeL = unifyMaybeBy unLoc
|
||||
|
||||
unifAbsArrity :: Maybe Int -> Maybe Int -> Err (Maybe Int)
|
||||
unifAbsArrity = unifyMaybe
|
||||
|
||||
unifAbsDefs :: Maybe [L Equation] -> Maybe [L Equation] -> Err (Maybe [L Equation])
|
||||
unifAbsDefs (Just xs) (Just ys) = return (Just (xs ++ ys))
|
||||
unifAbsDefs Nothing Nothing = return Nothing
|
||||
unifAbsDefs _ _ = fail ""
|
||||
232
src/compiler/api/GF/Compile/pgf.schema.json
Normal file
232
src/compiler/api/GF/Compile/pgf.schema.json
Normal file
@@ -0,0 +1,232 @@
|
||||
{
|
||||
"$schema": "http://json-schema.org/draft-07/schema#",
|
||||
"$id": "http://grammaticalframework.org/pgf.schema.json",
|
||||
"type": "object",
|
||||
"title": "PGF JSON Schema",
|
||||
"required": [
|
||||
"abstract",
|
||||
"concretes"
|
||||
],
|
||||
"properties": {
|
||||
"abstract": {
|
||||
"type": "object",
|
||||
"required": [
|
||||
"name",
|
||||
"startcat",
|
||||
"funs"
|
||||
],
|
||||
"properties": {
|
||||
"name": {
|
||||
"type": "string"
|
||||
},
|
||||
"startcat": {
|
||||
"type": "string"
|
||||
},
|
||||
"funs": {
|
||||
"type": "object",
|
||||
"additionalProperties": {
|
||||
"type": "object",
|
||||
"required": [
|
||||
"args",
|
||||
"cat"
|
||||
],
|
||||
"properties": {
|
||||
"args": {
|
||||
"type": "array",
|
||||
"items": {
|
||||
"type": "string"
|
||||
}
|
||||
},
|
||||
"cat": {
|
||||
"type": "string"
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
},
|
||||
"concretes": {
|
||||
"type": "object",
|
||||
"additionalProperties": {
|
||||
"required": [
|
||||
"flags",
|
||||
"productions",
|
||||
"functions",
|
||||
"sequences",
|
||||
"categories",
|
||||
"totalfids"
|
||||
],
|
||||
"properties": {
|
||||
"flags": {
|
||||
"type": "object",
|
||||
"additionalProperties": {
|
||||
"type": ["string", "number"]
|
||||
}
|
||||
},
|
||||
"productions": {
|
||||
"type": "object",
|
||||
"additionalProperties": {
|
||||
"type": "array",
|
||||
"items": {
|
||||
"oneOf": [
|
||||
{
|
||||
"$ref": "#/definitions/apply"
|
||||
},
|
||||
{
|
||||
"$ref": "#/definitions/coerce"
|
||||
}
|
||||
]
|
||||
}
|
||||
}
|
||||
},
|
||||
"functions": {
|
||||
"type": "array",
|
||||
"items": {
|
||||
"title": "CncFun",
|
||||
"type": "object",
|
||||
"properties": {
|
||||
"name": {
|
||||
"type": "string"
|
||||
},
|
||||
"lins": {
|
||||
"type": "array",
|
||||
"items": {
|
||||
"type": "integer"
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
},
|
||||
"sequences": {
|
||||
"type": "array",
|
||||
"items": {
|
||||
"type": "array",
|
||||
"items": {
|
||||
"$ref": "#/definitions/sym"
|
||||
}
|
||||
}
|
||||
},
|
||||
"categories": {
|
||||
"type": "object",
|
||||
"additionalProperties": {
|
||||
"title": "CncCat",
|
||||
"type": "object",
|
||||
"required": [
|
||||
"start",
|
||||
"end"
|
||||
],
|
||||
"properties": {
|
||||
"start": {
|
||||
"type": "integer"
|
||||
},
|
||||
"end": {
|
||||
"type": "integer"
|
||||
}
|
||||
}
|
||||
}
|
||||
},
|
||||
"totalfids": {
|
||||
"type": "integer"
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
},
|
||||
"definitions": {
|
||||
"apply": {
|
||||
"required": [
|
||||
"type",
|
||||
"fid",
|
||||
"args"
|
||||
],
|
||||
"properties": {
|
||||
"type": {
|
||||
"type": "string",
|
||||
"enum": ["Apply"]
|
||||
},
|
||||
"fid": {
|
||||
"type": "integer"
|
||||
},
|
||||
"args": {
|
||||
"type": "array",
|
||||
"items": {
|
||||
"$ref": "#/definitions/parg"
|
||||
}
|
||||
}
|
||||
}
|
||||
},
|
||||
"coerce": {
|
||||
"required": [
|
||||
"type",
|
||||
"arg"
|
||||
],
|
||||
"properties": {
|
||||
"type": {
|
||||
"type": "string",
|
||||
"enum": ["Coerce"]
|
||||
},
|
||||
"arg": {
|
||||
"type": "integer"
|
||||
}
|
||||
}
|
||||
},
|
||||
"parg": {
|
||||
"required": [
|
||||
"type",
|
||||
"hypos",
|
||||
"fid"
|
||||
],
|
||||
"properties": {
|
||||
"type": {
|
||||
"type": "string",
|
||||
"enum": ["PArg"]
|
||||
},
|
||||
"hypos": {
|
||||
"type": "array",
|
||||
"items": {
|
||||
"type": "integer"
|
||||
}
|
||||
},
|
||||
"fid": {
|
||||
"type": "integer"
|
||||
}
|
||||
}
|
||||
},
|
||||
"sym": {
|
||||
"title": "Sym",
|
||||
"required": [
|
||||
"type",
|
||||
"args"
|
||||
],
|
||||
"properties": {
|
||||
"type": {
|
||||
"type": "string",
|
||||
"enum": [
|
||||
"SymCat",
|
||||
"SymLit",
|
||||
"SymVar",
|
||||
"SymKS",
|
||||
"SymKP",
|
||||
"SymNE"
|
||||
]
|
||||
},
|
||||
"args": {
|
||||
"type": "array",
|
||||
"items": {
|
||||
"anyOf": [
|
||||
{
|
||||
"type": "string"
|
||||
},
|
||||
{
|
||||
"type": "integer"
|
||||
},
|
||||
{
|
||||
"$ref": "#/definitions/sym"
|
||||
}
|
||||
]
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
Reference in New Issue
Block a user