Merge branch 'majestic' of github.com:krangelov/gf-core into majestic

src/compiler/api/GF/Compile/Compute/Concrete.hs

@@ -285,7 +285,7 @@ eval env (Strs ts)      []  = do vs <- mapM (\t -> eval env t []) ts
                                  return (VStrs vs)
 eval env (Markup tag as ts) [] =
                               do as <- mapM (\(id,t) -> eval env t [] >>= \v -> return (id,v)) as
-                                 vs <- mapM (\t -> eval env t []) ts
+                                 vs <- mapM (\t -> eval env (unLoc t) []) ts
                                  return (VMarkup tag as vs)
 eval env (TSymCat d r rs) []= do rs <- forM rs $ \(i,(pv,ty)) ->
                                          case lookup pv env of
@@ -638,7 +638,7 @@ value2term flat xs (VStrs vs) = do
 value2term flat xs (VMarkup tag as vs) = do
   as <- mapM (\(id,v) -> value2term flat xs v >>= \t -> return (id,t)) as
   ts <- mapM (value2term flat xs) vs
-  return (Markup tag as ts)
+  return (Markup tag as (map noLoc ts))
 value2term flat xs (VCInts (Just i) Nothing) = return (App (Q (cPredef,cInts)) (EInt i))
 value2term flat xs (VCInts Nothing (Just j)) = return (App (Q (cPredef,cInts)) (EInt j))
 value2term flat xs (VCRecType lctrs) = do

src/compiler/api/GF/Compile/Compute/Concrete2.hs

@@ -87,7 +87,7 @@ data Value
   | VFV Choice (Variants Value)
   | VAlts Value [(Value, Value)]
   | VStrs [Value]
-  | VMarkup Ident [(Ident,Value)] [Value]
+  | VMarkup Ident [(Ident,Value)] [L Value]
   | VReset Ident (Maybe Value) Value (Maybe QIdent)
   | VSymCat Int LIndex [(LIndex, (Value, Type))]
   | VError Doc
@@ -126,7 +126,7 @@ isCanonicalForm True  (VFV {})            = False
 isCanonicalForm False (VFV c vs)          = all (isCanonicalForm False) (unvariants vs)
 isCanonicalForm flat  (VAlts d vs)        = all (isCanonicalForm flat . snd) vs
 isCanonicalForm flat  (VStrs vs)          = all (isCanonicalForm flat) vs
-isCanonicalForm flat  (VMarkup tag as vs) = all (isCanonicalForm flat . snd) as && all (isCanonicalForm flat) vs
+isCanonicalForm flat  (VMarkup tag as vs) = all (isCanonicalForm flat . snd) as && all (isCanonicalForm flat . unLoc) vs
 isCanonicalForm flat  (VReset ctl cv v _) = maybe True (isCanonicalForm flat) cv && isCanonicalForm flat v
 isCanonicalForm flat  _ = False
 
@@ -308,7 +308,7 @@ eval g env c (Strs ts)      []  = VStrs (mapC (\c t -> eval g env c t []) c ts)
 eval g env c (Markup tag as ts) [] =
                               let (c1,c2) = split c
                                   vas = mapC (\c (id,t) -> (id,eval g env c t [])) c1 as
-                                  vs  = mapC (\c t -> eval g env c t []) c2 ts
+                                  vs  = mapC (\c (L loc t) -> L loc (eval g env c t [])) c2 ts
                               in (VMarkup tag vas vs)
 eval g env c (Reset ctl mb_ct t qid) [] = VReset ctl (fmap (\t -> eval g env c t []) mb_ct) (eval g env c t []) qid
 eval g env c (TSymCat d r rs) []= VSymCat d r [(i,(fromJust (lookup pv env),ty)) | (i,(pv,ty)) <- rs]
