From c985dab565416251d9973f5b3bafe4d9d205b249 Mon Sep 17 00:00:00 2001 From: aarne Date: Wed, 1 Oct 2003 12:46:44 +0000 Subject: [PATCH] Putting def definitions in place. --- src/GF/Canon/AbsGFC.hs | 1 + src/GF/Canon/CanonToGrammar.hs | 2 +- src/GF/Canon/MkGFC.hs | 20 ++++++++++++++++++-- src/GF/Canon/PrintGFC.hs | 3 ++- src/GF/Canon/SkelGFC.hs | 5 ++--- src/GF/Compile/Extend.hs | 1 + src/GF/Compile/GrammarToCanon.hs | 10 ++++++++-- src/GF/Compile/Rename.hs | 25 +++++++++++++------------ src/GF/Compile/Update.hs | 13 ++++++++++--- src/GF/Data/Str.hs | 14 ++++++++++---- src/GF/Grammar/AbsCompute.hs | 2 +- src/GF/Grammar/Grammar.hs | 5 ++--- src/GF/Source/AbsGF.hs | 15 +++++++++++---- src/GF/Source/GrammarToSource.hs | 17 ++++++++--------- src/GF/Source/LexGF.hs | 1 + src/GF/Source/PrintGF.hs | 20 +++++++++++++++++++- src/GF/Source/SkelGF.hs | 16 +++++++++++++--- src/GF/Source/SourceToGrammar.hs | 27 ++++++++++++++++++++++++++- src/GF/Source/TestGF.hs | 5 ++++- src/Today.hs | 2 +- 20 files changed, 152 insertions(+), 52 deletions(-) diff --git a/src/GF/Canon/AbsGFC.hs b/src/GF/Canon/AbsGFC.hs index 361c59d34..56adb3b4e 100644 --- a/src/GF/Canon/AbsGFC.hs +++ b/src/GF/Canon/AbsGFC.hs @@ -61,6 +61,7 @@ data Exp = | EProd Ident Exp Exp | EAbs Ident Exp | EAtom Atom + | EData | EEq [Equation] deriving (Eq,Ord,Show) diff --git a/src/GF/Canon/CanonToGrammar.hs b/src/GF/Canon/CanonToGrammar.hs index 550dc37a4..e42c273cb 100644 --- a/src/GF/Canon/CanonToGrammar.hs +++ b/src/GF/Canon/CanonToGrammar.hs @@ -47,7 +47,7 @@ redInfo (c,info) = errIn ("decompiling abstract" +++ show c) $ do c' <- redIdent c info' <- case info of AbsCat cont fs -> do - return $ G.AbsCat (Yes cont) (Yes fs) + return $ G.AbsCat (Yes cont) (Yes (map (uncurry G.Q) fs)) AbsFun typ df -> do return $ G.AbsFun (Yes typ) (Yes df) diff --git a/src/GF/Canon/MkGFC.hs b/src/GF/Canon/MkGFC.hs index d7641ca21..25feb5a47 100644 --- a/src/GF/Canon/MkGFC.hs +++ b/src/GF/Canon/MkGFC.hs @@ -67,7 +67,8 @@ trExp t = case t of EProd x a b -> A.Prod x (trExp a) (trExp b) EAbs x b -> A.Abs x (trExp b) EApp f a -> A.App (trExp f) (trExp a) - EEq _ -> A.Eqs [] ---- eqs + EEq eqs -> A.Eqs [(map trPt ps, trExp e) | Equ ps e <- eqs] + EData -> A.EData _ -> trAt t where trAt (EAtom t) = case t of @@ -78,6 +79,12 @@ trExp t = case t of AT s -> A.Sort $ prt s AS s -> A.K s AI i -> A.EInt $ fromInteger i + trPt p = case p of + APC mc ps -> let (m,c) = trQIdent mc in A.PP m c (map trPt ps) + APV x -> A.PV x + APS s -> A.PString s + API i -> A.PInt $ fromInteger i + APW -> A.PW trQIdent (CIQ m c) = (m,c) @@ -102,7 +109,8 @@ rtExp t = case t of A.Prod x a b -> EProd (rtIdent x) (rtExp a) (rtExp b) A.Abs x b -> EAbs (rtIdent x) (rtExp b) A.App f a -> EApp (rtExp f) (rtExp a) - A.Eqs _ -> EEq [] ---- eqs + A.Eqs eqs -> EEq [Equ (map rtPt ps) (rtExp e) | (ps,e) <- eqs] + A.EData -> EData _ -> EAtom $ rtAt t where rtAt t = case t of @@ -114,6 +122,14 @@ rtExp t = case t of A.K s -> AS s A.EInt i -> AI $ toInteger i _ -> error $ "MkGFC.rt not defined for" +++ show t + rtPt p = case p of + A.PP m c ps -> APC (rtQIdent (m,c)) (map rtPt ps) + A.PV x -> APV x + A.PString s -> APS s + A.PInt i -> API $ toInteger i + A.PW -> APW + _ -> error $ "MkGFC.rt not defined for" +++ show p + rtQIdent (m,c) = CIQ (rtIdent m) (rtIdent c) rtIdent x diff --git a/src/GF/Canon/PrintGFC.hs b/src/GF/Canon/PrintGFC.hs index c4f2e7d62..bc89ffd6f 100644 --- a/src/GF/Canon/PrintGFC.hs +++ b/src/GF/Canon/PrintGFC.hs @@ -163,6 +163,7 @@ instance Print Exp where EAtom atom -> prPrec i 2 (concat [prt 0 atom]) EAbs id exp -> prPrec i 0 (concat [["\\"] , prt 0 id , ["->"] , prt 0 exp]) EEq equations -> prPrec i 0 (concat [["{"] , prt 0 equations , ["}"]]) + EData -> prPrec i 2 (concat [["data"]]) instance Print Sort where prt i e = case e of @@ -185,7 +186,7 @@ instance Print APatt where APW -> prPrec i 0 (concat [["_"]]) prtList es = case es of - [x] -> (concat [prt 0 x]) + [] -> (concat []) x:xs -> (concat [prt 0 x , prt 0 xs]) instance Print Atom where diff --git a/src/GF/Canon/SkelGFC.hs b/src/GF/Canon/SkelGFC.hs index e75b66636..955cc442f 100644 --- a/src/GF/Canon/SkelGFC.hs +++ b/src/GF/Canon/SkelGFC.hs @@ -1,7 +1,5 @@ module SkelGFC where -import Ident - -- Haskell module generated by the BNF converter import AbsGFC @@ -13,7 +11,7 @@ failure x = Bad $ "Undefined case: " ++ show x transIdent :: Ident -> Result transIdent x = case x of - _ -> failure x + Ident str -> failure x transCanon :: Canon -> Result @@ -83,6 +81,7 @@ transExp x = case x of EProd id exp0 exp -> failure x EAbs id exp -> failure x EAtom atom -> failure x + EData -> failure x EEq equations -> failure x diff --git a/src/GF/Compile/Extend.hs b/src/GF/Compile/Extend.hs index 66a632445..582a1e6ae 100644 --- a/src/GF/Compile/Extend.hs +++ b/src/GF/Compile/Extend.hs @@ -35,6 +35,7 @@ indirInfo n info = AnyInd b n' where (b,n') = case info of ResValue _ -> (True,n) ResParam _ -> (True,n) + AbsFun _ (Yes EData) -> (True,n) AnyInd b k -> (b,k) _ -> (False,n) ---- canonical in Abs diff --git a/src/GF/Compile/GrammarToCanon.hs b/src/GF/Compile/GrammarToCanon.hs index d5977b510..b097405de 100644 --- a/src/GF/Compile/GrammarToCanon.hs +++ b/src/GF/Compile/GrammarToCanon.hs @@ -60,9 +60,15 @@ redInfo am (c,info) = errIn ("translating definition of" +++ prt c) $ do c' <- redIdent c case info of AbsCat (Yes cont) pfs -> do - returns c' $ C.AbsCat cont [] ---- constrs + let fs = case pfs of + Yes ts -> [(m,c) | Q m c <- ts] + _ -> [] + returns c' $ C.AbsCat cont fs AbsFun (Yes typ) pdf -> do - returns c' $ C.AbsFun typ (Eqs []) ---- df + let df = case pdf of + Yes t -> t + _ -> EData --- data vs. primitive + returns c' $ C.AbsFun typ df ResParam (Yes ps) -> do ps' <- mapM redParam ps diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs index 1e45b5fcc..eb6f6dcb9 100644 --- a/src/GF/Compile/Rename.hs +++ b/src/GF/Compile/Rename.hs @@ -101,7 +101,7 @@ renameIdentPatt env p = do info2status :: Maybe Ident -> (Ident,Info) -> (Ident,StatusInfo) info2status mq (c,i) = (c, case i of - AbsFun _ (Yes (Con g)) | g == c -> maybe Con QC mq + AbsFun _ (Yes EData) -> maybe Con QC mq ResValue _ -> maybe Con QC mq ResParam _ -> maybe Con QC mq AnyInd True m -> maybe Con (const (QC m)) mq @@ -143,7 +143,7 @@ renameInfo :: Status -> (Ident,Info) -> Err (Ident,Info) renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $ liftM ((,) i) $ case info of AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco) - (return pfs) ---- + (renPerh (mapM rent) pfs) AbsFun pty ptr -> liftM2 AbsFun (ren pty) (ren ptr) ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr) @@ -172,8 +172,7 @@ renameTerm env vars = ren vars where Con _ -> renid trm Q _ _ -> renid trm QC _ _ -> renid trm - ----- Eqs eqs -> Eqs (map (renameEquation consts vs) eqs) + Eqs eqs -> liftM Eqs $ mapM (renameEquation env vars) eqs T i cs -> do i' <- case i of TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source @@ -212,9 +211,10 @@ renamePattern env patt = case patt of c' <- renameIdentTerm env $ Cn c psvss <- mapM renp ps let (ps',vs) = unzip psvss - return $ case c' of - QC p d -> (PP p d ps', concat vs) - _ -> (PC c ps', concat vs) + case c' of + QC p d -> return (PP p d ps', concat vs) + Q p d -> return (PP p d ps', concat vs) ---- should not happen + _ -> prtBad "unresolved pattern" c' ---- (PC c ps', concat vs) ---- PP p c ps -> (PP p c ps',concat vs') where (ps',vs') = unzip $ map renp ps @@ -255,9 +255,10 @@ renameContext b = renc [] where _ -> return cont ren = renameTerm b -{- -renameEquation :: Status -> [Ident] -> Equation -> Equation -renameEquation b vs (ps,t) = (ps',renameTerm b (concat vs' ++ vs) t) where - (ps',vs') = unzip $ map (renamePattern b vs) ps --} +-- vars not needed in env, since patterns always overshadow old vars +renameEquation :: Status -> [Ident] -> Equation -> Err Equation +renameEquation b vs (ps,t) = do + (ps',vs') <- liftM unzip $ mapM (renamePattern b) ps + t' <- renameTerm b (concat vs' ++ vs) t + return (ps',t') diff --git a/src/GF/Compile/Update.hs b/src/GF/Compile/Update.hs index 9bc16f03a..4eb4849ef 100644 --- a/src/GF/Compile/Update.hs +++ b/src/GF/Compile/Update.hs @@ -36,9 +36,9 @@ combineAnyInfos = combineInfos unifyAnyInfo unifyAnyInfo :: Ident -> Info -> Info -> Err Info unifyAnyInfo c i j = errIn ("combining information for" +++ prt c) $ case (i,j) of (AbsCat mc1 mf1, AbsCat mc2 mf2) -> - liftM2 AbsCat (unifPerhaps mc1 mc2) (unifPerhaps mf1 mf2) ---- adding constrs + liftM2 AbsCat (unifPerhaps mc1 mc2) (unifConstrs mf1 mf2) -- adding constrs (AbsFun mt1 md1, AbsFun mt2 md2) -> - liftM2 AbsFun (unifPerhaps mt1 mt2) (unifAbsDefs md1 md2) ---- adding defs + liftM2 AbsFun (unifPerhaps mt1 mt2) (unifAbsDefs md1 md2) -- adding defs (ResParam mt1, ResParam mt2) -> liftM ResParam $ unifPerhaps mt1 mt2 (ResOper mt1 m1, ResOper mt2 m2) -> @@ -95,4 +95,11 @@ unifAbsDefs p1 p2 = case (p1,p2) of (Nope, _) -> return p2 (_, Nope) -> return p1 (Yes (Eqs bs), Yes (Eqs ds)) -> return $ yes $ Eqs $ bs ++ ds --- order! - _ -> Bad "update conflict" + _ -> Bad "update conflict for definitions" + +unifConstrs :: Perh [Term] -> Perh [Term] -> Err (Perh [Term]) +unifConstrs p1 p2 = case (p1,p2) of + (Nope, _) -> return p2 + (_, Nope) -> return p1 + (Yes bs, Yes ds) -> return $ yes $ bs ++ ds + _ -> Bad "update conflict for constructors" diff --git a/src/GF/Data/Str.hs b/src/GF/Data/Str.hs index 743bd71b8..0c1ecf7c9 100644 --- a/src/GF/Data/Str.hs +++ b/src/GF/Data/Str.hs @@ -16,6 +16,7 @@ newtype Str = Str [Tok] deriving (Read, Show, Eq, Ord) data Tok = TK String | TN Ss [(Ss, [String])] -- variants depending on next string +--- | TP Ss [(Ss, [String])] -- variants depending on previous string deriving (Eq, Ord, Show, Read) -- notice that having both pre and post would leave to inconsistent situations: @@ -31,14 +32,19 @@ type Ss = [String] matchPrefix :: Ss -> [(Ss,[String])] -> [String] -> Ss matchPrefix s vs t = - head ([u | (u,as) <- vs, any (\c -> isPrefixOf c (concat t)) as] ++ [s]) + head ([u | (u,as) <- vs, any (\c -> isPrefixOf c (concat t)) as] ++ [s]) + +matchSuffix :: String -> Ss -> [(Ss,[String])] -> Ss +matchSuffix t s vs = + head ([u | (u,as) <- vs, any (\c -> isSuffixOf c t) as] ++ [s]) str2strings :: Str -> Ss str2strings (Str st) = alls st where alls st = case st of - TK s : ts -> s : alls ts - TN ds vs : ts -> matchPrefix ds vs t ++ t where t = alls ts - [] -> [] + TK s : ts -> s : alls ts + TN ds vs : ts -> matchPrefix ds vs t ++ t where t = alls ts +---- u :TP ds vs: ts -> [u] ++ matchSuffix u ds vs ++ alls ts + [] -> [] str2allStrings :: Str -> [Ss] str2allStrings (Str st) = alls st where diff --git a/src/GF/Grammar/AbsCompute.hs b/src/GF/Grammar/AbsCompute.hs index 52a2ca678..daa13955e 100644 --- a/src/GF/Grammar/AbsCompute.hs +++ b/src/GF/Grammar/AbsCompute.hs @@ -47,7 +47,7 @@ computeAbsTermIn gr = compt where return $ mkAbs yy $ mkApp f aa' look (Q m f) = case lookupAbsDef gr m f of - Ok (Just (Eqs [])) -> Nothing -- canonical + Ok (Just EData) -> Nothing -- canonical --- should always be QC Ok md -> md _ -> Nothing look _ = Nothing diff --git a/src/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs index 1ee5425c4..ee018791a 100644 --- a/src/GF/Grammar/Grammar.hs +++ b/src/GF/Grammar/Grammar.hs @@ -24,7 +24,7 @@ type SourceCnc = Module Ident Option Info -- judgements in abstract syntax data Info = - AbsCat (Perh Context) (Perh [Fun]) -- constructors + AbsCat (Perh Context) (Perh [Term]) -- constructors; must be Id or QId | AbsFun (Perh Type) (Perh Term) -- Yes f = canonical | AbsTrans Ident @@ -55,6 +55,7 @@ data Term = Vr Ident -- variable | Cn Ident -- constant | Con Ident -- constructor + | EData -- to mark in definition that a fun is a constructor | Sort String -- basic type | EInt Int -- integer literal | K String -- string literal or token: "foo" @@ -68,8 +69,6 @@ data Term = -- only used in internal representation | Typed Term Term -- type-annotated term - | ECase Term [Branch] -- case expression in abstract syntax à la Alfa - -- below this only for concrete syntax | RecType [Labelling] -- record type: { p : A ; ...} | R [Assign] -- record: { p = a ; ...} diff --git a/src/GF/Source/AbsGF.hs b/src/GF/Source/AbsGF.hs index 16d342dd8..ce307ee17 100644 --- a/src/GF/Source/AbsGF.hs +++ b/src/GF/Source/AbsGF.hs @@ -2,12 +2,10 @@ module AbsGF where import Ident --H --- Haskell module generated by the BNF converter, except for --H +-- Haskell module generated by the BNF converter, except --H -- newtype Ident = Ident String deriving (Eq,Ord,Show) --H - newtype LString = LString String deriving (Eq,Ord,Show) - data Grammar = Gr [ModDef] deriving (Eq,Ord,Show) @@ -66,7 +64,7 @@ data TopDef = DefCat [CatDef] | DefFun [FunDef] | DefDef [Def] - | DefData [ParDef] + | DefData [DataDef] | DefTrans [FlagDef] | DefPar [ParDef] | DefOper [Def] @@ -89,6 +87,15 @@ data FunDef = FunDef [Ident] Exp deriving (Eq,Ord,Show) +data DataDef = + DataDef Ident [DataConstr] + deriving (Eq,Ord,Show) + +data DataConstr = + DataId Ident + | DataQId Ident Ident + deriving (Eq,Ord,Show) + data ParDef = ParDef Ident [ParConstr] | ParDefIndir Ident Ident diff --git a/src/GF/Source/GrammarToSource.hs b/src/GF/Source/GrammarToSource.hs index 6303bcd99..a211605fc 100644 --- a/src/GF/Source/GrammarToSource.hs +++ b/src/GF/Source/GrammarToSource.hs @@ -41,8 +41,13 @@ mkTopDefs ds = ds trAnyDef :: (Ident,Info) -> [P.TopDef] trAnyDef (i,info) = let i' = tri i in case info of - AbsCat (Yes co) _ -> [P.DefCat [P.CatDef i' (map trDecl co)]] - AbsFun (Yes ty) _ -> [P.DefFun [P.FunDef [i'] (trt ty)]] + AbsCat (Yes co) pd -> [P.DefCat [P.CatDef i' (map trDecl co)]] ++ case pd of + Yes fs -> [P.DefData [P.DataDef i' [P.DataQId (tri m) (tri c) | QC m c <- fs]]] + _ -> [] + AbsFun (Yes ty) pt -> [P.DefFun [P.FunDef [i'] (trt ty)]] ++ case pt of + Yes EData -> [] -- keep this information in data defs only + Yes t -> [P.DefDef [P.DDef [i'] (trt t)]] + _ -> [] AbsFun (May b) _ -> [P.DefFun [P.FunDef [i'] (P.EIndir (tri b))]] ---- don't destroy definitions! @@ -85,8 +90,6 @@ trt trm = case trm of Vr s -> P.EIdent $ tri s Cn s -> P.ECons $ tri s Con s -> P.EConstr $ tri s ----- ConAt id typ -> P.EConAt (tri id) (trt typ) - Sort s -> P.ESort $ case s of "Type" -> P.Sort_Type "PType" -> P.Sort_PType @@ -95,13 +98,9 @@ trt trm = case trm of "Strs" -> P.Sort_Strs _ -> error $ "not yet sort " +++ show trm ---- - App c a -> P.EApp (trt c) (trt a) Abs x b -> P.EAbstr [trb x] (trt b) - ----- Eqs pts -> "fn" +++ prCurlyList [prtBranchOld pst | pst <- pts] --- ----- ECase e bs -> "case" +++ prt e +++ "of" +++ prCurlyList (map prtBranch bs) - + Eqs pts -> P.EEqs [P.Equ (map trp ps) (trt t) | (ps,t) <- pts] Meta m -> P.EMeta Prod x a b | isWildIdent x -> P.EProd (P.DExp (trt a)) (trt b) Prod x a b -> P.EProd (P.DDec [trb x] (trt a)) (trt b) diff --git a/src/GF/Source/LexGF.hs b/src/GF/Source/LexGF.hs index e9406dd78..d7ab78725 100644 --- a/src/GF/Source/LexGF.hs +++ b/src/GF/Source/LexGF.hs @@ -1,3 +1,4 @@ + module LexGF where import Alex diff --git a/src/GF/Source/PrintGF.hs b/src/GF/Source/PrintGF.hs index 9d71dfe6e..fbb5afafa 100644 --- a/src/GF/Source/PrintGF.hs +++ b/src/GF/Source/PrintGF.hs @@ -165,7 +165,7 @@ instance Print TopDef where DefCat catdefs -> prPrec i 0 (concat [["cat"] , prt 0 catdefs]) DefFun fundefs -> prPrec i 0 (concat [["fun"] , prt 0 fundefs]) DefDef defs -> prPrec i 0 (concat [["def"] , prt 0 defs]) - DefData pardefs -> prPrec i 0 (concat [["data"] , prt 0 pardefs]) + DefData datadefs -> prPrec i 0 (concat [["data"] , prt 0 datadefs]) DefTrans flagdefs -> prPrec i 0 (concat [["transfer"] , prt 0 flagdefs]) DefPar pardefs -> prPrec i 0 (concat [["param"] , prt 0 pardefs]) DefOper defs -> prPrec i 0 (concat [["oper"] , prt 0 defs]) @@ -199,6 +199,24 @@ instance Print FunDef where [x] -> (concat [prt 0 x , [";"]]) x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) +instance Print DataDef where + prt i e = case e of + DataDef id dataconstrs -> prPrec i 0 (concat [prt 0 id , ["="] , prt 0 dataconstrs]) + + prtList es = case es of + [x] -> (concat [prt 0 x , [";"]]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print DataConstr where + prt i e = case e of + DataId id -> prPrec i 0 (concat [prt 0 id]) + DataQId id0 id -> prPrec i 0 (concat [prt 0 id0 , ["."] , prt 0 id]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , ["|"] , prt 0 xs]) + instance Print ParDef where prt i e = case e of ParDef id parconstrs -> prPrec i 0 (concat [prt 0 id , ["="] , prt 0 parconstrs]) diff --git a/src/GF/Source/SkelGF.hs b/src/GF/Source/SkelGF.hs index cf0932a87..f18b5bd7b 100644 --- a/src/GF/Source/SkelGF.hs +++ b/src/GF/Source/SkelGF.hs @@ -3,7 +3,6 @@ module SkelGF where -- Haskell module generated by the BNF converter import AbsGF -import Ident import ErrM type Result = Err String @@ -12,7 +11,7 @@ failure x = Bad $ "Undefined case: " ++ show x transIdent :: Ident -> Result transIdent x = case x of - _ -> failure x + Ident str -> failure x transLString :: LString -> Result @@ -88,7 +87,7 @@ transTopDef x = case x of DefCat catdefs -> failure x DefFun fundefs -> failure x DefDef defs -> failure x - DefData pardefs -> failure x + DefData datadefs -> failure x DefTrans flagdefs -> failure x DefPar pardefs -> failure x DefOper defs -> failure x @@ -113,6 +112,17 @@ transFunDef x = case x of FunDef ids exp -> failure x +transDataDef :: DataDef -> Result +transDataDef x = case x of + DataDef id dataconstrs -> failure x + + +transDataConstr :: DataConstr -> Result +transDataConstr x = case x of + DataId id -> failure x + DataQId id0 id -> failure x + + transParDef :: ParDef -> Result transParDef x = case x of ParDef id parconstrs -> failure x diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs index f9e098e08..b6c3f3a44 100644 --- a/src/GF/Source/SourceToGrammar.hs +++ b/src/GF/Source/SourceToGrammar.hs @@ -144,13 +144,24 @@ transAbsDef x = case x of DefDef defs -> do defs' <- liftM concat $ mapM getDefsGen defs returnl [(c, G.AbsFun nope pe) | (c,(_,pe)) <- defs'] - DefData _ -> returnl [] ---- + DefData ds -> do + ds' <- mapM transDataDef ds + returnl $ + [(c, G.AbsCat nope (yes ps)) | (c,ps) <- ds'] ++ + [(f, G.AbsFun nope (yes G.EData)) | (_,fs) <- ds', tf <- fs, f <- funs tf] DefTrans defs -> do let (ids,vals) = unzip [(i,v) | FlagDef i v <- defs] defs' <- liftM2 zip (mapM transIdent ids) (mapM transIdent vals) returnl [(c, G.AbsTrans f) | (c,f) <- defs'] DefFlag defs -> liftM Right $ 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 @@ -168,6 +179,14 @@ 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, G.Info)] [GO.Option]) transResDef x = case x of DefPar pardefs -> do @@ -327,6 +346,8 @@ transExp x = case x of ELString (LString str) -> return $ G.K str ELin id -> liftM G.LiT $ transIdent id + EEqs eqs -> liftM G.Eqs $ mapM transEquation eqs + _ -> Bad $ "translation not yet defined for" +++ printTree x ---- --- this is complicated: should we change Exp or G.Term ? @@ -421,6 +442,10 @@ transCase (Case pattalts exp) = do exp' <- transExp exp return [(p,exp') | p <- patts] +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) diff --git a/src/GF/Source/TestGF.hs b/src/GF/Source/TestGF.hs index f1c8e49a1..89700bda6 100644 --- a/src/GF/Source/TestGF.hs +++ b/src/GF/Source/TestGF.hs @@ -6,15 +6,18 @@ import ParGF import SkelGF import PrintGF import AbsGF + import ErrM type ParseFun a = [Token] -> Err a +myLLexer = myLexer + runFile :: (Print a, Show a) => ParseFun a -> FilePath -> IO() runFile p f = readFile f >>= run p run :: (Print a, Show a) => ParseFun a -> String -> IO() -run p s = case (p (myLexer s)) of +run p s = case (p (myLLexer s)) of Bad s -> do putStrLn "\nParse Failed...\n" putStrLn s Ok tree -> do putStrLn "\nParse Successful!" diff --git a/src/Today.hs b/src/Today.hs index 8ac2a112b..81d5b4dba 100644 --- a/src/Today.hs +++ b/src/Today.hs @@ -1 +1 @@ -module Today where today = "Thu Sep 25 14:49:28 CEST 2003" +module Today where today = "Wed Oct 1 15:37:15 CEST 2003"