GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-12 06:19:33 -06:00
Code Issues Packages Projects Releases Wiki Activity
Files
ea9aed6ff8303a576c95683d8e647b13be836e88
gf-core/src/GF/Source/SourceToGrammar.hs

734 lines
26 KiB
Haskell
Raw Blame History

----------------------------------------------------------------------
-- |
-- Module : SourceToGrammar
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/04 11:05:07 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.28 $
--
-- based on the skeleton Haskell module generated by the BNF converter
-----------------------------------------------------------------------------
module GF.Source.SourceToGrammar ( transGrammar,
transInclude,
transModDef,
transOldGrammar,
transExp,
newReservedWords
) where
import qualified GF.Grammar.Grammar as G
import qualified GF.Grammar.PrGrammar as GP
import qualified GF.Infra.Modules as GM
import qualified GF.Grammar.Macros as M
import qualified GF.Compile.Update as U
import qualified GF.Infra.Option as GO
import qualified GF.Compile.ModDeps as GD
import GF.Grammar.Predef
import GF.Infra.Ident
import GF.Source.AbsGF
import GF.Source.PrintGF
import GF.Data.Operations
import GF.Infra.Option
import Control.Monad
import Data.Char
import Data.List (genericReplicate)
import qualified Data.ByteString.Char8 as BS
-- based on the skeleton Haskell module generated by the BNF converter
type Result = Err String
failure :: Show a => a -> Err b
failure x = Bad $ "Undefined case: " ++ show x
getIdentPos :: PIdent -> Err (Ident,Int)
getIdentPos x = case x of
PIdent ((line,_),c) -> return (IC c,line)
transIdent :: PIdent -> Err Ident
transIdent = liftM fst . getIdentPos
transName :: Name -> Err Ident
transName n = case n of
IdentName i -> transIdent i
ListName i -> liftM mkListId (transIdent i)
transNamePos :: Name -> Err (Ident,Int)
transNamePos n = case n of
IdentName i -> getIdentPos i
ListName i -> liftM (\ (c,p) -> (mkListId c,p)) (getIdentPos i)
transGrammar :: Grammar -> Err G.SourceGrammar
transGrammar x = case x of
Gr moddefs -> do
moddefs' <- mapM transModDef moddefs
GD.mkSourceGrammar moddefs'
transModDef :: ModDef -> Err G.SourceModule
transModDef x = case x of
MModule compl mtyp body -> do
let mstat' = transComplMod compl
(trDef, mtyp', id') <- case mtyp of
MTAbstract id -> do
id' <- transIdent id
return (transAbsDef, GM.MTAbstract, id')
MTResource id -> mkModRes id GM.MTResource body
MTConcrete id open -> do
id' <- transIdent id
open' <- transIdent open
return (transCncDef, GM.MTConcrete open', id')
MTTransfer id a b -> do
id' <- transIdent id
a' <- transOpen a
b' <- transOpen a
return (transAbsDef, GM.MTTransfer a' b', id')
MTInterface id -> mkModRes id GM.MTInterface body
MTInstance id open -> do
open' <- transIdent open
mkModRes id (GM.MTInstance open') body
mkBody (mstat', trDef, mtyp', id') body
where
poss = emptyBinTree ----
mkBody xx@(mstat', trDef, mtyp', id') bod = case bod of
MNoBody incls -> do
mkBody xx $ MBody (Ext incls) NoOpens []
MBody extends opens defs -> do
extends' <- transExtend extends
opens' <- transOpens opens
defs0 <- mapM trDef $ getTopDefs defs
poss0 <- return [(i,p) | Left ds <- defs0, (i,p,_) <- ds]
defs' <- U.buildAnyTree id' [(i,d) | Left ds <- defs0, (i,_,d) <- ds]
flags' <- return $ concatOptions [o | Right o <- defs0]
let poss1 = buildPosTree id' poss0
return (id', GM.ModInfo mtyp' mstat' flags' extends' Nothing opens' [] defs' poss1)
MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens []
MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs
MWithE extends m insts -> mkBody xx $ MWithEBody extends m insts NoOpens []
MWithEBody extends m insts opens defs -> do
extends' <- mapM transIncludedExt extends
m' <- transIncludedExt m
insts' <- mapM transInst insts
opens' <- transOpens opens
defs0 <- mapM trDef $ getTopDefs defs
poss0 <- return [(i,p) | Left ds <- defs0, (i,p,_) <- ds]
defs' <- U.buildAnyTree id' [(i,d) | Left ds <- defs0, (i,_,d) <- ds]
flags' <- return $ concatOptions [o | Right o <- defs0]
let poss1 = buildPosTree id' poss0
return (id', GM.ModInfo mtyp' mstat' flags' extends' (Just (fst m',snd m',insts')) opens' [] defs' poss1)
mkModRes id mtyp body = do
id' <- transIdent id
return (transResDef, mtyp, id')
transComplMod :: ComplMod -> GM.ModuleStatus
transComplMod x = case x of
CMCompl -> GM.MSComplete
CMIncompl -> GM.MSIncomplete
getTopDefs :: [TopDef] -> [TopDef]
getTopDefs x = x
transConcExp :: ConcExp ->
Err (Ident, Maybe (GM.OpenSpec Ident),Maybe (GM.OpenSpec Ident))
transConcExp x = case x of
ConcExp id transfers -> do
id' <- transIdent id
trs <- mapM transTransfer transfers
tin <- case [o | Left o <- trs] of
[o] -> return $ Just o
[] -> return $ Nothing
_ -> Bad "ambiguous transfer in"
tout <- case [o | Right o <- trs] of
[o] -> return $ Just o
[] -> return $ Nothing
_ -> Bad "ambiguous transfer out"
return (id',tin,tout)
transTransfer :: Transfer ->
Err (Either (GM.OpenSpec Ident)(GM.OpenSpec Ident))
transTransfer x = case x of
TransferIn open -> liftM Left $ transOpen open
TransferOut open -> liftM Right $ transOpen open
transExtend :: Extend -> Err [(Ident,GM.MInclude Ident)]
transExtend x = case x of
Ext ids -> mapM transIncludedExt ids
NoExt -> return []
transOpens :: Opens -> Err [GM.OpenSpec Ident]
transOpens x = case x of
NoOpens -> return []
OpenIn opens -> mapM transOpen opens
transOpen :: Open -> Err (GM.OpenSpec Ident)
transOpen x = case x of
OName id -> liftM GM.OSimple (transIdent id)
OQualQO q id -> liftM GM.OSimple (transIdent id)
OQual q id m -> liftM2 GM.OQualif (transIdent id) (transIdent m)
transInst :: Open -> Err (Ident,Ident)
transInst x = case x of
OQual q id m -> liftM2 (,) (transIdent id) (transIdent m)
_ -> Bad "qualified open expected"
transIncluded :: Included -> Err (Ident,[Ident])
transIncluded x = case x of
IAll i -> liftM (flip (curry id) []) $ transIdent i
ISome i ids -> liftM2 (curry id) (transIdent i) (mapM transIdent ids)
IMinus i ids -> liftM2 (curry id) (transIdent i) (mapM transIdent ids) ----
transIncludedExt :: Included -> Err (Ident, GM.MInclude Ident)
transIncludedExt x = case x of
IAll i -> liftM2 (,) (transIdent i) (return GM.MIAll)
ISome i ids -> liftM2 (,) (transIdent i) (liftM GM.MIOnly $ mapM transIdent ids)
IMinus i ids -> liftM2 (,) (transIdent i) (liftM GM.MIExcept $ mapM transIdent ids)
--- where no position is saved
nopos :: Int
nopos = -1
buildPosTree :: Ident -> [(Ident,Int)] -> BinTree Ident (String,(Int,Int))
buildPosTree m = buildTree . mkPoss . filter ((>0) . snd) where
mkPoss cs = case cs of
(i,p):rest@((_,q):_) -> (i,(name,(p,max p (q-1)))) : mkPoss rest
(i,p):[] -> (i,(name,(p,p+100))) : [] --- don't know last line
_ -> []
name = prIdent m ++ ".gf" ----
transAbsDef :: TopDef -> Err (Either [(Ident, Int, G.Info)] GO.Options)
transAbsDef x = case x of
DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs
DefFun fundefs -> do
fundefs' <- mapM transFunDef fundefs
returnl [(fun, nopos, G.AbsFun (Just typ) Nothing) | (funs,typ) <- fundefs', fun <- funs]
DefFunData fundefs -> do
fundefs' <- mapM transFunDef fundefs
returnl $
[(cat, nopos, G.AbsCat Nothing (Just [G.Cn fun])) | (funs,typ) <- fundefs',
fun <- funs,
Ok (_,cat) <- [M.valCat typ]
] ++
[(fun, nopos, G.AbsFun (Just typ) (Just G.EData)) | (funs,typ) <- fundefs', fun <- funs]
DefDef defs -> do
defs' <- liftM concat $ mapM getDefsGen defs
returnl [(c, nopos, G.AbsFun Nothing pe) | ((c,p),(_,pe)) <- defs']
DefData ds -> do
ds' <- mapM transDataDef ds
returnl $
[(c, nopos, G.AbsCat Nothing (Just ps)) | (c,ps) <- ds'] ++
[(f, nopos, G.AbsFun Nothing (Just G.EData)) | (_,fs) <- ds', tf <- fs, f <- funs tf]
DefFlag defs -> liftM (Right . concatOptions) $ mapM transFlagDef defs
_ -> Bad $ "illegal definition in abstract module:" ++++ printTree x
where
-- to get data constructors as terms
funs t = case t of
G.Cn f -> [f]
G.Q _ f -> [f]
G.QC _ f -> [f]
_ -> []
returnl :: a -> Err (Either a b)
returnl = return . Left
transFlagDef :: FlagDef -> Err GO.Options
transFlagDef x = case x of
FlagDef f x -> parseModuleOptions ["--" ++ prPIdent f ++ "=" ++ prPIdent x]
where
prPIdent (PIdent (_,c)) = BS.unpack c
-- | Cat definitions can also return some fun defs
-- if it is a list category definition
transCatDef :: CatDef -> Err [(Ident, Int, G.Info)]
transCatDef x = case x of
SimpleCatDef id ddecls -> do
(id',pos) <- getIdentPos id
liftM (:[]) $ cat id' pos ddecls
ListCatDef id ddecls -> listCat id ddecls 0
ListSizeCatDef id ddecls size -> listCat id ddecls size
where
cat i pos ddecls = do
-- i <- transIdent id
cont <- liftM concat $ mapM transDDecl ddecls
return (i, pos, G.AbsCat (Just cont) Nothing)
listCat id ddecls size = do
(id',pos) <- getIdentPos id
let
li = mkListId id'
baseId = mkBaseId id'
consId = mkConsId id'
catd0@(c,p,G.AbsCat (Just cont0) _) <- cat li pos ddecls
let
catd = (c,pos,G.AbsCat (Just cont0) (Just [G.Cn baseId,G.Cn consId]))
cont = [(mkId x i,ty) | (i,(x,ty)) <- zip [0..] cont0]
xs = map (G.Vr . fst) cont
cd = M.mkDecl (M.mkApp (G.Vr id') xs)
lc = M.mkApp (G.Vr li) xs
niltyp = M.mkProdSimple (cont ++ genericReplicate size cd) lc
nilfund = (baseId, nopos, G.AbsFun (Just niltyp) (Just G.EData))
constyp = M.mkProdSimple (cont ++ [cd, M.mkDecl lc]) lc
consfund = (consId, nopos, G.AbsFun (Just constyp) (Just G.EData))
return [catd,nilfund,consfund]
mkId x i = if isWildIdent x then (varX i) else x
transFunDef :: FunDef -> Err ([Ident], G.Type)
transFunDef x = case x of
FunDef ids typ -> liftM2 (,) (mapM transIdent ids) (transExp typ)
transDataDef :: DataDef -> Err (Ident,[G.Term])
transDataDef x = case x of
DataDef id ds -> liftM2 (,) (transIdent id) (mapM transData ds)
where
transData d = case d of
DataId id -> liftM G.Cn $ transIdent id
DataQId id0 id -> liftM2 G.QC (transIdent id0) (transIdent id)
transResDef :: TopDef -> Err (Either [(Ident, Int, G.Info)] GO.Options)
transResDef x = case x of
DefPar pardefs -> do
pardefs' <- mapM transParDef pardefs
returnl $ [(p, nopos, G.ResParam (if null pars
then Nothing -- abstract param type
else (Just (pars,Nothing))))
| (p,pars) <- pardefs']
++ [(f, nopos, G.ResValue (Just (M.mkProdSimple co (G.Cn p),Nothing))) |
(p,pars) <- pardefs', (f,co) <- pars]
DefOper defs -> do
defs' <- liftM concat $ mapM getDefs defs
returnl $
concatMap mkOverload [(f, p, G.ResOper pt pe) | ((f,p),(pt,pe)) <- defs']
DefLintype defs -> do
defs' <- liftM concat $ mapM getDefs defs
returnl [(f, p, G.ResOper pt pe) | ((f,p),(pt,pe)) <- defs']
DefFlag defs -> liftM (Right . concatOptions) $ mapM transFlagDef defs
_ -> Bad $ "illegal definition form in resource" +++ printTree x
where
mkOverload op@(c,p,j) = case j of
G.ResOper _ (Just df) -> case M.appForm df of
(keyw, ts@(_:_)) | isOverloading keyw -> case last ts of
G.R fs ->
[(c,p,G.ResOverload [m | G.Vr m <- ts] [(ty,fu) | (_,(Just ty,fu)) <- fs])]
_ -> [op]
_ -> [op]
-- to enable separare type signature --- not type-checked
G.ResOper (Just df) _ -> case M.appForm df of
(keyw, ts@(_:_)) | isOverloading keyw -> case last ts of
G.RecType _ -> []
_ -> [op]
_ -> [op]
_ -> [(c,p,j)]
isOverloading keyw =
GP.prt keyw == "overload" -- overload is a "soft keyword"
isRec t = case t of
G.R _ -> True
_ -> False
transParDef :: ParDef -> Err (Ident, [G.Param])
transParDef x = case x of
ParDefDir id params -> liftM2 (,) (transIdent id) (mapM transParConstr params)
ParDefAbs id -> liftM2 (,) (transIdent id) (return [])
_ -> Bad $ "illegal definition in resource:" ++++ printTree x
transCncDef :: TopDef -> Err (Either [(Ident, Int, G.Info)] GO.Options)
transCncDef x = case x of
DefLincat defs -> do
defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, nopos, G.CncCat (Just t) Nothing Nothing) | (f,t) <- defs']
DefLindef defs -> do
defs' <- liftM concat $ mapM getDefs defs
returnl [(f, p, G.CncCat pt pe Nothing) | ((f,p),(pt,pe)) <- defs']
DefLin defs -> do
defs' <- liftM concat $ mapM getDefs defs
returnl [(f, p, G.CncFun Nothing pe Nothing) | ((f,p),(_,pe)) <- defs']
DefPrintCat defs -> do
defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, nopos, G.CncCat Nothing Nothing (Just e)) | (f,e) <- defs']
DefPrintFun defs -> do
defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, nopos, G.CncFun Nothing Nothing (Just e)) | (f,e) <- defs']
DefPrintOld defs -> do --- a guess, for backward compatibility
defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, nopos, G.CncFun Nothing Nothing (Just e)) | (f,e) <- defs']
DefFlag defs -> liftM (Right . concatOptions) $ mapM transFlagDef defs
DefPattern defs -> do
defs' <- liftM concat $ mapM getDefs defs
let defs2 = [(f, termInPattern t) | (f,(_,Just t)) <- defs']
returnl [(f, p, G.CncFun Nothing (Just t) Nothing) | ((f,p),t) <- defs2]
_ -> errIn ("illegal definition in concrete syntax:") $ transResDef x
transPrintDef :: PrintDef -> Err [(Ident,G.Term)]
transPrintDef x = case x of
PrintDef ids exp -> do
(ids,e) <- liftM2 (,) (mapM transName ids) (transExp exp)
return $ [(i,e) | i <- ids]
getDefsGen :: Def -> Err [((Ident, Int),(Maybe G.Type, Maybe G.Term))]
getDefsGen d = case d of
DDecl ids t -> do
ids' <- mapM transNamePos ids
t' <- transExp t
return [(i,(Just t', Nothing)) | i <- ids']
DDef ids e -> do
ids' <- mapM transNamePos ids
e' <- transExp e
return [(i,(Nothing, Just e')) | i <- ids']
DFull ids t e -> do
ids' <- mapM transNamePos ids
t' <- transExp t
e' <- transExp e
return [(i,(Just t', Just e')) | i <- ids']
DPatt id patts e -> do
id' <- transNamePos id
ps' <- mapM transPatt patts
e' <- transExp e
return [(id',(Nothing, Just (G.Eqs [(ps',e')])))]
-- | sometimes you need this special case, e.g. in linearization rules
getDefs :: Def -> Err [((Ident,Int), (Maybe G.Type, Maybe G.Term))]
getDefs d = case d of
DPatt id patts e -> do
id' <- transNamePos id
xs <- mapM tryMakeVar patts
e' <- transExp e
return [(id',(Nothing, Just (M.mkAbs xs e')))]
_ -> getDefsGen d
-- | accepts a pattern that is either a variable or a wild card
tryMakeVar :: Patt -> Err Ident
tryMakeVar p = do
p' <- transPatt p
case p' of
G.PV i -> return i
G.PW -> return identW
_ -> Bad $ "not a legal pattern in lambda binding" +++ GP.prt p'
transExp :: Exp -> Err G.Term
transExp x = case x of
EIdent id -> liftM G.Vr $ transIdent id
EConstr id -> liftM G.Con $ transIdent id
ECons id -> liftM G.Cn $ transIdent id
EQConstr m c -> liftM2 G.QC (transIdent m) (transIdent c)
EQCons m c -> liftM2 G.Q (transIdent m) (transIdent c)
EString str -> return $ G.K str
ESort sort -> return $ G.Sort $ transSort sort
EInt n -> return $ G.EInt n
EFloat n -> return $ G.EFloat n
EMeta -> return $ G.Meta $ M.int2meta 0
EEmpty -> return G.Empty
-- [ C x_1 ... x_n ] becomes (ListC x_1 ... x_n)
EList i es -> do
i' <- transIdent i
es' <- mapM transExp (exps2list es)
return $ foldl G.App (G.Vr (mkListId i')) es'
EStrings [] -> return G.Empty
EStrings str -> return $ foldr1 G.C $ map G.K $ words str
ERecord defs -> erecord2term defs
ETupTyp _ _ -> do
let tups t = case t of
ETupTyp x y -> tups x ++ [y] -- right-associative parsing
_ -> [t]
es <- mapM transExp $ tups x
return $ G.RecType $ M.tuple2recordType es
ETuple tuplecomps -> do
es <- mapM transExp [e | TComp e <- tuplecomps]
return $ G.R $ M.tuple2record es
EProj exp id -> liftM2 G.P (transExp exp) (trLabel id)
EApp exp0 exp -> liftM2 G.App (transExp exp0) (transExp exp)
ETable cases -> liftM (G.T G.TRaw) (transCases cases)
ETTable exp cases ->
liftM2 (\t c -> G.T (G.TTyped t) c) (transExp exp) (transCases cases)
EVTable exp cases ->
liftM2 (\t c -> G.V t c) (transExp exp) (mapM transExp cases)
ECase exp cases -> do
exp' <- transExp exp
cases' <- transCases cases
let annot = case exp' of
G.Typed _ t -> G.TTyped t
_ -> G.TRaw
return $ G.S (G.T annot cases') exp'
ECTable binds exp -> liftM2 M.mkCTable (mapM transBind binds) (transExp exp)
EVariants exps -> liftM G.FV $ mapM transExp exps
EVariant exp0 exp -> do let fvList (G.FV xs) = xs
fvList t = [t]
exp0' <- transExp exp0
exp' <- transExp exp
return $ G.FV $ fvList exp0' ++ fvList exp'
EPre exp alts -> liftM2 (curry G.Alts) (transExp exp) (mapM transAltern alts)
EStrs exps -> liftM G.Strs $ mapM transExp exps
ESelect exp0 exp -> liftM2 G.S (transExp exp0) (transExp exp)
EExtend exp0 exp -> liftM2 G.ExtR (transExp exp0) (transExp exp)
EAbstr binds exp -> liftM2 M.mkAbs (mapM transBind binds) (transExp exp)
ETyped exp0 exp -> liftM2 G.Typed (transExp exp0) (transExp exp)
EExample exp str -> liftM2 G.Example (transExp exp) (return str)
EProd decl exp -> liftM2 M.mkProdSimple (transDecl decl) (transExp exp)
ETType exp0 exp -> liftM2 G.Table (transExp exp0) (transExp exp)
EConcat exp0 exp -> liftM2 G.C (transExp exp0) (transExp exp)
EGlue exp0 exp -> liftM2 G.Glue (transExp exp0) (transExp exp)
ELet defs exp -> do
exp' <- transExp exp
defs0 <- mapM locdef2fields defs
defs' <- mapM tryLoc $ concat defs0
return $ M.mkLet defs' exp'
where
tryLoc (c,(mty,Just e)) = return (c,(mty,e))
tryLoc (c,_) = Bad $ "local definition of" +++ GP.prt c +++ "without value"
ELetb defs exp -> transExp $ ELet defs exp
EWhere exp defs -> transExp $ ELet defs exp
EPattType typ -> liftM G.EPattType (transExp typ)
EPatt patt -> liftM G.EPatt (transPatt patt)
ELString (LString str) -> return $ G.K (BS.unpack str) -- use the grammar encoding here
EEqs eqs -> liftM G.Eqs $ mapM transEquation eqs
_ -> Bad $ "translation not yet defined for" +++ printTree x ----
exps2list :: Exps -> [Exp]
exps2list NilExp = []
exps2list (ConsExp e es) = e : exps2list es
--- this is complicated: should we change Exp or G.Term ?
erecord2term :: [LocDef] -> Err G.Term
erecord2term ds = do
ds' <- mapM locdef2fields ds
mkR $ concat ds'
where
mkR fs = do
fs' <- transF fs
return $ case fs' of
Left ts -> G.RecType ts
Right ds -> G.R ds
transF [] = return $ Left [] --- empty record always interpreted as record type
transF fs@(f:_) = case f of
(lab,(Just ty,Nothing)) -> mapM tryRT fs >>= return . Left
_ -> mapM tryR fs >>= return . Right
tryRT f = case f of
(lab,(Just ty,Nothing)) -> return (G.ident2label lab,ty)
_ -> Bad $ "illegal record type field" +++ GP.prt (fst f) --- manifest fields ?!
tryR f = case f of
(lab,(mty, Just t)) -> return (G.ident2label lab,(mty,t))
_ -> Bad $ "illegal record field" +++ GP.prt (fst f)
locdef2fields :: LocDef -> Err [(Ident, (Maybe G.Type, Maybe G.Type))]
locdef2fields d = case d of
LDDecl ids t -> do
labs <- mapM transIdent ids
t' <- transExp t
return [(lab,(Just t',Nothing)) | lab <- labs]
LDDef ids e -> do
labs <- mapM transIdent ids
e' <- transExp e
return [(lab,(Nothing, Just e')) | lab <- labs]
LDFull ids t e -> do
labs <- mapM transIdent ids
t' <- transExp t
e' <- transExp e
return [(lab,(Just t', Just e')) | lab <- labs]
trLabel :: Label -> Err G.Label
trLabel x = case x of
LIdent (PIdent (_, s)) -> return $ G.LIdent s
LVar x -> return $ G.LVar $ fromInteger x
transSort :: Sort -> Ident
transSort Sort_Type = cType
transSort Sort_PType = cPType
transSort Sort_Tok = cTok
transSort Sort_Str = cStr
transSort Sort_Strs = cStrs
{-
--- no more used 7/1/2006 AR
transPatts :: Patt -> Err [G.Patt]
transPatts p = case p of
PDisj p1 p2 -> liftM2 (++) (transPatts p1) (transPatts p2)
PC id patts -> liftM (map (G.PC id) . combinations) $ mapM transPatts patts
PQC q id patts -> liftM (map (G.PP q id) . combinations) (mapM transPatts patts)
PR pattasss -> do
let (lss,ps) = unzip [(ls,p) | PA ls p <- pattasss]
ls = map LIdent $ concat lss
ps0 <- mapM transPatts ps
let ps' = combinations ps0
lss' <- mapM trLabel ls
let rss = map (zip lss') ps'
return $ map G.PR rss
PTup pcs -> do
ps0 <- mapM transPatts [e | PTComp e <- pcs]
let ps' = combinations ps0
return $ map (G.PR . M.tuple2recordPatt) ps'
_ -> liftM singleton $ transPatt p
-}
transPatt :: Patt -> Err G.Patt
transPatt x = case x of
PW -> return G.PW
PV id -> liftM G.PV $ transIdent id
PC id patts -> liftM2 G.PC (transIdent id) (mapM transPatt patts)
PCon id -> liftM2 G.PC (transIdent id) (return [])
PInt n -> return $ G.PInt n
PFloat n -> return $ G.PFloat n
PStr str -> return $ G.PString str
PR pattasss -> do
let (lss,ps) = unzip [(ls,p) | PA ls p <- pattasss]
ls = map LIdent $ concat lss
liftM G.PR $ liftM2 zip (mapM trLabel ls) (mapM transPatt ps)
PTup pcs ->
liftM (G.PR . M.tuple2recordPatt) (mapM transPatt [e | PTComp e <- pcs])
PQ id0 id -> liftM3 G.PP (transIdent id0) (transIdent id) (return [])
PQC id0 id patts ->
liftM3 G.PP (transIdent id0) (transIdent id) (mapM transPatt patts)
PDisj p1 p2 -> liftM2 G.PAlt (transPatt p1) (transPatt p2)
PSeq p1 p2 -> liftM2 G.PSeq (transPatt p1) (transPatt p2)
PRep p -> liftM G.PRep (transPatt p)
PNeg p -> liftM G.PNeg (transPatt p)
PAs x p -> liftM2 G.PAs (transIdent x) (transPatt p)
PChar -> return G.PChar
PChars s -> return $ G.PChars s
PMacro c -> liftM G.PMacro $ transIdent c
PM m c -> liftM2 G.PM (transIdent m) (transIdent c)
transBind :: Bind -> Err Ident
transBind x = case x of
BIdent id -> transIdent id
BWild -> return identW
transDecl :: Decl -> Err [G.Decl]
transDecl x = case x of
DDec binds exp -> do
xs <- mapM transBind binds
exp' <- transExp exp
return [(x,exp') | x <- xs]
DExp exp -> liftM (return . M.mkDecl) $ transExp exp
transCases :: [Case] -> Err [G.Case]
transCases = mapM transCase
transCase :: Case -> Err G.Case
transCase (Case p exp) = do
patt <- transPatt p
exp' <- transExp exp
return (patt,exp')
transEquation :: Equation -> Err G.Equation
transEquation x = case x of
Equ apatts exp -> liftM2 (,) (mapM transPatt apatts) (transExp exp)
transAltern :: Altern -> Err (G.Term, G.Term)
transAltern x = case x of
Alt exp0 exp -> liftM2 (,) (transExp exp0) (transExp exp)
transParConstr :: ParConstr -> Err G.Param
transParConstr x = case x of
ParConstr id ddecls -> do
id' <- transIdent id
ddecls' <- mapM transDDecl ddecls
return (id',concat ddecls')
transDDecl :: DDecl -> Err [G.Decl]
transDDecl x = case x of
DDDec binds exp -> transDecl $ DDec binds exp
DDExp exp -> transDecl $ DExp exp
-- | to deal with the old format, sort judgements in two modules, forming
-- their names from a given string, e.g. file name or overriding user-given string
transOldGrammar :: Options -> FilePath -> OldGrammar -> Err G.SourceGrammar
transOldGrammar opts name0 x = case x of
OldGr includes topdefs -> do --- includes must be collected separately
let moddefs = sortTopDefs topdefs
transGrammar $ Gr moddefs
where
sortTopDefs ds = [mkAbs a, mkCnc ops (c ++ r)]
where
ops = map fst ps
(a,r,c,ps) = foldr srt ([],[],[],[]) ds
srt d (a,r,c,ps) = case d of
DefCat catdefs -> (d:a,r,c,ps)
DefFun fundefs -> (d:a,r,c,ps)
DefFunData fundefs -> (d:a,r,c,ps)
DefDef defs -> (d:a,r,c,ps)
DefData pardefs -> (d:a,r,c,ps)
DefPar pardefs -> (a,d:r,c,ps)
DefOper defs -> (a,d:r,c,ps)
DefLintype defs -> (a,d:r,c,ps)
DefLincat defs -> (a,r,d:c,ps)
DefLindef defs -> (a,r,d:c,ps)
DefLin defs -> (a,r,d:c,ps)
DefPattern defs -> (a,r,d:c,ps)
DefFlag defs -> (a,r,d:c,ps) --- a guess
DefPrintCat printdefs -> (a,r,d:c,ps)
DefPrintFun printdefs -> (a,r,d:c,ps)
DefPrintOld printdefs -> (a,r,d:c,ps)
-- DefPackage m ds -> (a,r,c,(m,ds):ps) -- OBSOLETE
_ -> (a,r,c,ps)
mkAbs a = MModule q (MTAbstract absName) (MBody ne (OpenIn []) (topDefs a))
mkCnc ps r = MModule q (MTConcrete cncName absName) (MBody ne (OpenIn []) (topDefs r))
topDefs t = t
ne = NoExt
q = CMCompl
name = maybe name0 (++ ".gf") $ flag optName opts
absName = identPI $ maybe topic id $ flag optAbsName opts
resName = identPI $ maybe ("Res" ++ lang) id $ flag optResName opts
cncName = identPI $ maybe lang id $ flag optCncName opts
identPI s = PIdent ((0,0),BS.pack s)
(beg,rest) = span (/='.') name
(topic,lang) = case rest of -- to avoid overwriting old files
".gf" -> ("Abs" ++ beg,"Cnc" ++ beg)
".cf" -> ("Abs" ++ beg,"Cnc" ++ beg)
".ebnf" -> ("Abs" ++ beg,"Cnc" ++ beg)
[] -> ("Abs" ++ beg,"Cnc" ++ beg)
_:s -> (beg, takeWhile (/='.') s)
transInclude :: Include -> Err [FilePath]
transInclude x = Bad "Old GF with includes no more supported in GF 3.0"
newReservedWords :: [String]
newReservedWords =
words $ "abstract concrete interface incomplete " ++
"instance out open resource reuse transfer union with where"
termInPattern :: G.Term -> G.Term
termInPattern t = M.mkAbs xx $ G.R [(s, (Nothing, toP body))] where
toP t = case t of
G.Vr x -> G.P t s
_ -> M.composSafeOp toP t
s = G.LIdent (BS.pack "s")
(xx,body) = abss [] t
abss xs t = case t of
G.Abs x b -> abss (x:xs) b
_ -> (reverse xs,t)
mkListId,mkConsId,mkBaseId :: Ident -> Ident
mkListId = prefixId (BS.pack "List")
mkConsId = prefixId (BS.pack "Cons")
mkBaseId = prefixId (BS.pack "Base")
prefixId :: BS.ByteString -> Ident -> Ident
prefixId pref id = identC (BS.append pref (ident2bs id))
Reference in New Issue View Git Blame Copy Permalink