@@ -410,7 +410,7 @@ bubble v = snd (bubble v)
     bubble (VStrs vs) = liftL VStrs vs
     bubble (VMarkup tag attrs vs) =
       let (union1,attrs') = mapAccumL descend' Map.empty attrs
-          (union2,vs')    = mapAccumL descend  union1 vs
+          (union2,vs')    = mapAccumL descendL union1 vs
       in (union2, VMarkup tag attrs' vs')
     bubble (VReset ctl mb_cv v id) =
       let (union,v') = bubble v
@@ -481,6 +481,10 @@ bubble v = snd (bubble v)
       let (choices,v') = bubble v
       in (mergeChoices1 union choices,(i,(v',ty)))
 
+    descendL union (L loc v) =
+      let (choices,v') = bubble v
+      in (mergeChoices1 union choices,L loc v')
+
     descendR union (l,b,v) =
       let (choices,v') = bubble v
       in (mergeChoices1 union choices,(l,b,v'))
@@ -934,7 +938,7 @@ value2termM flat xs (VStrs vs) = do
   return (Strs ts)
 value2termM flat xs (VMarkup tag as vs) = do
   as <- mapM (\(id,v) -> value2termM flat xs v >>= \t -> return (id,t)) as
-  ts <- mapM (value2termM flat xs) vs
+  ts <- mapM (mapM (value2termM flat xs)) vs
   return (Markup tag as ts)
 value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
   ts <- reset (value2termM True xs v)
@@ -948,7 +952,7 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
                  _             -> evalError (pp "[concat: .. | ..] requires an integer constant")
          case ts of
            [t] -> return t
-           ts  -> return (Markup identW [] ts)
+           ts  -> return (Markup identW [] (map noLoc ts))
       | ctl == cConcat' = do
          ts <- case mb_cv of
                  Just (VInt n) -> return (genericTake n ts)
@@ -957,7 +961,7 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
          case ts of
            []  -> mzero
            [t] -> return t
-           ts  -> return (Markup identW [] ts)
+           ts  -> return (Markup identW [] (map noLoc ts))
       | ctl == cOne =
          case (ts,mb_cv) of
            ([]  ,Nothing) -> mzero
@@ -979,6 +983,16 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
                                _    -> evalError (pp "The term must be a record")
                            select n (t:ts) = select (n-1) ts
            _             -> evalError (pp "[select: .. | ..] requires an integer constant")
+      | ctl == cFilter =
+          let filter []     = mzero
+              filter (t:ts) =
+                case t of
+                  R rs -> case (lookup (ident2label cp1) rs, lookup (ident2label cp2) rs) of
+                            (Just (_,t), Just (_,Q q))
+                                | q == (cPredef,cTrue) -> pure t `mplus` filter ts
+                            _                          ->                filter ts
+                  _    -> evalError (pp "The term must be a record")
+          in filter ts
       | ctl == cDefault =
          case (ts,mb_cv) of
            ([]  ,Nothing) -> mzero
@@ -1000,6 +1014,11 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
            Just cv  -> do g <- globals
                           value2termM True xs (apply g cv [VInt (genericLength ts)])
            Nothing  -> return (EInt (genericLength ts))
+      | ctl == cConst =
+          case mb_cv of
+            Just cv -> do ct <- value2termM flat xs cv
+                          msum (map (pure . const ct) ts)
+            _       -> evalError (pp "[const: .. | ..] requires an argument")
       | otherwise = evalError (pp "Operator" <+> pp ctl <+> pp "is not defined")
 
     listify mn cat [t1,t2] = do return (App (App (QC (mn,identS ("Base"++cat))) t1) t2)

src/compiler/api/GF/Compile/GeneratePMCFG.hs

@@ -102,7 +102,6 @@ pmcfgForm g t ctxt ty = do
        let (ms',s',_,t2,params) = type2metaTerm sgr d ms s 0 [] ty []
        in apply (d+1) ms' s' ctxt (App t t2) (params:args)
 
-
 type2fields :: SourceGrammar -> Type -> [String]
 type2fields gr = map show . type2fields PP.empty
   where

src/compiler/api/GF/Compile/TypeCheck/Concrete.hs

@@ -452,8 +452,8 @@ tcRho scope c (Markup tag attrs children) mb_ty = do
                        (t,_) <- tcRho scope c t Nothing
                        return (id,t))
                  c1 attrs
-  res <- mapCM (\c child -> tcRho scope c child Nothing) c2 children
+  res <- mapCM (\c (L loc child) -> fmap (L loc . fst) (tcRho scope c child Nothing)) c2 children
-  instSigma scope c3 (Markup tag attrs (map fst res)) vtypeMarkup mb_ty
+  instSigma scope c3 (Markup tag attrs res) vtypeMarkup mb_ty
 tcRho scope c (Reset ctl mb_ct t qid) mb_ty
   | ctl == cConcat || ctl == cConcat' = do
       let (c1,c23) = split c
@@ -487,6 +487,19 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty
                  Nothing -> evalError (pp "[select: .. | ..] requires an integer argument")
       (t,_) <- tcRho scope c1 t (Just rec_ty)
       return (Reset ctl mb_ct t qid,ty)
+  | ctl == cFilter = do
+      ty <- case mb_ty of
+              Just ty -> return ty
+              Nothing -> do i <- newResiduation scope
+                            return (VMeta i [])
+      let rec_ty = VRecType [ (ident2label cp1, True, ty)
+                            , (ident2label cp2, True, VApp poison (cPredef,cBool) [])
+                            ] False
+      case mb_ct of
+        Just ct -> evalError (pp "[filter | ..] cannot take an argument")
+        Nothing -> return ()
+      (t,_) <- tcRho scope c t (Just rec_ty)
+      return (Reset ctl mb_ct t qid,ty)
   | ctl == cDefault = do
       let (c1,c2) = split c
       (t,ty)     <- tcRho scope c1 t mb_ty
@@ -516,6 +529,14 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty
                          (ct,_) <- tcRho scope c2 ct (Just (VProd Explicit identW vtypeInt res_ty))
                          return (Reset ctl (Just ct) t Nothing, res_ty)
            Nothing -> instSigma scope c2 (Reset ctl Nothing t Nothing) vtypeInt mb_ty
+  | ctl == cConst = do
+      let (c1,c2) = split c
+      (t,_)      <- tcRho scope c1 t Nothing
+      (mb_ct,ty) <- case mb_ct of
+                      Just ct -> do (ct,ty) <- tcRho scope c2 ct mb_ty
+                                    return (Just ct,ty)
+                      Nothing -> evalError (pp "[list: .. | ..] requires an argument")
+      return (Reset ctl mb_ct t qid,ty)
   | otherwise = evalError (pp "Operator" <+> pp ctl <+> pp "is not defined")
 tcRho scope s (Opts n cs) mb_ty = do
   let (s1,s2,s3) = split3 s

src/compiler/api/GF/Data/XML.hs

@@ -4,7 +4,7 @@
 --
 -- Utilities for creating XML documents.
 ----------------------------------------------------------------------
-module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML, parseXML) where
+module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, showsNospaceXML, bottomUpXML, parseXML) where
 
 import Data.Char(isSpace)
 import Numeric (readHex)
@@ -38,6 +38,17 @@ showsXML = showsX 0 where
     (Empty) -> id
   ind i = showString ("\n" ++ replicate (2*i) ' ')
 
+showsNospaceXML :: XML -> ShowS
+showsNospaceXML x = case x of
+    (Data s) -> showString (escape s)
+    (ETag t as) -> showChar '<' . showString t . showsAttrs as . showString "/>"
+    (Tag t as cs) ->
+      showChar '<' . showString t . showsAttrs as . showChar '>' .
+      concatS (map showsNospaceXML cs) .
+      showString "</" . showString t . showChar '>'
+    (Comment c) -> showString "<!-- " . showString c . showString " -->"
+    (Empty) -> id
+
 showsAttrs :: [Attr] -> ShowS
 showsAttrs = concatS . map (showChar ' ' .) . map showsAttr
 

src/compiler/api/GF/Grammar/Grammar.hs

@@ -395,7 +395,7 @@ data Term =
 
  | FV [Term]                     -- ^ alternatives in free variation: @variants { s ; ... }@
 
- | Markup Ident [(Ident,Term)] [Term]
+ | Markup Ident [(Ident,Term)] [L Term]
  | Reset Ident (Maybe Term) Term (Maybe QIdent)
 
  | Alts Term [(Term, Term)]      -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@

src/compiler/api/GF/Grammar/JSON.hs

@@ -126,7 +126,7 @@ term2json (ELin id t) = makeObj [("lin",showJSON id), ("term",term2json t)]
 term2json (FV ts) = makeObj [("variants",showJSON (map term2json ts))]
 term2json (Markup tag attrs children) = makeObj [ ("tag",showJSON tag)
                                                 , ("attrs",showJSON (map (\(attr,val) -> (showJSON attr,term2json val)) attrs))
-                                                , ("children",showJSON (map term2json children))
+                                                , ("children",showJSON (map (term2json . unLoc) children))
                                                 ]
 term2json (Reset ctl ct t qid) =
   makeObj ([("ctl",showJSON ctl)]++maybe [] (\t->[("ct",term2json t)]) ct++[("term",term2json t), ("qid",showJSON qid)])
@@ -177,7 +177,7 @@ json2term o  = Vr      <$> o!:"vr"
     <|>        FV      <$> (o!:"variants" >>= mapM json2term)
     <|>        Markup  <$> (o!:"tag") <*>
                            (o!:"attrs" >>= mapM (\(attr,val) -> fmap ((,)attr) (json2term val))) <*>
-                           (o!:"children" >>= mapM json2term)
+                           (o!:"children" >>= mapM (fmap noLoc . json2term))
     <|>        Reset   <$> o!:"ctl" <*> fmap Just (o!<"ct") <*> o!<"term" <*> o!:"qid"
     <|>        Reset   <$> o!:"ctl" <*> pure Nothing <*> o!<"term" <*> o!:"qid"
     <|>        Alts    <$> (o!<"def") <*> (o!:"alts" >>= mapM (\(x,y) -> liftM2 (,) (json2term x) (json2term y)))

src/compiler/api/GF/Grammar/Macros.hs

@@ -418,7 +418,7 @@ composOp co trm =
    ELincat c ty     -> liftM (ELincat c) (co ty)
    ELin c ty        -> liftM (ELin c) (co ty)
    ImplArg t        -> liftM ImplArg (co t)
-   Markup t as cs   -> liftM2 (Markup t) (mapAttrs co as) (mapM co cs)
+   Markup t as cs   -> liftM2 (Markup t) (mapAttrs co as) (mapM (mapM co) cs)
    Reset ctl ct t qid->liftM2 (\mb_ct t->Reset ctl ct t qid) (maybe (pure Nothing) (fmap Just . co) ct) (co t)
    Typed t ty       -> liftM2 Typed (co t) (co ty)
    _ -> return trm -- covers K, Vr, Cn, Sort, EPatt
@@ -466,7 +466,7 @@ collectOp co trm = case trm of
   Strs tt      -> mconcatMap co tt
   ELincat _ t  -> co t
   ELin _ t     -> co t
-  Markup t as cs -> mconcatMap (co.snd) as <> mconcatMap co cs
+  Markup t as cs -> mconcatMap (co.snd) as <> mconcatMap (co . unLoc) cs
   Reset _ ct t _-> maybe mempty co ct <> co t
   _            -> mempty -- covers K, Vr, Cn, Sort
 

src/compiler/api/GF/Grammar/Parser.y

@@ -714,9 +714,11 @@ ERHS3 :: { ERHS }
   | '(' ERHS0 ')'         { $2         }
 
 NLG :: { Map.Map Ident Info }
-  : ListNLGDef             { Map.fromList $1 }
+  : ListNLGDef            { Map.fromList $1 }
-  | Posn Exp         Posn  { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 $2))) }
+  | Posn Exp Posn         { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 $2))) }
-  | Posn ListMarkup2 Posn  { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 (mkMarkup $2)))) }
+  | ListMarkup2           { case (head $1,last $1) of
+                              (L (Local l1 _) _, L (Local _ l2) _) -> Map.singleton (identS "main") (ResOper Nothing (Just (L (Local l1 l2) (mkMarkup $1))))
+                          }
 
 ListNLGDef :: { [(Ident,Info)] }
 ListNLGDef
@@ -730,10 +732,10 @@ NLGDef
   | Posn LhsName ListArg '=' ListMarkup2  Posn { [(i, info) | i <- [$2], info <- mkOverload Nothing   (Just (mkL $1 $6 (mkAbs $3 (mkMarkup $5))))] }
   | Posn LhsNames ':' Exp '=' ListMarkup2 Posn { [(i, info) | i <- $2,   info <- mkOverload (Just (mkL $1 $7 $4)) (Just (mkL $1 $7 (mkMarkup $6)))] }
 
-Markup :: { Term }
+Markup :: { L Term }
 Markup
-  : Tag     { $1 }
+  : Posn Tag Posn     { mkL $1 $3 $2 }
-  | Exp ';' { $1 }
+  | Posn Exp Posn ';' { mkL $1 $3 $2 }
 
 Tag :: { Term }
 Tag
@@ -742,12 +744,12 @@ Tag
                                                        else fail ("Unmatched closing tag " ++ showIdent $1) }
   | '<tag' Attributes '/' '>'                     { Markup $1 $2 [] }
 
