From a7b68870508b90ab1a9e635489ff4e687713d166 Mon Sep 17 00:00:00 2001 From: aarne Date: Tue, 4 Dec 2007 07:48:37 +0000 Subject: moved some modules to Devel.Grammar --- src/GF/Devel/Grammar/Judgements.hs | 21 +++++ src/GF/Devel/Grammar/Lookup.hs | 73 ++++++++++++++ src/GF/Devel/Grammar/Macros.hs | 178 +++++++++++++++++++++++++++++++++++ src/GF/Devel/Grammar/MkJudgements.hs | 75 +++++++++++++++ src/GF/Devel/Grammar/Modules.hs | 49 ++++++++++ src/GF/Devel/Grammar/SourceToGF.hs | 10 +- src/GF/Devel/Grammar/Terms.hs | 116 +++++++++++++++++++++++ src/GF/Devel/Judgements.hs | 21 ----- src/GF/Devel/Lookup.hs | 73 -------------- src/GF/Devel/Macros.hs | 178 ----------------------------------- src/GF/Devel/MkJudgements.hs | 75 --------------- src/GF/Devel/Modules.hs | 49 ---------- src/GF/Devel/Terms.hs | 117 ----------------------- 13 files changed, 517 insertions(+), 518 deletions(-) create mode 100644 src/GF/Devel/Grammar/Judgements.hs create mode 100644 src/GF/Devel/Grammar/Lookup.hs create mode 100644 src/GF/Devel/Grammar/Macros.hs create mode 100644 src/GF/Devel/Grammar/MkJudgements.hs create mode 100644 src/GF/Devel/Grammar/Modules.hs create mode 100644 src/GF/Devel/Grammar/Terms.hs delete mode 100644 src/GF/Devel/Judgements.hs delete mode 100644 src/GF/Devel/Lookup.hs delete mode 100644 src/GF/Devel/Macros.hs delete mode 100644 src/GF/Devel/MkJudgements.hs delete mode 100644 src/GF/Devel/Modules.hs delete mode 100644 src/GF/Devel/Terms.hs (limited to 'src') diff --git a/src/GF/Devel/Grammar/Judgements.hs b/src/GF/Devel/Grammar/Judgements.hs new file mode 100644 index 000000000..b09576e50 --- /dev/null +++ b/src/GF/Devel/Grammar/Judgements.hs @@ -0,0 +1,21 @@ +module GF.Devel.Grammar.Judgements where + +import GF.Devel.Grammar.Terms +import GF.Infra.Ident + +data Judgement = Judgement { + jform :: JudgementForm, -- cat fun lincat lin oper param + jtype :: Type, -- context type lincat - type constrs + jdef :: Term, -- lindef def lindef lin def values + jprintname :: Term -- - - prname prname - - + } + +data JudgementForm = + JCat + | JFun + | JLincat + | JLin + | JOper + | JParam + deriving Eq + diff --git a/src/GF/Devel/Grammar/Lookup.hs b/src/GF/Devel/Grammar/Lookup.hs new file mode 100644 index 000000000..9236f0222 --- /dev/null +++ b/src/GF/Devel/Grammar/Lookup.hs @@ -0,0 +1,73 @@ +module GF.Devel.Grammar.Lookup where + +import GF.Devel.Grammar.Modules +import GF.Devel.Grammar.Judgements +import GF.Devel.Grammar.Macros +import GF.Devel.Grammar.Terms +import GF.Infra.Ident + +import GF.Data.Operations + +import Data.Map + +-- look up fields for a constant in a grammar + +lookupJField :: (Judgement -> a) -> GF -> Ident -> Ident -> Err a +lookupJField field gf m c = do + j <- lookupJudgement gf m c + return $ field j + +lookupJForm :: GF -> Ident -> Ident -> Err JudgementForm +lookupJForm = lookupJField jform + +-- the following don't (need to) check that the jment form is adequate + +lookupCatContext :: GF -> Ident -> Ident -> Err Context +lookupCatContext gf m c = do + ty <- lookupJField jtype gf m c + return $ contextOfType ty + +lookupFunType :: GF -> Ident -> Ident -> Err Term +lookupFunType = lookupJField jtype + +lookupLin :: GF -> Ident -> Ident -> Err Term +lookupLin = lookupJField jdef + +lookupLincat :: GF -> Ident -> Ident -> Err Term +lookupLincat = lookupJField jtype + +lookupOperType :: GF -> Ident -> Ident -> Err Term +lookupOperType = lookupJField jtype + +lookupOperDef :: GF -> Ident -> Ident -> Err Term +lookupOperDef = lookupJField jdef + +lookupParams :: GF -> Ident -> Ident -> Err [(Ident,Context)] +lookupParams gf m c = do + ty <- lookupJField jtype gf m c + return [(k,contextOfType t) | (k,t) <- contextOfType ty] + +lookupParamConstructor :: GF -> Ident -> Ident -> Err Type +lookupParamConstructor = lookupJField jtype + +lookupParamValues :: GF -> Ident -> Ident -> Err [Term] +lookupParamValues gf m c = do + d <- lookupJField jdef gf m c + case d of + V _ ts -> return ts + _ -> raise "no parameter values" + +-- infrastructure for lookup + +lookupIdent :: GF -> Ident -> Ident -> Err (Either Judgement Ident) +lookupIdent gf m c = do + mo <- maybe (raise "module not found") return $ mlookup m (gfmodules gf) + maybe (Bad "constant not found") return $ mlookup c (mjments mo) + +lookupJudgement :: GF -> Ident -> Ident -> Err Judgement +lookupJudgement gf m c = do + eji <- lookupIdent gf m c + either return (\n -> lookupJudgement gf n c) eji + +mlookup = Data.Map.lookup + diff --git a/src/GF/Devel/Grammar/Macros.hs b/src/GF/Devel/Grammar/Macros.hs new file mode 100644 index 000000000..4848a5e1a --- /dev/null +++ b/src/GF/Devel/Grammar/Macros.hs @@ -0,0 +1,178 @@ +module GF.Devel.Grammar.Macros where + +import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Judgements +import GF.Devel.Grammar.Modules +import GF.Infra.Ident + +import GF.Data.Operations + +import Data.Map +import Control.Monad (liftM,liftM2) + +contextOfType :: Type -> Context +contextOfType ty = co where (co,_,_) = typeForm ty + +typeForm :: Type -> (Context,Term,[Term]) +typeForm t = (co,f,a) where + (co,t2) = prodForm t + (f,a) = appForm t2 + +prodForm :: Type -> (Context,Term) +prodForm t = case t of + Prod x ty val -> ((x,ty):co,t2) where (co,t2) = prodForm val + _ -> ([],t) + +appForm :: Term -> (Term,[Term]) +appForm tr = (f,reverse xs) where + (f,xs) = apps tr + apps t = case t of + App f a -> (f2,a:a2) where (f2,a2) = appForm f + _ -> (t,[]) + +mkProd :: Context -> Type -> Type +mkProd = flip (foldr (uncurry Prod)) + +mkApp :: Term -> [Term] -> Term +mkApp = foldl App + +mkAbs :: [Ident] -> Term -> Term +mkAbs xs t = foldr Abs t xs + +mkDecl :: Term -> Decl +mkDecl typ = (wildIdent, typ) + +typeType :: Type +typeType = Sort "Type" + +ident2label :: Ident -> Label +ident2label c = LIdent (prIdent c) + +----label2ident :: Label -> Ident +----label2ident = identC . prLabel + +-- to apply a term operation to every term in a judgement, module, grammar + +termOpGF :: Monad m => (Term -> m Term) -> GF -> m GF +termOpGF f g = do + ms <- mapMapM fm (gfmodules g) + return g {gfmodules = ms} + where + fm = termOpModule f + +termOpModule :: Monad m => (Term -> m Term) -> Module -> m Module +termOpModule f m = do + mjs <- mapMapM fj (mjments m) + return m {mjments = mjs} + where + fj = either (liftM Left . termOpJudgement f) (return . Right) + +termOpJudgement :: Monad m => (Term -> m Term) -> Judgement -> m Judgement +termOpJudgement f j = do + jtyp <- f (jtype j) + jde <- f (jdef j) + jpri <- f (jprintname j) + return $ j { + jtype = jtyp, + jdef = jde, + jprintname = jpri + } + +-- | to define compositional term functions +composSafeOp :: (Term -> Term) -> Term -> Term +composSafeOp op trm = case composOp (mkMonadic op) trm of + Ok t -> t + _ -> error "the operation is safe isn't it ?" + where + mkMonadic f = return . f + +-- | to define compositional monadic term functions +composOp :: Monad m => (Term -> m Term) -> Term -> m Term +composOp co trm = case trm of + App c a -> + do c' <- co c + a' <- co a + return (App c' a') + Abs x b -> + do b' <- co b + return (Abs x b') + Prod x a b -> + do a' <- co a + b' <- co b + return (Prod x a' b') + S c a -> + do c' <- co c + a' <- co a + return (S c' a') + Table a c -> + do a' <- co a + c' <- co c + return (Table a' c') + R r -> + do r' <- mapAssignM co r + return (R r') + RecType r -> + do r' <- mapPairListM (co . snd) r + return (RecType r') + P t i -> + do t' <- co t + return (P t' i) + PI t i j -> + do t' <- co t + return (PI t' i j) + ExtR a c -> + do a' <- co a + c' <- co c + return (ExtR a' c') + T i cc -> + do cc' <- mapPairListM (co . snd) cc + i' <- changeTableType co i + return (T i' cc') + Eqs cc -> + do cc' <- mapPairListM (co . snd) cc + return (Eqs cc') + V ty vs -> + do ty' <- co ty + vs' <- mapM co vs + return (V ty' vs') + Let (x,(mt,a)) b -> + do a' <- co a + mt' <- case mt of + Just t -> co t >>= (return . Just) + _ -> return mt + b' <- co b + return (Let (x,(mt',a')) b') + C s1 s2 -> + do v1 <- co s1 + v2 <- co s2 + return (C v1 v2) + Glue s1 s2 -> + do v1 <- co s1 + v2 <- co s2 + return (Glue v1 v2) + Alts (t,aa) -> + do t' <- co t + aa' <- mapM (pairM co) aa + return (Alts (t',aa')) + FV ts -> mapM co ts >>= return . FV + _ -> return trm -- covers K, Vr, Cn, Sort + +--- just aux to composOp? + +mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))] +mapAssignM f = mapM (\ (ls,tv) -> liftM ((,) ls) (g tv)) + where g (t,v) = liftM2 (,) (maybe (return Nothing) (liftM Just . f) t) (f v) + +changeTableType :: Monad m => (Type -> m Type) -> TInfo -> m TInfo +changeTableType co i = case i of + TTyped ty -> co ty >>= return . TTyped + TComp ty -> co ty >>= return . TComp + TWild ty -> co ty >>= return . TWild + _ -> return i + +---- given in lib? + +mapMapM :: (Monad m, Ord k) => (v -> m v) -> Map k v -> m (Map k v) +mapMapM f = + liftM fromAscList . mapM (\ (x,y) -> liftM ((,) x) $ f y) . assocs + diff --git a/src/GF/Devel/Grammar/MkJudgements.hs b/src/GF/Devel/Grammar/MkJudgements.hs new file mode 100644 index 000000000..795bf6f67 --- /dev/null +++ b/src/GF/Devel/Grammar/MkJudgements.hs @@ -0,0 +1,75 @@ +module GF.Devel.Grammar.MkJudgements where + +import GF.Devel.Grammar.Macros +import GF.Devel.Grammar.Judgements +import GF.Devel.Grammar.Terms +import GF.Infra.Ident + +import GF.Data.Operations + +import Control.Monad +import Data.Map + +-- constructing judgements from parse tree + +emptyJudgement :: JudgementForm -> Judgement +emptyJudgement form = Judgement form meta meta meta where + meta = Meta 0 + +addJType :: Type -> Judgement -> Judgement +addJType tr ju = ju {jtype = tr} + +addJDef :: Term -> Judgement -> Judgement +addJDef tr ju = ju {jdef = tr} + +addJPrintname :: Term -> Judgement -> Judgement +addJPrintname tr ju = ju {jprintname = tr} + + +absCat :: Context -> Judgement +absCat co = addJType (mkProd co typeType) (emptyJudgement JCat) + +absFun :: Type -> Judgement +absFun ty = addJType ty (emptyJudgement JFun) + +cncCat :: Type -> Judgement +cncCat ty = addJType ty (emptyJudgement JLincat) + +cncFun :: Term -> Judgement +cncFun tr = addJDef tr (emptyJudgement JLin) + +resOperType :: Type -> Judgement +resOperType ty = addJType ty (emptyJudgement JOper) + +resOperDef :: Term -> Judgement +resOperDef tr = addJDef tr (emptyJudgement JOper) + +resOper :: Type -> Term -> Judgement +resOper ty tr = addJDef tr (resOperType ty) + +-- param m.p = c g is encoded as p : (ci : gi -> EData) -> Type +-- we use EData instead of m.p to make circularity check easier +resParam :: Ident -> Ident -> [(Ident,Context)] -> Judgement +resParam m p cos = addJType constrs (emptyJudgement JParam) where + constrs = mkProd [(c,mkProd co EData) | (c,co) <- cos] typeType + +-- to enable constructor type lookup: +-- create an oper for each constructor m.p = c g, as c : g -> m.p = EData +paramConstructors :: Ident -> Ident -> [(Ident,Context)] -> [(Ident,Judgement)] +paramConstructors m p cs = + [(c,resOper (mkProd co (QC m p)) EData) | (c,co) <- cs] + +-- unifying contents of judgements + +unifyJudgement :: Judgement -> Judgement -> Err Judgement +unifyJudgement old new = do + testErr (jform old == jform new) "different judment forms" + [jty,jde,jpri] <- mapM unifyField [jtype,jdef,jprintname] + return $ old{jtype = jty, jdef = jde, jprintname = jpri} + where + unifyField field = unifyTerm (field old) (field new) + unifyTerm oterm nterm = case (oterm,nterm) of + (Meta _,t) -> return t + (t,Meta _) -> return t + _ -> testErr (nterm == oterm) "incompatible fields" >> return nterm + diff --git a/src/GF/Devel/Grammar/Modules.hs b/src/GF/Devel/Grammar/Modules.hs new file mode 100644 index 000000000..774cc6387 --- /dev/null +++ b/src/GF/Devel/Grammar/Modules.hs @@ -0,0 +1,49 @@ +module GF.Devel.Grammar.Modules where + +import GF.Devel.Grammar.Judgements +import GF.Devel.Grammar.Terms +import GF.Infra.Ident + +import GF.Data.Operations + +import Control.Monad +import Data.Map + + +data GF = GF { + gfabsname :: Maybe Ident , + gfcncnames :: [Ident] , + gflags :: Map Ident String , -- value of a global flag + gfmodules :: Map Ident Module + } + +emptyGF :: GF +emptyGF = GF Nothing [] empty empty + +data Module = Module { + mtype :: ModuleType, + minterfaces :: [(Ident,Ident)], -- non-empty for functors + minstances :: [((Ident,MInclude),[(Ident,Ident)])], -- non-empty for instant'ions + mextends :: [(Ident,MInclude)], + mopens :: [(Ident,Ident)], -- used name, original name + mflags :: Map Ident String, + mjments :: Map Ident (Either Judgement Ident) -- def or indirection + } + +emptyModule :: Ident -> Module +emptyModule m = Module MTGrammar [] [] [] [] empty empty + +listJudgements :: Module -> [(Ident,Either Judgement Ident)] +listJudgements = assocs . mjments + +data ModuleType = + MTAbstract + | MTConcrete Ident + | MTGrammar + +data MInclude = + MIAll + | MIExcept [Ident] + | MIOnly [Ident] + + diff --git a/src/GF/Devel/Grammar/SourceToGF.hs b/src/GF/Devel/Grammar/SourceToGF.hs index 496202e80..d40026851 100644 --- a/src/GF/Devel/Grammar/SourceToGF.hs +++ b/src/GF/Devel/Grammar/SourceToGF.hs @@ -21,12 +21,12 @@ module GF.Devel.Grammar.SourceToGF ( newReservedWords ) where -import qualified GF.Devel.Terms as G +import qualified GF.Devel.Grammar.Terms as G ----import qualified GF.Grammar.PrGrammar as GP -import GF.Devel.Judgements -import GF.Devel.MkJudgements -import GF.Devel.Modules -import qualified GF.Devel.Macros as M +import GF.Devel.Grammar.Judgements +import GF.Devel.Grammar.MkJudgements +import GF.Devel.Grammar.Modules +import qualified GF.Devel.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 diff --git a/src/GF/Devel/Grammar/Terms.hs b/src/GF/Devel/Grammar/Terms.hs new file mode 100644 index 000000000..bfbdff7d0 --- /dev/null +++ b/src/GF/Devel/Grammar/Terms.hs @@ -0,0 +1,116 @@ +module GF.Devel.Grammar.Terms where + +import GF.Infra.Ident + +import GF.Data.Operations + +type Type = Term +type Cat = QIdent +type Fun = QIdent + +type QIdent = (Ident,Ident) + +data Term = + Vr Ident -- ^ variable + | Con Ident -- ^ constructor + | EData -- ^ to mark in definition that a fun is a constructor + | Sort String -- ^ predefined type + | EInt Integer -- ^ integer literal + | EFloat Double -- ^ floating point literal + | K String -- ^ string literal or token: @\"foo\"@ + | Empty -- ^ the empty string @[]@ + + | App Term Term -- ^ application: @f a@ + | Abs Ident Term -- ^ abstraction: @\x -> b@ + | Meta MetaSymb -- ^ metavariable: @?i@ (only parsable: ? = ?0) + | Prod Ident Term Term -- ^ function type: @(x : A) -> B@ + | Eqs [Equation] -- ^ abstraction by cases: @fn {x y -> b ; z u -> c}@ + -- only used in internal representation + | Typed Term Term -- ^ type-annotated term +-- +-- /below this, the constructors are only for concrete syntax/ + | Example Term String -- ^ example-based term: @in M.C "foo" + | RecType [Labelling] -- ^ record type: @{ p : A ; ...}@ + | R [Assign] -- ^ record: @{ p = a ; ...}@ + | P Term Label -- ^ projection: @r.p@ + | PI Term Label Int -- ^ index-annotated projection + | ExtR Term Term -- ^ extension: @R ** {x : A}@ (both types and terms) + + | Table Term Term -- ^ table type: @P => A@ + | T TInfo [Case] -- ^ table: @table {p => c ; ...}@ + | V Type [Term] -- ^ course of values: @table T [c1 ; ... ; cn]@ + | S Term Term -- ^ selection: @t ! p@ + | Val Type Int -- ^ parameter value number: @T # i# + + | Let LocalDef Term -- ^ local definition: @let {t : T = a} in b@ + + | Q Ident Ident -- ^ qualified constant from a module + | QC Ident Ident -- ^ qualified constructor from a module + + | C Term Term -- ^ concatenation: @s ++ t@ + | Glue Term Term -- ^ agglutination: @s + t@ + + | FV [Term] -- ^ free variation: @variants { s ; ... }@ + + | Alts (Term, [(Term, Term)]) -- ^ prefix-dependent: @pre {t ; s\/c ; ...}@ + + deriving (Read, Show, Eq, Ord) + +data Patt = + PC Ident [Patt] -- ^ constructor pattern: @C p1 ... pn@ @C@ + | PP Ident Ident [Patt] -- ^ qualified constr patt: @P.C p1 ... pn@ @P.C@ + | PV Ident -- ^ variable pattern: @x@ + | PW -- ^ wild card pattern: @_@ + | PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@ + | PString String -- ^ string literal pattern: @\"foo\"@ + | PInt Integer -- ^ integer literal pattern: @12@ + | PFloat Double -- ^ float literal pattern: @1.2@ + | PT Type Patt -- ^ type-annotated pattern + | PAs Ident Patt -- ^ as-pattern: x@p + + -- regular expression patterns + | PNeg Patt -- ^ negated pattern: -p + | PAlt Patt Patt -- ^ disjunctive pattern: p1 | p2 + | PSeq Patt Patt -- ^ sequence of token parts: p + q + | PRep Patt -- ^ repetition of token part: p* + + deriving (Read, Show, Eq, Ord) + +-- | to guide computation and type checking of tables +data TInfo = + TRaw -- ^ received from parser; can be anything + | TTyped Type -- ^ type annotated, but can be anything + | TComp Type -- ^ expanded + | TWild Type -- ^ just one wild card pattern, no need to expand + deriving (Read, Show, Eq, Ord) + +-- | record label +data Label = + LIdent String + | LVar Int + deriving (Read, Show, Eq, Ord) + +type MetaSymb = Int + +type Decl = (Ident,Term) -- (x:A) (_:A) A +type Context = [Decl] -- (x:A)(y:B) (x,y:A) (_,_:A) +type Substitution = [(Ident, Term)] +type Equation = ([Patt],Term) + +type Labelling = (Label, Term) +type Assign = (Label, (Maybe Type, Term)) +type Case = (Patt, Term) +type LocalDef = (Ident, (Maybe Type, Term)) + + +-- | branches à la Alfa +newtype Branch = Branch (Con,([Ident],Term)) deriving (Eq, Ord,Show,Read) +type Con = Ident --- + +varLabel :: Int -> Label +varLabel = LVar + +wildPatt :: Patt +wildPatt = PW + +type Trm = Term diff --git a/src/GF/Devel/Judgements.hs b/src/GF/Devel/Judgements.hs deleted file mode 100644 index 7be565bf0..000000000 --- a/src/GF/Devel/Judgements.hs +++ /dev/null @@ -1,21 +0,0 @@ -module GF.Devel.Judgements where - -import GF.Devel.Terms -import GF.Infra.Ident - -data Judgement = Judgement { - jform :: JudgementForm, -- cat fun lincat lin oper param - jtype :: Type, -- context type lincat - type constrs - jdef :: Term, -- lindef def lindef lin def values - jprintname :: Term -- - - prname prname - - - } - -data JudgementForm = - JCat - | JFun - | JLincat - | JLin - | JOper - | JParam - deriving Eq - diff --git a/src/GF/Devel/Lookup.hs b/src/GF/Devel/Lookup.hs deleted file mode 100644 index 741c65472..000000000 --- a/src/GF/Devel/Lookup.hs +++ /dev/null @@ -1,73 +0,0 @@ -module GF.Devel.Lookup where - -import GF.Devel.Modules -import GF.Devel.Judgements -import GF.Devel.Macros -import GF.Devel.Terms -import GF.Infra.Ident - -import GF.Data.Operations - -import Data.Map - --- look up fields for a constant in a grammar - -lookupJField :: (Judgement -> a) -> GF -> Ident -> Ident -> Err a -lookupJField field gf m c = do - j <- lookupJudgement gf m c - return $ field j - -lookupJForm :: GF -> Ident -> Ident -> Err JudgementForm -lookupJForm = lookupJField jform - --- the following don't (need to) check that the jment form is adequate - -lookupCatContext :: GF -> Ident -> Ident -> Err Context -lookupCatContext gf m c = do - ty <- lookupJField jtype gf m c - return $ contextOfType ty - -lookupFunType :: GF -> Ident -> Ident -> Err Term -lookupFunType = lookupJField jtype - -lookupLin :: GF -> Ident -> Ident -> Err Term -lookupLin = lookupJField jdef - -lookupLincat :: GF -> Ident -> Ident -> Err Term -lookupLincat = lookupJField jtype - -lookupOperType :: GF -> Ident -> Ident -> Err Term -lookupOperType = lookupJField jtype - -lookupOperDef :: GF -> Ident -> Ident -> Err Term -lookupOperDef = lookupJField jdef - -lookupParams :: GF -> Ident -> Ident -> Err [(Ident,Context)] -lookupParams gf m c = do - ty <- lookupJField jtype gf m c - return [(k,contextOfType t) | (k,t) <- contextOfType ty] - -lookupParamConstructor :: GF -> Ident -> Ident -> Err Type -lookupParamConstructor = lookupJField jtype - -lookupParamValues :: GF -> Ident -> Ident -> Err [Term] -lookupParamValues gf m c = do - d <- lookupJField jdef gf m c - case d of - V _ ts -> return ts - _ -> raise "no parameter values" - --- infrastructure for lookup - -lookupIdent :: GF -> Ident -> Ident -> Err (Either Judgement Ident) -lookupIdent gf m c = do - mo <- maybe (raise "module not found") return $ mlookup m (gfmodules gf) - maybe (Bad "constant not found") return $ mlookup c (mjments mo) - -lookupJudgement :: GF -> Ident -> Ident -> Err Judgement -lookupJudgement gf m c = do - eji <- lookupIdent gf m c - either return (\n -> lookupJudgement gf n c) eji - -mlookup = Data.Map.lookup - diff --git a/src/GF/Devel/Macros.hs b/src/GF/Devel/Macros.hs deleted file mode 100644 index afaf71c52..000000000 --- a/src/GF/Devel/Macros.hs +++ /dev/null @@ -1,178 +0,0 @@ -module GF.Devel.Macros where - -import GF.Devel.Terms -import GF.Devel.Judgements -import GF.Devel.Modules -import GF.Infra.Ident - -import GF.Data.Operations - -import Data.Map -import Control.Monad (liftM,liftM2) - -contextOfType :: Type -> Context -contextOfType ty = co where (co,_,_) = typeForm ty - -typeForm :: Type -> (Context,Term,[Term]) -typeForm t = (co,f,a) where - (co,t2) = prodForm t - (f,a) = appForm t2 - -prodForm :: Type -> (Context,Term) -prodForm t = case t of - Prod x ty val -> ((x,ty):co,t2) where (co,t2) = prodForm val - _ -> ([],t) - -appForm :: Term -> (Term,[Term]) -appForm tr = (f,reverse xs) where - (f,xs) = apps tr - apps t = case t of - App f a -> (f2,a:a2) where (f2,a2) = appForm f - _ -> (t,[]) - -mkProd :: Context -> Type -> Type -mkProd = flip (foldr (uncurry Prod)) - -mkApp :: Term -> [Term] -> Term -mkApp = foldl App - -mkAbs :: [Ident] -> Term -> Term -mkAbs xs t = foldr Abs t xs - -mkDecl :: Term -> Decl -mkDecl typ = (wildIdent, typ) - -typeType :: Type -typeType = Sort "Type" - -ident2label :: Ident -> Label -ident2label c = LIdent (prIdent c) - -----label2ident :: Label -> Ident -----label2ident = identC . prLabel - --- to apply a term operation to every term in a judgement, module, grammar - -termOpGF :: Monad m => (Term -> m Term) -> GF -> m GF -termOpGF f g = do - ms <- mapMapM fm (gfmodules g) - return g {gfmodules = ms} - where - fm = termOpModule f - -termOpModule :: Monad m => (Term -> m Term) -> Module -> m Module -termOpModule f m = do - mjs <- mapMapM fj (mjments m) - return m {mjments = mjs} - where - fj = either (liftM Left . termOpJudgement f) (return . Right) - -termOpJudgement :: Monad m => (Term -> m Term) -> Judgement -> m Judgement -termOpJudgement f j = do - jtyp <- f (jtype j) - jde <- f (jdef j) - jpri <- f (jprintname j) - return $ j { - jtype = jtyp, - jdef = jde, - jprintname = jpri - } - --- | to define compositional term functions -composSafeOp :: (Term -> Term) -> Term -> Term -composSafeOp op trm = case composOp (mkMonadic op) trm of - Ok t -> t - _ -> error "the operation is safe isn't it ?" - where - mkMonadic f = return . f - --- | to define compositional monadic term functions -composOp :: Monad m => (Term -> m Term) -> Term -> m Term -composOp co trm = case trm of - App c a -> - do c' <- co c - a' <- co a - return (App c' a') - Abs x b -> - do b' <- co b - return (Abs x b') - Prod x a b -> - do a' <- co a - b' <- co b - return (Prod x a' b') - S c a -> - do c' <- co c - a' <- co a - return (S c' a') - Table a c -> - do a' <- co a - c' <- co c - return (Table a' c') - R r -> - do r' <- mapAssignM co r - return (R r') - RecType r -> - do r' <- mapPairListM (co . snd) r - return (RecType r') - P t i -> - do t' <- co t - return (P t' i) - PI t i j -> - do t' <- co t - return (PI t' i j) - ExtR a c -> - do a' <- co a - c' <- co c - return (ExtR a' c') - T i cc -> - do cc' <- mapPairListM (co . snd) cc - i' <- changeTableType co i - return (T i' cc') - Eqs cc -> - do cc' <- mapPairListM (co . snd) cc - return (Eqs cc') - V ty vs -> - do ty' <- co ty - vs' <- mapM co vs - return (V ty' vs') - Let (x,(mt,a)) b -> - do a' <- co a - mt' <- case mt of - Just t -> co t >>= (return . Just) - _ -> return mt - b' <- co b - return (Let (x,(mt',a')) b') - C s1 s2 -> - do v1 <- co s1 - v2 <- co s2 - return (C v1 v2) - Glue s1 s2 -> - do v1 <- co s1 - v2 <- co s2 - return (Glue v1 v2) - Alts (t,aa) -> - do t' <- co t - aa' <- mapM (pairM co) aa - return (Alts (t',aa')) - FV ts -> mapM co ts >>= return . FV - _ -> return trm -- covers K, Vr, Cn, Sort - ---- just aux to composOp? - -mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))] -mapAssignM f = mapM (\ (ls,tv) -> liftM ((,) ls) (g tv)) - where g (t,v) = liftM2 (,) (maybe (return Nothing) (liftM Just . f) t) (f v) - -changeTableType :: Monad m => (Type -> m Type) -> TInfo -> m TInfo -changeTableType co i = case i of - TTyped ty -> co ty >>= return . TTyped - TComp ty -> co ty >>= return . TComp - TWild ty -> co ty >>= return . TWild - _ -> return i - ----- given in lib? - -mapMapM :: (Monad m, Ord k) => (v -> m v) -> Map k v -> m (Map k v) -mapMapM f = - liftM fromAscList . mapM (\ (x,y) -> liftM ((,) x) $ f y) . assocs - diff --git a/src/GF/Devel/MkJudgements.hs b/src/GF/Devel/MkJudgements.hs deleted file mode 100644 index dbe57b0f1..000000000 --- a/src/GF/Devel/MkJudgements.hs +++ /dev/null @@ -1,75 +0,0 @@ -module GF.Devel.MkJudgements where - -import GF.Devel.Macros -import GF.Devel.Judgements -import GF.Devel.Terms -import GF.Infra.Ident - -import GF.Data.Operations - -import Control.Monad -import Data.Map - --- constructing judgements from parse tree - -emptyJudgement :: JudgementForm -> Judgement -emptyJudgement form = Judgement form meta meta meta where - meta = Meta 0 - -addJType :: Type -> Judgement -> Judgement -addJType tr ju = ju {jtype = tr} - -addJDef :: Term -> Judgement -> Judgement -addJDef tr ju = ju {jdef = tr} - -addJPrintname :: Term -> Judgement -> Judgement -addJPrintname tr ju = ju {jprintname = tr} - - -absCat :: Context -> Judgement -absCat co = addJType (mkProd co typeType) (emptyJudgement JCat) - -absFun :: Type -> Judgement -absFun ty = addJType ty (emptyJudgement JFun) - -cncCat :: Type -> Judgement -cncCat ty = addJType ty (emptyJudgement JLincat) - -cncFun :: Term -> Judgement -cncFun tr = addJDef tr (emptyJudgement JLin) - -resOperType :: Type -> Judgement -resOperType ty = addJType ty (emptyJudgement JOper) - -resOperDef :: Term -> Judgement -resOperDef tr = addJDef tr (emptyJudgement JOper) - -resOper :: Type -> Term -> Judgement -resOper ty tr = addJDef tr (resOperType ty) - --- param m.p = c g is encoded as p : (ci : gi -> EData) -> Type --- we use EData instead of m.p to make circularity check easier -resParam :: Ident -> Ident -> [(Ident,Context)] -> Judgement -resParam m p cos = addJType constrs (emptyJudgement JParam) where - constrs = mkProd [(c,mkProd co EData) | (c,co) <- cos] typeType - --- to enable constructor type lookup: --- create an oper for each constructor m.p = c g, as c : g -> m.p = EData -paramConstructors :: Ident -> Ident -> [(Ident,Context)] -> [(Ident,Judgement)] -paramConstructors m p cs = - [(c,resOper (mkProd co (QC m p)) EData) | (c,co) <- cs] - --- unifying contents of judgements - -unifyJudgement :: Judgement -> Judgement -> Err Judgement -unifyJudgement old new = do - testErr (jform old == jform new) "different judment forms" - [jty,jde,jpri] <- mapM unifyField [jtype,jdef,jprintname] - return $ old{jtype = jty, jdef = jde, jprintname = jpri} - where - unifyField field = unifyTerm (field old) (field new) - unifyTerm oterm nterm = case (oterm,nterm) of - (Meta _,t) -> return t - (t,Meta _) -> return t - _ -> testErr (nterm == oterm) "incompatible fields" >> return nterm - diff --git a/src/GF/Devel/Modules.hs b/src/GF/Devel/Modules.hs deleted file mode 100644 index 112cca221..000000000 --- a/src/GF/Devel/Modules.hs +++ /dev/null @@ -1,49 +0,0 @@ -module GF.Devel.Modules where - -import GF.Devel.Judgements -import GF.Devel.Terms -import GF.Infra.Ident - -import GF.Data.Operations - -import Control.Monad -import Data.Map - - -data GF = GF { - gfabsname :: Maybe Ident , - gfcncnames :: [Ident] , - gflags :: Map Ident String , -- value of a global flag - gfmodules :: Map Ident Module - } - -emptyGF :: GF -emptyGF = GF Nothing [] empty empty - -data Module = Module { - mtype :: ModuleType, - minterfaces :: [(Ident,Ident)], -- non-empty for functors - minstances :: [((Ident,MInclude),[(Ident,Ident)])], -- non-empty for instant'ions - mextends :: [(Ident,MInclude)], - mopens :: [(Ident,Ident)], -- used name, original name - mflags :: Map Ident String, - mjments :: Map Ident (Either Judgement Ident) -- def or indirection - } - -emptyModule :: Ident -> Module -emptyModule m = Module MTGrammar [] [] [] [] empty empty - -listJudgements :: Module -> [(Ident,Either Judgement Ident)] -listJudgements = assocs . mjments - -data ModuleType = - MTAbstract - | MTConcrete Ident - | MTGrammar - -data MInclude = - MIAll - | MIExcept [Ident] - | MIOnly [Ident] - - diff --git a/src/GF/Devel/Terms.hs b/src/GF/Devel/Terms.hs deleted file mode 100644 index c2a6022c7..000000000 --- a/src/GF/Devel/Terms.hs +++ /dev/null @@ -1,117 +0,0 @@ -module GF.Devel.Terms where - -import GF.Infra.Ident -import GF.Infra.Modules - -import GF.Data.Operations - -type Type = Term -type Cat = QIdent -type Fun = QIdent - -type QIdent = (Ident,Ident) - -data Term = - Vr Ident -- ^ variable - | Con Ident -- ^ constructor - | EData -- ^ to mark in definition that a fun is a constructor - | Sort String -- ^ predefined type - | EInt Integer -- ^ integer literal - | EFloat Double -- ^ floating point literal - | K String -- ^ string literal or token: @\"foo\"@ - | Empty -- ^ the empty string @[]@ - - | App Term Term -- ^ application: @f a@ - | Abs Ident Term -- ^ abstraction: @\x -> b@ - | Meta MetaSymb -- ^ metavariable: @?i@ (only parsable: ? = ?0) - | Prod Ident Term Term -- ^ function type: @(x : A) -> B@ - | Eqs [Equation] -- ^ abstraction by cases: @fn {x y -> b ; z u -> c}@ - -- only used in internal representation - | Typed Term Term -- ^ type-annotated term --- --- /below this, the constructors are only for concrete syntax/ - | Example Term String -- ^ example-based term: @in M.C "foo" - | RecType [Labelling] -- ^ record type: @{ p : A ; ...}@ - | R [Assign] -- ^ record: @{ p = a ; ...}@ - | P Term Label -- ^ projection: @r.p@ - | PI Term Label Int -- ^ index-annotated projection - | ExtR Term Term -- ^ extension: @R ** {x : A}@ (both types and terms) - - | Table Term Term -- ^ table type: @P => A@ - | T TInfo [Case] -- ^ table: @table {p => c ; ...}@ - | V Type [Term] -- ^ course of values: @table T [c1 ; ... ; cn]@ - | S Term Term -- ^ selection: @t ! p@ - | Val Type Int -- ^ parameter value number: @T # i# - - | Let LocalDef Term -- ^ local definition: @let {t : T = a} in b@ - - | Q Ident Ident -- ^ qualified constant from a module - | QC Ident Ident -- ^ qualified constructor from a module - - | C Term Term -- ^ concatenation: @s ++ t@ - | Glue Term Term -- ^ agglutination: @s + t@ - - | FV [Term] -- ^ free variation: @variants { s ; ... }@ - - | Alts (Term, [(Term, Term)]) -- ^ prefix-dependent: @pre {t ; s\/c ; ...}@ - - deriving (Read, Show, Eq, Ord) - -data Patt = - PC Ident [Patt] -- ^ constructor pattern: @C p1 ... pn@ @C@ - | PP Ident Ident [Patt] -- ^ qualified constr patt: @P.C p1 ... pn@ @P.C@ - | PV Ident -- ^ variable pattern: @x@ - | PW -- ^ wild card pattern: @_@ - | PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@ - | PString String -- ^ string literal pattern: @\"foo\"@ - | PInt Integer -- ^ integer literal pattern: @12@ - | PFloat Double -- ^ float literal pattern: @1.2@ - | PT Type Patt -- ^ type-annotated pattern - | PAs Ident Patt -- ^ as-pattern: x@p - - -- regular expression patterns - | PNeg Patt -- ^ negated pattern: -p - | PAlt Patt Patt -- ^ disjunctive pattern: p1 | p2 - | PSeq Patt Patt -- ^ sequence of token parts: p + q - | PRep Patt -- ^ repetition of token part: p* - - deriving (Read, Show, Eq, Ord) - --- | to guide computation and type checking of tables -data TInfo = - TRaw -- ^ received from parser; can be anything - | TTyped Type -- ^ type annotated, but can be anything - | TComp Type -- ^ expanded - | TWild Type -- ^ just one wild card pattern, no need to expand - deriving (Read, Show, Eq, Ord) - --- | record label -data Label = - LIdent String - | LVar Int - deriving (Read, Show, Eq, Ord) - -type MetaSymb = Int - -type Decl = (Ident,Term) -- (x:A) (_:A) A -type Context = [Decl] -- (x:A)(y:B) (x,y:A) (_,_:A) -type Substitution = [(Ident, Term)] -type Equation = ([Patt],Term) - -type Labelling = (Label, Term) -type Assign = (Label, (Maybe Type, Term)) -type Case = (Patt, Term) -type LocalDef = (Ident, (Maybe Type, Term)) - - --- | branches à la Alfa -newtype Branch = Branch (Con,([Ident],Term)) deriving (Eq, Ord,Show,Read) -type Con = Ident --- - -varLabel :: Int -> Label -varLabel = LVar - -wildPatt :: Patt -wildPatt = PW - -type Trm = Term -- cgit v1.2.3