moved some modules to Devel.Grammar

7 files changed, 517 insertions, 5 deletions

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