-ListMarkup :: { [Term] }
+ListMarkup :: { [L Term] }
   :                    { []      }
-  | Exp                { [$1]    }
+  | Posn Exp Posn      { [mkL $1 $3 $2] }
   | Markup ListMarkup  { $1 : $2 }
 
-ListMarkup2 :: { [Term] }
+ListMarkup2 :: { [L Term] }
   : Markup              { [$1]    }
   | Markup ListMarkup2  { $1 : $2 }
 
@@ -889,7 +891,7 @@ mkAlts cs = case cs of
 mkL :: Posn -> Posn -> x -> L x
 mkL (Pn l1 _) (Pn l2 _) x = L (Local l1 l2) x
 
-mkMarkup [t] = t
+mkMarkup [t] = unLoc t
 mkMarkup ts  = Markup identW [] ts
 
 words2term []     = Empty

src/compiler/api/GF/Grammar/Predef.hs

@@ -25,6 +25,7 @@ cFloat = identS "Float"
 cString = identS "String"
 cInts = identS "Ints"
 cPBool = identS "PBool"
+cBool = identS "Bool"
 cErrorType = identS "Error"
 cOverload = identS "overload"
 cNonExist = identS "nonExist"
@@ -40,6 +41,8 @@ isPredefCat c = elem c [cInt,cString,cFloat]
 
 cPTrue  = identS "PTrue"
 cPFalse = identS "PFalse"
+cTrue  = identS "True"
+cFalse = identS "False"
 cLength = identS "length"
 cDrop = identS "drop"
 cTake = identS "take"
@@ -66,9 +69,11 @@ cConcat = identS "concat"
 cConcat' = identS "concat'"
 cOne = identS "one"
 cSelect = identS "select"
+cFilter = identS "filter"
 cDefault = identS "default"
 cList = identS "list"
 cLen = identS "len"
+cConst = identS "const"
 
 cp1 = identS "p1"
 cp2 = identS "p2"

src/compiler/api/GF/Grammar/Printer.hs

@@ -366,8 +366,8 @@ ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
 ppMarkupAttr q (id,e) =
   id <> pp '=' <> ppTerm q 5 e
 
-ppMarkupChildren q [t]    = ppTerm q 0 t
+ppMarkupChildren q [L _ t]    = ppTerm q 0 t
-ppMarkupChildren q (t:ts) =
+ppMarkupChildren q (L _ t:ts) =
   (case t of
      Markup {} -> ppTerm q 0 t
      _         -> ppTerm q 0 t <> ';') $$

src/compiler/api/GF/Infra/Location.hs

@@ -14,10 +14,14 @@ data Location
   deriving (Show,Eq,Ord)
 
 -- | Attaching location information
-data L a = L Location a deriving Show
+data L a = L Location a deriving (Show, Eq, Ord)
 
 instance Functor L where fmap f (L loc x) = L loc (f x)
 
+instance Foldable L where foldr f b (L loc x) = f x b
+
+instance Traversable L where traverse f (L loc x) = pure (L loc) <*> f x
+
 unLoc :: L a -> a
 unLoc (L _ x) = x