From c02a0c4159da18cc34e42bb9514542eedc490f58 Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Tue, 26 Aug 2025 19:45:31 +0200 Subject: [PATCH 01/14] fix the case PType => PType --- src/compiler/api/GF/Compile/GeneratePMCFG.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs index 0ff244c3d..383b11e41 100644 --- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs @@ -131,13 +131,22 @@ type2metaTerm gr d ms r rs (RecType lbls) = do type2metaTerm gr d ms r rs (Table p q) | count == 1 = do (ms',r',t) <- type2metaTerm gr d ms r rs q return (ms',r+(r'-r),T (TTyped p) [(PW,t)]) - | otherwise = do let pv = varX (length rs+1) + | null (collectParams q) + = do let pv = varX (length rs+1) (ms',delta,t) <- fixST $ \(~(_,delta,_)) -> do (ms',r',t) <- type2metaTerm gr d ms r ((delta,(pv,p)):rs) q return (ms',r'-r,t) return (ms',r+delta*count,T (TTyped p) [(PV pv,t)]) + | otherwise = do ((ms',r'),ts) <- mapAccumM (\(ms,r) _ -> do (ms',r',t) <- type2metaTerm gr d ms r rs q + return ((ms',r'),t)) + (ms,r) [0..count-1] + return (ms',r+(r'-r),V p ts) where + collectParams (QC q) = [q] + collectParams (Table _ t) = collectParams t + collectParams t = collectOp collectParams t + count = case allParamValues gr p of Ok ts -> length ts Bad msg -> error msg From d8df0a0171c2e2e23f574a048f3c0356452423dc Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Sat, 30 Aug 2025 14:01:06 +0000 Subject: [PATCH 02/14] fix evaluation of options --- src/compiler/api/GF/Compile/Compute/Concrete2.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs index 8c260cc2b..2070cbe5a 100644 --- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs +++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs @@ -94,7 +94,7 @@ data Value data Variants = VarFree [Value] - | VarOpts Value [(Maybe Value, Value)] + | VarOpts Value [(Value, Value)] mapVariants :: (Value -> Value) -> Variants -> Variants mapVariants f (VarFree vs) = VarFree (f <$> vs) @@ -138,7 +138,7 @@ data ConstValue a data ConstVariants a = ConstFree [ConstValue a] - | ConstOpts Value [(Maybe Value, ConstValue a)] + | ConstOpts Value [(Value, ConstValue a)] mapConstVs :: (ConstValue a -> ConstValue b) -> ConstVariants a -> ConstVariants b mapConstVs f (ConstFree vs) = ConstFree (f <$> vs) @@ -337,8 +337,8 @@ eval g env c t@(Opts n cs) vs = if null cs vn = eval g env c1 n [] vcs = mapC evalOpt c cs in VFV c3 (VarOpts vn vcs) - where evalOpt c' (Just l, t) = let (c1,c2) = split c' in (Just (eval g env c1 l []), eval g env c2 t vs) - evalOpt c' (Nothing,t) = let (c1,c2) = split c' in (Nothing, eval g env c2 t vs) + where evalOpt c' (Just l, t) = let (c1,c2) = split c' in (eval g env c1 l [], eval g env c2 t vs) + evalOpt c' (Nothing,t) = let v = eval g env c' t vs in (v, v) eval g env c t vs = VError ("Cannot reduce term" <+> pp t) evalPredef :: Globals -> Choice -> Ident -> [Value] -> Value @@ -424,7 +424,7 @@ bubble v = snd (bubble v) bubble v@(VFV c (VarOpts n os)) | null os = (Map.empty, v) | otherwise = let (union,os') = mapAccumL (\acc (k,v) -> second (k,) $ descend acc v) Map.empty os - in (Map.insert c (BubbleOpts n (map (\(l,t) -> fromMaybe t l) os),1) union, VFV c (VarOpts n os')) + in (Map.insert c (BubbleOpts n (map fst os),1) union, VFV c (VarOpts n os')) bubble (VAlts v vs) = lift1L2 VAlts v vs bubble (VStrs vs) = liftL VStrs vs bubble (VMarkup tag attrs vs) = @@ -509,7 +509,7 @@ bubble v = snd (bubble v) addVariant c (bvs,cnt) v | cnt > 1 = VFV c $ case bvs of BubbleFree k -> VarFree (replicate k v) - BubbleOpts n os -> VarOpts n (map (\l -> (Just l,v)) os) + BubbleOpts n os -> VarOpts n (map (\l -> (l,v)) os) | otherwise = v unitfy = fmap (\(n,_) -> (n,1)) @@ -925,7 +925,7 @@ value2termM flat xs (VFV i (VarOpts n os)) = let j = fromMaybe 0 (Map.lookup i choices) in case os `maybeAt` j of Just (l,t) -> case value2termM flat xs t of - EvalM f -> let oi = OptionInfo i n (map (\(l,t) -> fromMaybe t l) os) + EvalM f -> let oi = OptionInfo i n (map fst os) in f g k (State choices metas (oi:opts)) r msgs Nothing -> Fail ("Index" <+> j <+> "out of bounds for option:" $$ ppValue Unqualified 0 n) msgs value2termM flat xs (VPatt min max p) = return (EPatt min max p) From b79a53adc5989ade1acdfc3738dde905f8728cdf Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Sat, 30 Aug 2025 14:54:07 +0000 Subject: [PATCH 03/14] fix parsing NLG operations --- src/compiler/api/GF/Grammar/Parser.y | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/compiler/api/GF/Grammar/Parser.y b/src/compiler/api/GF/Grammar/Parser.y index a6e04dd3a..b46b17a4f 100644 --- a/src/compiler/api/GF/Grammar/Parser.y +++ b/src/compiler/api/GF/Grammar/Parser.y @@ -720,7 +720,7 @@ NLG :: { Map.Map Ident Info } ListNLGDef :: { [(Ident,Info)] } ListNLGDef - : 'oper' NLGDef { [] } + : 'oper' NLGDef { $2 } | 'oper' NLGDef ListNLGDef { $2 ++ $3 } NLGDef :: { [(Ident,Info)] } From e5a531da616641bc6955d12ed61dc56d5a4b3d1c Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Sat, 30 Aug 2025 20:09:13 +0200 Subject: [PATCH 04/14] testing repl not needed anymore --- src/compiler/api/GF/Compile/Repl.hs | 313 ---------------------------- src/compiler/gf-repl.hs | 12 -- src/compiler/gf.cabal | 7 - 3 files changed, 332 deletions(-) delete mode 100644 src/compiler/api/GF/Compile/Repl.hs delete mode 100644 src/compiler/gf-repl.hs diff --git a/src/compiler/api/GF/Compile/Repl.hs b/src/compiler/api/GF/Compile/Repl.hs deleted file mode 100644 index 7c952cd9e..000000000 --- a/src/compiler/api/GF/Compile/Repl.hs +++ /dev/null @@ -1,313 +0,0 @@ -{-# LANGUAGE LambdaCase, TupleSections, NamedFieldPuns #-} - -module GF.Compile.Repl (ReplOpts(..), defaultReplOpts, replOptDescrs, getReplOpts, runRepl, runRepl') where - -import Control.Monad (join, when, unless, forM_, foldM) -import Control.Monad.IO.Class (MonadIO) -import qualified Data.ByteString.Char8 as BS -import Data.Char (isSpace) -import Data.Function ((&)) -import Data.Functor ((<&>)) -import Data.List (find) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import Text.Read (readMaybe) - -import System.Console.GetOpt (ArgOrder(RequireOrder), OptDescr(..), ArgDescr(..), getOpt, usageInfo) -import System.Console.Haskeline (InputT, Settings(..), noCompletion, runInputT, getInputLine, outputStrLn) -import System.Directory (getAppUserDataDirectory) - -import GF.Compile (batchCompile) -import GF.Compile.Compute.Concrete2 - ( Choice(..) - , ChoiceMap - , Globals(Gl) - , OptionInfo(..) - , stdPredef - , unit - , eval - , cleanOptions - , runEvalMWithOpts - , value2termM - , ppValue - ) -import GF.Compile.Rename (renameSourceTerm) -import GF.Compile.TypeCheck.Concrete (inferLType) -import GF.Data.ErrM (Err(..)) -import GF.Data.Utilities (maybeAt, orLeft) -import GF.Grammar.Grammar - ( Grammar - , mGrammar - , Info - , Module - , ModuleName - , ModuleInfo(..) - , ModuleType(MTResource) - , ModuleStatus(MSComplete) - , OpenSpec(OSimple) - , Location (NoLoc) - , Term(Typed) - , prependModule - ) -import GF.Grammar.Lexer (Posn(..), Lang(..), runLangP) -import GF.Grammar.Parser (pTerm) -import GF.Grammar.Printer (TermPrintQual(Unqualified), ppTerm) -import GF.Infra.CheckM (Check, runCheck) -import GF.Infra.Ident (moduleNameS) -import GF.Infra.Option (noOptions) -import GF.Infra.UseIO (justModuleName) -import GF.Text.Pretty (render) -import Debug.Trace - -data ReplOpts = ReplOpts - { lang :: Lang - , noPrelude :: Bool - , inputFiles :: [String] - , evalToFlat :: Bool - } - -defaultReplOpts :: ReplOpts -defaultReplOpts = ReplOpts - { lang = GF - , noPrelude = False - , inputFiles = [] - , evalToFlat = True - } - -type Errs a = Either [String] a -type ReplOptsOp = ReplOpts -> Errs ReplOpts - -replOptDescrs :: [OptDescr ReplOptsOp] -replOptDescrs = - [ Option ['h'] ["help"] (NoArg $ \o -> Left [usageInfo "gfci" replOptDescrs]) "Display help." - , Option [] ["no-prelude"] (flag $ \o -> o { noPrelude = True }) "Don't load the prelude." - , Option [] ["lang"] (ReqArg (\s o -> case s of - "gf" -> Right (o { lang = GF }) - "bnfc" -> Right (o { lang = BNFC }) - "nlg" -> Right (o { lang = NLG }) - _ -> Left ["Unknown language variant: " ++ s]) - "{gf,bnfc,nlg}") - "Set the active language variant." - , Option [] ["no-flat"] (flag $ \o -> o { evalToFlat = False }) "Do not evaluate to flat form." - ] - where - flag f = NoArg $ \o -> pure (f o) - -getReplOpts :: [String] -> Errs ReplOpts -getReplOpts args = case errs of - [] -> foldM (&) defaultReplOpts flags <&> \o -> o { inputFiles = inputFiles } - _ -> Left errs - where - (flags, inputFiles, errs) = getOpt RequireOrder replOptDescrs args - -execCheck :: MonadIO m => Check a -> (a -> InputT m b) -> InputT m (Maybe b) -execCheck c k = case runCheck c of - Ok (a, warn) -> do - unless (null warn) $ outputStrLn warn - Just <$> k a - Bad err -> do - outputStrLn err - return Nothing - -replModNameStr :: String -replModNameStr = "" - -replModName :: ModuleName -replModName = moduleNameS replModNameStr - -parseThen :: MonadIO m => Lang -> Grammar -> String -> (Term -> InputT m b) -> InputT m (Maybe b) -parseThen l g s k = case runLangP l pTerm (BS.pack s) of - Left (Pn l c, err) -> do - outputStrLn $ err ++ " (" ++ show l ++ ":" ++ show c ++ ")" - return Nothing - Right t -> execCheck (renameSourceTerm g replModName t) $ \t -> k t - -data ResultState = ResultState - { srsResult :: Term - , srsChoices :: ChoiceMap - , srsOptInfo :: [OptionInfo] - , srsOpts :: ChoiceMap - } -data OptionState = OptionState - { osTerm :: Term - , osResults :: [ResultState] - , osSelected :: Maybe ResultState - } -newtype ReplState = ReplState - { rsOpts :: Maybe OptionState - } - -initState :: ReplState -initState = ReplState Nothing - -runRepl' :: ReplOpts -> Globals -> IO () -runRepl' opts@ReplOpts { lang, evalToFlat } gl@(Gl g _) = do - historyFile <- getAppUserDataDirectory "gfci_history" - runInputT (Settings noCompletion (Just historyFile) True) (repl initState) -- TODO tab completion - where - repl st = do - getInputLine "gfci> " >>= \case - Nothing -> repl st - Just (':' : l) -> let (cmd, arg) = break isSpace l in command st cmd (dropWhile isSpace arg) - Just code -> evalPrintLoop st code - - nlrepl st = outputStrLn "" >> repl st - - -- Show help text - command st "?" arg = do - outputStrLn ":? -- show help text." - outputStrLn ":t -- show the inferred type of ." - outputStrLn ":r -- show the results of the last eval." - outputStrLn ":s -- select the result at ." - outputStrLn ":c -- show the current selected result." - outputStrLn ":o -- set option to ." - outputStrLn ":q -- quit the REPL." - nlrepl st - - -- Show the inferred type of an expression - command st "t" arg = do - parseThen lang g arg $ \main -> - execCheck (inferLType gl main) $ \(t, ty) -> - let t' = case t of - Typed _ _ -> t - t -> Typed t ty - in outputStrLn $ render (ppTerm Unqualified 0 t') - nlrepl st - - -- Show the results of the last evaluated expression - command st "r" arg = do - case rsOpts st of - Nothing -> do - outputStrLn "No results to show!" - Just (OptionState t rs _) -> do - outputStrLn $ "> " ++ render (ppTerm Unqualified 0 t) - outputResults rs - nlrepl st - - -- Select a result to "focus" by its index - command st "s" arg = do - let e = do (OptionState t rs _) <- orLeft "No results to select!" $ rsOpts st - s <- orLeft "Could not parse result index!" $ readMaybe arg - (ResultState r cs ois os) <- orLeft "Result index out of bounds!" $ rs `maybeAt` (s - 1) - return (t, rs, r, cs, ois, os) - case e of - Left err -> do - outputStrLn err - nlrepl st - Right (t, rs, r, cs, ois, os) -> do - outputStrLn $ render (ppTerm Unqualified 0 r) - outputOptions ois os - nlrepl (st { rsOpts = Just (OptionState t rs (Just (ResultState r cs ois os))) }) - - -- Show the current selected result - command st "c" arg = do - let e = do (OptionState t _ sel) <- orLeft "No results to select!" $ rsOpts st - (ResultState r _ ois os) <- orLeft "No result selected!" sel - return (t, r, ois, os) - case e of - Left err -> outputStrLn err - Right (t, r, ois, os) -> do - outputStrLn $ "> " ++ render (ppTerm Unqualified 0 t) - outputStrLn $ render (ppTerm Unqualified 0 r) - outputOptions ois os - nlrepl st - - -- Set an option for the selected result - command st "o" arg = do - let e = do (OptionState t _ sel) <- orLeft "No results to select!" $ rsOpts st - (ResultState _ cs ois os) <- orLeft "No result selected!" sel - (c, i) <- case words arg of - [argc, argi] -> do - c <- orLeft "Could not parse option choice!" $ readMaybe argc - i <- orLeft "Could not parse option value!" $ readMaybe argi - return (c, i) - _ -> Left "Expected two arguments!" - when (i < 1) $ Left "Option value must be positive!" - oi <- orLeft "No such option!" $ find (\oi -> unchoice (optChoice oi) == c) ois - when (i > length (optChoices oi)) $ Left "Option value out of bounds!" - return (t, cs, ois, os, c, i) - case e of - Left err -> do - outputStrLn err - nlrepl st - Right (t, cs, ois, os, c, i) -> do - let os' = Map.insert (Choice c) (i - 1) os - nfs <- execCheck (doEval st t (Map.union os' cs)) pure - case nfs of - Nothing -> nlrepl st - Just [] -> do - outputStrLn "No results!" - nlrepl st - Just [(r, cs, ois')] -> do - outputStrLn $ render (ppTerm Unqualified 0 r) - let os'' = cleanOptions ois' os' - outputOptions ois' os'' - let rst = ResultState r (Map.difference cs os') ois' os'' - nlrepl (st { rsOpts = Just (OptionState t [rst] (Just rst)) }) - Just rs -> do - let rsts = rs <&> \(r, cs, ois') -> - ResultState r (Map.difference cs os') ois' (cleanOptions ois' os') - outputResults rsts - nlrepl (st { rsOpts = Just (OptionState t rsts Nothing) }) - - -- Quit the REPL - command _ "q" _ = outputStrLn "Bye!" - - command st cmd _ = do - outputStrLn $ "Unknown REPL command \"" ++ cmd ++ "\"! Use :? for help." - nlrepl st - - evalPrintLoop st code = do -- TODO bindings - c <- parseThen lang g code $ \main -> do - rsts <- execCheck (doEval st main Map.empty) $ \nfs -> do - if null nfs then do - outputStrLn "No results!" - return Nothing - else do - let rsts = nfs <&> \(r, cs, ois) -> ResultState r cs ois Map.empty - outputResults rsts - return $ Just rsts - return $ (main,) <$> join rsts - case join c of - Just (t, rs) -> nlrepl (ReplState (Just (OptionState t rs Nothing))) - Nothing -> nlrepl st - - doEval st t opts = inferLType gl t >>= \case - (t', _) -> runEvalMWithOpts gl opts (value2termM evalToFlat [] (eval gl [] unit t' [])) - - outputResults rs = - forM_ (zip [1..] rs) $ \(i, ResultState r _ opts _) -> - outputStrLn $ show i ++ (if null opts then ". " else "*. ") ++ render (ppTerm Unqualified 0 r) - - outputOptions ois os = - forM_ ois $ \(OptionInfo c n ls) -> do - outputStrLn "" - outputStrLn $ show (unchoice c) ++ ") " ++ render (ppValue Unqualified 0 n) - let sel = fromMaybe 0 (Map.lookup c os) + 1 - forM_ (zip [1..] ls) $ \(i, l) -> - outputStrLn $ (if i == sel then "->" else " ") ++ show i ++ ". " ++ render (ppValue Unqualified 0 l) - -runRepl :: ReplOpts -> IO () -runRepl opts@ReplOpts { noPrelude, inputFiles } = do - -- TODO accept an ngf grammar - let toLoad = if noPrelude then inputFiles else "prelude/Predef.gfo" : inputFiles - (g0, opens) <- case toLoad of - [] -> pure (mGrammar [], []) - _ -> do - (_, g0) <- batchCompile noOptions Nothing toLoad - pure (g0, OSimple . moduleNameS . justModuleName <$> toLoad) - let - modInfo = ModInfo - { mtype = MTResource - , mstatus = MSComplete - , mflags = noOptions - , mextend = [] - , mwith = Nothing - , mopens = opens - , mexdeps = [] - , msrc = replModNameStr - , mseqs = Nothing - , jments = Map.empty - } - g = Gl (prependModule g0 (replModName, modInfo)) (if noPrelude then Map.empty else stdPredef g) - runRepl' opts g diff --git a/src/compiler/gf-repl.hs b/src/compiler/gf-repl.hs deleted file mode 100644 index 5b890fa9e..000000000 --- a/src/compiler/gf-repl.hs +++ /dev/null @@ -1,12 +0,0 @@ -import GHC.IO.Encoding (setLocaleEncoding, utf8) - -import System.Environment (getArgs) -import GF.Compile.Repl (getReplOpts, runRepl) - -main :: IO () -main = do - setLocaleEncoding utf8 - args <- getArgs - case getReplOpts args of - Left errs -> mapM_ putStrLn errs - Right opts -> runRepl opts diff --git a/src/compiler/gf.cabal b/src/compiler/gf.cabal index 56875c9bb..a4f6bd7cf 100644 --- a/src/compiler/gf.cabal +++ b/src/compiler/gf.cabal @@ -121,7 +121,6 @@ library GF.Compile.GrammarToCanonical GF.Compile.ReadFiles GF.Compile.Rename - GF.Compile.Repl GF.Compile.SubExOpt GF.Compile.Tags GF.Compile.ToAPI @@ -239,12 +238,6 @@ executable gf build-depends: base >= 4.6 && <5, directory>=1.2, gf ghc-options: -threaded -executable gfci - main-is: gf-repl.hs - default-language: Haskell2010 - build-depends: base >= 4.6 && < 5, gf - ghc-options: -threaded - test-suite gf-tests type: exitcode-stdio-1.0 main-is: run.hs From 85806752c383f6ddc7c6839b4b59e50e41482ce4 Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Sat, 30 Aug 2025 21:20:52 +0200 Subject: [PATCH 05/14] remove AdHocOverload --- src/compiler/api/GF/Grammar/Grammar.hs | 2 -- src/compiler/api/GF/Grammar/JSON.hs | 2 -- src/compiler/api/GF/Grammar/Macros.hs | 1 - src/compiler/api/GF/Grammar/Printer.hs | 1 - 4 files changed, 6 deletions(-) diff --git a/src/compiler/api/GF/Grammar/Grammar.hs b/src/compiler/api/GF/Grammar/Grammar.hs index 74433c076..189b3c36f 100644 --- a/src/compiler/api/GF/Grammar/Grammar.hs +++ b/src/compiler/api/GF/Grammar/Grammar.hs @@ -394,8 +394,6 @@ data Term = | ELincat Ident Term -- ^ boxed linearization type of Ident | ELin Ident Term -- ^ boxed linearization of type Ident - | AdHocOverload [Term] -- ^ ad hoc overloading generated in Rename - | FV [Term] -- ^ alternatives in free variation: @variants { s ; ... }@ | Markup Ident [(Ident,Term)] [Term] diff --git a/src/compiler/api/GF/Grammar/JSON.hs b/src/compiler/api/GF/Grammar/JSON.hs index ce24559bf..0ca49e15f 100644 --- a/src/compiler/api/GF/Grammar/JSON.hs +++ b/src/compiler/api/GF/Grammar/JSON.hs @@ -123,7 +123,6 @@ term2json (Glue t1 t2) = makeObj [("glue1",term2json t1),("glue2", term2json t2) term2json (EPattType t) = makeObj [("patttype",term2json t)] term2json (ELincat id t) = makeObj [("lincat",showJSON id), ("term",term2json t)] term2json (ELin id t) = makeObj [("lin",showJSON id), ("term",term2json t)] -term2json (AdHocOverload ts) = makeObj [("overloaded",showJSON (map term2json ts))] 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)) @@ -175,7 +174,6 @@ json2term o = Vr <$> o!:"vr" <|> EPattType <$> o!<"patttype" <|> ELincat <$> o!:"lincat" <*> o!<"term" <|> ELin <$> o!:"lin" <*> o!<"term" - <|> AdHocOverload <$> (o!:"overloaded" >>= mapM json2term) <|> FV <$> (o!:"variants" >>= mapM json2term) <|> Markup <$> (o!:"tag") <*> (o!:"attrs" >>= mapM (\(attr,val) -> fmap ((,)attr) (json2term val))) <*> diff --git a/src/compiler/api/GF/Grammar/Macros.hs b/src/compiler/api/GF/Grammar/Macros.hs index 4c24b9b0e..56b755178 100644 --- a/src/compiler/api/GF/Grammar/Macros.hs +++ b/src/compiler/api/GF/Grammar/Macros.hs @@ -466,7 +466,6 @@ collectOp co trm = case trm of Strs tt -> mconcatMap co tt ELincat _ t -> co t ELin _ t -> co t - AdHocOverload ts -> mconcatMap co ts Markup t as cs -> mconcatMap (co.snd) as <> mconcatMap co cs Reset _ ct t _-> maybe mempty co ct <> co t _ -> mempty -- covers K, Vr, Cn, Sort diff --git a/src/compiler/api/GF/Grammar/Printer.hs b/src/compiler/api/GF/Grammar/Printer.hs index ef6bc9eec..9a6283e49 100644 --- a/src/compiler/api/GF/Grammar/Printer.hs +++ b/src/compiler/api/GF/Grammar/Printer.hs @@ -224,7 +224,6 @@ ppTerm q d (Opts t opts) = "option" <+> ppTerm q 0 t <+>"of" <+> '{' $$ ppTerm q d (App x y) = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y) ppTerm q d (V e es) = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))]) ppTerm q d (FV es) = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))) -ppTerm q d (AdHocOverload es) = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))) ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs)))) ppTerm q d (Strs es) = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))) ppTerm q d (EPatt _ _ p)=prec d 4 ('#' <+> ppPatt q 2 p) From 25b3d8026ce9f4c1d9f84368206b1370e3677a1e Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Mon, 1 Sep 2025 08:43:58 +0000 Subject: [PATCH 06/14] added value2expr --- src/compiler/api/GF/Compile/Compute/Concrete2.hs | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs index 2070cbe5a..90fa57bb6 100644 --- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs +++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs @@ -8,7 +8,7 @@ module GF.Compile.Compute.Concrete2 PredefImpl, Predef(..), ($\), pdCanonicalArgs, pdArity, normalForm, normalFlatForm, - eval, apply, value2term, value2termM, value2int, value2float, bubble, patternMatch, vtableSelect, State(..), + eval, apply, value2term, value2termM, value2string, value2int, value2float, value2expr, string2value, bubble, patternMatch, vtableSelect, State(..), newResiduation, checkpoint, getMeta, setMeta, MetaState(..), variants, try, evalError, evalWarn, ppValue, Choice(..), unit, poison, split, split3, split4, mapC, mapCM) where @@ -34,6 +34,7 @@ import Data.Functor ((<&>)) import Data.Maybe (fromMaybe,fromJust) import Data.List import Data.Char +import PGF2(Expr(..),Literal(..)) type PredefImpl = Globals -> Choice -> [Value] -> ConstValue Value newtype Predef = Predef { runPredef :: PredefImpl } @@ -1163,6 +1164,19 @@ value2float g (VFlt f) = Const f value2float g (VFV s vs) = CFV s (variants2consts (value2float g) vs) value2float g _ = RunTime +value2expr g xs (VApp _ (m,f) vs) + | m /= cPredef = foldl (\e v -> fmap EApp e <*> value2expr g xs v) (pure (EFun (showIdent f))) vs +value2expr g xs (VMeta i vs) = CSusp i (\v -> value2expr g xs (apply g v vs)) +value2expr g xs (VSusp i k vs) = CSusp i (\v -> value2expr g xs (apply g (k v) vs)) +value2expr g xs (VGen j vs) = foldl (\e v -> fmap EApp e <*> value2expr g xs v) (pure (EVar (length xs - j - 1))) vs +value2expr g xs (VClosure env s (Abs b x t)) = + let v = eval g ((x,VGen (length xs) []):env) s t [] + x' = mkFreshVar xs x + in fmap (EAbs b (showIdent x')) (value2expr g (x':xs) v) +value2expr g xs (VInt n) = pure (ELit (LInt n)) +value2expr g xs (VFlt f) = pure (ELit (LFlt f)) +value2expr g xs v = fmap (ELit . LStr) (value2string g v) + newtype Choice = Choice { unchoice :: Integer } deriving (Eq,Ord,Pretty,Show) From 4eb8ae2f850369f04c58e44fb27ca1f332129e5e Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Tue, 2 Sep 2025 12:21:18 +0000 Subject: [PATCH 07/14] refactoring bugfixing related to options --- .../api/GF/Compile/Compute/Concrete2.hs | 135 ++++++++---------- 1 file changed, 60 insertions(+), 75 deletions(-) diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs index 90fa57bb6..3cfb3f772 100644 --- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs +++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs @@ -1,10 +1,10 @@ {-# LANGUAGE RankNTypes, BangPatterns, GeneralizedNewtypeDeriving, TupleSections #-} module GF.Compile.Compute.Concrete2 - (Env, Scope, Value(..), Variants(..), OptionInfo(..), ChoiceMap, cleanOptions, - ConstValue(..), ConstVariants(..), Globals(..), PredefTable, EvalM, - mapVariants, mapVariantsC, unvariants, variants2consts, consts2variants, - runEvalM, runEvalMWithOpts, stdPredef, globals, + (Env, Scope, Value(..), Variants(..), OptionInfo(..), + ConstValue(..), Globals(..), PredefTable, EvalM, + mapVariants, mapVariantsC, unvariants, + runEvalM, runEvalMWithInput, stdPredef, globals, PredefImpl, Predef(..), ($\), pdCanonicalArgs, pdArity, normalForm, normalFlatForm, @@ -84,7 +84,7 @@ data Value | VGlue Value Value | VPatt Int (Maybe Int) Patt | VPattType Value - | VFV Choice Variants + | VFV Choice (Variants Value) | VAlts Value [(Value, Value)] | VStrs [Value] | VMarkup Ident [(Ident,Value)] [Value] @@ -93,19 +93,19 @@ data Value | VError Doc | VInts Integer Bool -data Variants - = VarFree [Value] - | VarOpts Value [(Value, Value)] +data Variants a + = VarFree [a] + | VarOpts Value [(Value, a)] -mapVariants :: (Value -> Value) -> Variants -> Variants +mapVariants :: (a -> b) -> Variants a -> Variants b mapVariants f (VarFree vs) = VarFree (f <$> vs) mapVariants f (VarOpts n cs) = VarOpts n (second f <$> cs) -mapVariantsC :: (Choice -> Value -> Value) -> Choice -> Variants -> Variants +mapVariantsC :: (Choice -> a -> b) -> Choice -> Variants a -> Variants b mapVariantsC f c (VarFree vs) = VarFree (mapC f c vs) mapVariantsC f c (VarOpts n cs) = VarOpts n (mapC (\c (x,y) -> (x,f c y)) c cs) -unvariants :: Variants -> [Value] +unvariants :: Variants a -> [a] unvariants (VarFree vs) = vs unvariants (VarOpts n cs) = snd <$> cs @@ -133,25 +133,13 @@ isCanonicalForm flat _ = False data ConstValue a = Const a | CSusp MetaId (Value -> ConstValue a) - | CFV Choice (ConstVariants a) + | CFV Choice (Variants (ConstValue a)) | RunTime | NonExist -data ConstVariants a - = ConstFree [ConstValue a] - | ConstOpts Value [(Value, ConstValue a)] - -mapConstVs :: (ConstValue a -> ConstValue b) -> ConstVariants a -> ConstVariants b -mapConstVs f (ConstFree vs) = ConstFree (f <$> vs) -mapConstVs f (ConstOpts n cs) = ConstOpts n (second f <$> cs) - -unconstVs :: ConstVariants a -> [ConstValue a] -unconstVs (ConstFree vs) = vs -unconstVs (ConstOpts n cs) = snd <$> cs - instance Functor ConstValue where fmap f (Const c) = Const (f c) - fmap f (CFV i vs) = CFV i (mapConstVs (fmap f) vs) + fmap f (CFV i vs) = CFV i (mapVariants (fmap f) vs) fmap f (CSusp i k) = CSusp i (fmap f . k) fmap f RunTime = RunTime fmap f NonExist = NonExist @@ -160,8 +148,8 @@ instance Applicative ConstValue where pure = Const (Const f) <*> (Const x) = Const (f x) - (CFV s vs) <*> v2 = CFV s (mapConstVs (<*> v2) vs) - v1 <*> (CFV s vs) = CFV s (mapConstVs (v1 <*>) vs) + (CFV s vs) <*> v2 = CFV s (mapVariants (<*> v2) vs) + v1 <*> (CFV s vs) = CFV s (mapVariants (v1 <*>) vs) (CSusp i k) <*> v2 = CSusp i (\v -> k v <*> v2) v1 <*> (CSusp i k) = CSusp i (\v -> v1 <*> k v) NonExist <*> _ = NonExist @@ -169,14 +157,6 @@ instance Applicative ConstValue where RunTime <*> _ = RunTime _ <*> RunTime = RunTime -variants2consts :: (Value -> ConstValue a) -> Variants -> ConstVariants a -variants2consts f (VarFree vs) = ConstFree (f <$> vs) -variants2consts f (VarOpts n os) = ConstOpts n (second f <$> os) - -consts2variants :: (ConstValue a -> Value) -> ConstVariants a -> Variants -consts2variants f (ConstFree vs) = VarFree (f <$> vs) -consts2variants f (ConstOpts n os) = VarOpts n (second f <$> os) - normalForm :: Globals -> Term -> Check Term normalForm g t = value2term g [] (bubble (eval g [] unit t [])) @@ -256,7 +236,7 @@ eval g env s (S t1 t2) vs = let (!s1,!s2) = split s select v1 = v0 -- FIXME: options=[] is definitely not correct and this shouldn't be using value2termM at all - empty = State Map.empty Map.empty [] + empty = State [] Map.empty Map.empty [] in select v1 eval g env s (Let (x,(_,t1)) t2) vs = let (!s1,!s2) = split s @@ -347,7 +327,7 @@ evalPredef g@(Gl gr pds) c n args = case Map.lookup n pds of Nothing -> VApp c (cPredef,n) args Just def -> let valueOf (Const res) = res - valueOf (CFV i vs) = VFV i (consts2variants valueOf vs) + valueOf (CFV i vs) = VFV i (mapVariants valueOf vs) valueOf (CSusp i k) = VSusp i (valueOf . k) [] valueOf RunTime = VApp c (cPredef,n) args valueOf NonExist = VApp c (cPredef,cNonExist) [] @@ -625,7 +605,7 @@ vtableSelect g v0 ty cs v2 vs = where select (Const (i,_)) = cs !! i select (CSusp i k) = VSusp i (\v -> select (k v)) [] - select (CFV s vs) = VFV s (consts2variants select vs) + select (CFV c vs) = VFV c (mapVariants select vs) select _ = v0 value2index (VMeta i vs) ty = CSusp i (\v -> value2index (apply g v vs) ty) @@ -665,7 +645,7 @@ vtableSelect g v0 ty cs v2 vs = Gl gr _ = g value2index (VInt n) ty | Just max <- isTypeInts ty = Const (fromIntegral n,fromIntegral max+1) - value2index (VFV i vs) ty = CFV i (variants2consts (\v -> value2index v ty) vs) + value2index (VFV c vs) ty = CFV c (mapVariants (\v -> value2index v ty) vs) value2index v ty = RunTime @@ -683,20 +663,18 @@ data MetaState data OptionInfo = OptionInfo { optChoice :: Choice + , optValue :: Int , optLabel :: Value , optChoices :: [Value] } -type ChoiceMap = Map.Map Choice Int data State = State - { choices :: ChoiceMap + { input :: [(Choice, Int)] + , choices :: Map.Map Choice Int , metaVars :: Map.Map MetaId MetaState , options :: [OptionInfo] } -cleanOptions :: [OptionInfo] -> ChoiceMap -> ChoiceMap -cleanOptions opts = Map.filterWithKey (\k _ -> any (\opt -> k == optChoice opt) opts) - type Cont r = State -> r -> [Message] -> CheckResult r [Message] newtype EvalM a = EvalM (forall r . Globals -> (a -> Cont r) -> Cont r) @@ -732,15 +710,15 @@ runEvalM g (EvalM f) = Check $ \(es,ws) -> Fail msg ws -> Fail msg (es,ws) Success xs ws -> Success (reverse xs) (es,ws) where - empty = State Map.empty Map.empty [] + empty = State [] Map.empty Map.empty [] -runEvalMWithOpts :: Globals -> ChoiceMap -> EvalM a -> Check [(a, ChoiceMap, [OptionInfo])] -runEvalMWithOpts g cs (EvalM f) = Check $ \(es,ws) -> - case f g (\x (State cs mvs os) xs ws -> Success ((x,cs,reverse os):xs) ws) init [] ws of +runEvalMWithInput :: Globals -> [(Choice,Int)] -> EvalM a -> Check [(a, [OptionInfo])] +runEvalMWithInput g input (EvalM f) = Check $ \(es,ws) -> + case f g (\x (State _ cs mvs os) xs ws -> Success ((x,reverse os):xs) ws) init [] ws of Fail msg ws -> Fail msg (es,ws) Success xs ws -> Success (reverse xs) (es,ws) where - init = State cs Map.empty [] + init = State input Map.empty Map.empty [] reset :: EvalM a -> EvalM [a] reset (EvalM f) = EvalM $ \g k state r ws -> @@ -752,32 +730,32 @@ globals :: EvalM Globals globals = EvalM (\g k -> k g) variants :: Choice -> [a] -> EvalM a -variants c xs = EvalM (\g k state@(State choices metas opts) r msgs -> +variants c xs = EvalM (\g k state@(State input choices metas opts) r msgs -> case Map.lookup c choices of Just j -> k (xs !! j) state r msgs - Nothing -> backtrack 0 xs k choices metas opts r msgs) + Nothing -> backtrack 0 xs k input choices metas opts r msgs) where - backtrack j [] k choices metas opts r msgs = Success r msgs - backtrack j (x:xs) k choices metas opts r msgs = - case k x (State (Map.insert c j choices) metas opts) r msgs of + backtrack j [] k input choices metas opts r msgs = Success r msgs + backtrack j (x:xs) k input choices metas opts r msgs = + case k x (State input (Map.insert c j choices) metas opts) r msgs of Fail msg msgs -> Fail msg msgs - Success r msgs -> backtrack (j+1) xs k choices metas opts r msgs + Success r msgs -> backtrack (j+1) xs k input choices metas opts r msgs variants' :: Choice -> (a -> EvalM Term) -> [a] -> EvalM Term -variants' c f xs = EvalM (\g k state@(State choices metas opts) r msgs -> +variants' c f xs = EvalM (\g k state@(State input choices metas opts) r msgs -> case Map.lookup c choices of Just j -> case f (xs !! j) of EvalM f -> f g k state r msgs - Nothing -> case backtrack g 0 xs choices metas opts [] msgs of + Nothing -> case backtrack g 0 xs input choices metas opts [] msgs of Fail msg msgs -> Fail msg msgs Success ts msgs -> k (FV (reverse ts)) state r msgs) where - backtrack g j [] choices metas opts ts msgs = Success ts msgs - backtrack g j (x:xs) choices metas opts ts msgs = + backtrack g j [] input choices metas opts ts msgs = Success ts msgs + backtrack g j (x:xs) input choices metas opts ts msgs = case f x of - EvalM f -> case f g (\t st ts msgs -> Success (t:ts) msgs) (State (Map.insert c j choices) metas opts) ts msgs of + EvalM f -> case f g (\t st ts msgs -> Success (t:ts) msgs) (State input (Map.insert c j choices) metas opts) ts msgs of Fail msg msgs -> Fail msg msgs - Success ts msgs -> backtrack g (j+1) xs choices metas opts ts msgs + Success ts msgs -> backtrack g (j+1) xs input choices metas opts ts msgs try :: Int -> (a -> EvalM b) -> ([b] -> EvalM b) -> [a] -> EvalM b try sz f select xs = EvalM (\g k state r msgs -> @@ -801,9 +779,9 @@ try sz f select xs = EvalM (\g k state r msgs -> Nothing -> ms newResiduation :: Scope -> EvalM MetaId -newResiduation scope = EvalM (\g k (State choices metas opts) r msgs -> +newResiduation scope = EvalM (\g k (State input choices metas opts) r msgs -> let meta_id = Map.size metas+1 - in k meta_id (State choices (Map.insert meta_id (Residuation scope) metas) opts) r msgs) + in k meta_id (State input choices (Map.insert meta_id (Residuation scope) metas) opts) r msgs) checkpoint :: EvalM Int checkpoint = EvalM (\g k state r msgs -> @@ -816,8 +794,8 @@ getMeta i = EvalM (\g k state r msgs -> Nothing -> Fail ("Metavariable ?"<>pp i<+>"is not defined") msgs) setMeta :: MetaId -> MetaState -> EvalM () -setMeta i ms = EvalM (\g k (State choices metas opts) r msgs -> - let state' = State choices (Map.insert i ms metas) opts +setMeta i ms = EvalM (\g k (State input choices metas opts) r msgs -> + let state' = State input choices (Map.insert i ms metas) opts in k () state' r msgs) value2termM :: Bool -> [Ident] -> Value -> EvalM Term @@ -920,14 +898,20 @@ value2termM flat xs (VGlue v1 v2) = do value2termM True xs (VFV i (VarFree vs)) = do v <- variants i vs value2termM True xs v -value2termM False xs (VFV i (VarFree vs)) = variants' i (value2termM False xs) vs -value2termM flat xs (VFV i (VarOpts n os)) = - EvalM $ \g k (State choices metas opts) r msgs -> - let j = fromMaybe 0 (Map.lookup i choices) +value2termM False xs (VFV c (VarFree vs)) = variants' c (value2termM False xs) vs +value2termM flat xs (VFV c (VarOpts n os)) = + EvalM $ \g k (State input choices metas opts) r msgs -> + let (j,input',choices',opts') = + case Map.lookup c choices of + Just j -> (j,input,choices,opts) + Nothing -> case input of + (c',j):input | c == c' -> let oi = OptionInfo c j n (map fst os) + in (j,input,Map.insert c j choices,oi:opts) + _ -> let oi = OptionInfo c 0 n (map fst os) + in (0,[],Map.insert c 0 choices,oi:opts) in case os `maybeAt` j of Just (l,t) -> case value2termM flat xs t of - EvalM f -> let oi = OptionInfo i n (map fst os) - in f g k (State choices metas (oi:opts)) r msgs + EvalM f -> f g k (State input' choices' metas opts') r msgs Nothing -> Fail ("Index" <+> j <+> "out of bounds for option:" $$ ppValue Unqualified 0 n) msgs value2termM flat xs (VPatt min max p) = return (EPatt min max p) value2termM flat xs (VPattType v) = do t <- value2termM flat xs v @@ -1104,7 +1088,7 @@ value2string' g VEmpty b ws qs = Const (b,ws,qs) value2string' g (VC v1 v2) b ws qs = concat v1 (value2string' g v2 b ws qs) where concat v1 (Const (b,ws,qs)) = value2string' g v1 b ws qs - concat v1 (CFV i vs) = CFV i (mapConstVs (concat v1) vs) + concat v1 (CFV c vs) = CFV c (mapVariants (concat v1) vs) concat v1 res = res value2string' g (VApp c q []) b ws qs | q == (cPredef,cNonExist) = NonExist @@ -1138,7 +1122,7 @@ value2string' g (VAlts vd vas) b ws qs = | or [startsWith s w | VStr s <- ss] = value2string' g v | otherwise = pre vd vas w value2string' g (VFV s vs) b ws qs = - CFV s (variants2consts (\v -> value2string' g v b ws qs) vs) + CFV s (mapVariants (\v -> value2string' g v b ws qs) vs) value2string' _ _ _ _ _ = RunTime startsWith [] _ = True @@ -1155,13 +1139,13 @@ string2value' (w:ws) = VC (VStr w) (string2value' ws) value2int g (VMeta i vs) = CSusp i (\v -> value2int g (apply g v vs)) value2int g (VSusp i k vs) = CSusp i (\v -> value2int g (apply g (k v) vs)) value2int g (VInt n) = Const n -value2int g (VFV s vs) = CFV s (variants2consts (value2int g) vs) +value2int g (VFV s vs) = CFV s (mapVariants (value2int g) vs) value2int g _ = RunTime value2float g (VMeta i vs) = CSusp i (\v -> value2float g (apply g v vs)) value2float g (VSusp i k vs) = CSusp i (\v -> value2float g (apply g (k v) vs)) value2float g (VFlt f) = Const f -value2float g (VFV s vs) = CFV s (variants2consts (value2float g) vs) +value2float g (VFV s vs) = CFV s (mapVariants (value2float g) vs) value2float g _ = RunTime value2expr g xs (VApp _ (m,f) vs) @@ -1175,6 +1159,7 @@ value2expr g xs (VClosure env s (Abs b x t)) = in fmap (EAbs b (showIdent x')) (value2expr g (x':xs) v) value2expr g xs (VInt n) = pure (ELit (LInt n)) value2expr g xs (VFlt f) = pure (ELit (LFlt f)) +value2expr g xs (VFV s vs) = CFV s (mapVariants (value2expr g xs) vs) value2expr g xs v = fmap (ELit . LStr) (value2string g v) newtype Choice = Choice { unchoice :: Integer } From adf042f2831295877ec75dd24b08f60b99b93ba6 Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Wed, 3 Sep 2025 12:47:05 +0000 Subject: [PATCH 08/14] identification: String=Str, Int=Predef.Int, Float=Predef.Float --- src/compiler/api/GF/Grammar/Lookup.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/compiler/api/GF/Grammar/Lookup.hs b/src/compiler/api/GF/Grammar/Lookup.hs index c2eb5d6d1..30d581c72 100644 --- a/src/compiler/api/GF/Grammar/Lookup.hs +++ b/src/compiler/api/GF/Grammar/Lookup.hs @@ -68,7 +68,11 @@ lookupIdentInfo (m,ModPGF{mpgf=pgf}) i = Nothing -> notFound i where cnvType xs (PGF2.DTyp hypos cat es) = - appHypos hypos xs (QC (m,identS cat)) es + let t | cat == "String" = Sort cStr + | cat == "Int" = QC (cPredef,cInt) + | cat == "Float" = QC (cPredef,cFloat) + | otherwise = QC (m,identS cat) + in appHypos hypos xs t es appHypos [] xs t es = foldl (appExpr xs) t es From 5ce60c745b1be4d2b32379406ccf3e766a67404a Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Thu, 4 Sep 2025 14:12:59 +0000 Subject: [PATCH 09/14] added minimal implementation for XML parsing --- src/compiler/api/GF/Data/XML.hs | 232 +++++++++++++++++++++++++++++++- 1 file changed, 230 insertions(+), 2 deletions(-) diff --git a/src/compiler/api/GF/Data/XML.hs b/src/compiler/api/GF/Data/XML.hs index 933dc243a..cd9b18339 100644 --- a/src/compiler/api/GF/Data/XML.hs +++ b/src/compiler/api/GF/Data/XML.hs @@ -1,11 +1,13 @@ ----------------------------------------------------------------------- + ---------------------------------------------------------------------- -- | -- Module : XML -- -- Utilities for creating XML documents. ---------------------------------------------------------------------- -module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML) where +module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML, parseXML) where +import Data.Char(isSpace) +import Numeric (readHex) import GF.Data.Utilities data XML = Data String | Tag String [Attr] [XML] | ETag String [Attr] | Comment String | Empty @@ -54,3 +56,229 @@ escape = concatMap escChar bottomUpXML :: (XML -> XML) -> XML -> XML bottomUpXML f (Tag n attrs cs) = f (Tag n attrs (map (bottomUpXML f) cs)) bottomUpXML f x = f x + + +-- Lexer ----------------------------------------------------------------------- + +type Line = Integer +type LChar = (Line,Char) +type LString = [LChar] +data Token = TokStart Line String [Attr] Bool -- is empty? + | TokEnd Line String + | TokCRef String + | TokText String + deriving Show + +tokens :: String -> [Token] +tokens = tokens' . linenumber 1 + +tokens' :: LString -> [Token] +tokens' ((_,'<') : c@(_,'!') : cs) = special c cs + +tokens' ((_,'<') : cs) = tag (dropSpace cs) -- we are being nice here +tokens' [] = [] +tokens' cs@((l,_):_) = let (as,bs) = breakn ('<' ==) cs + in map cvt (decode_text as) ++ tokens' bs + + -- XXX: Note, some of the lines might be a bit inacuarate + where cvt (TxtBit x) = TokText x + cvt (CRefBit x) = case cref_to_char x of + Just c -> TokText [c] + Nothing -> TokCRef x + + +special :: LChar -> LString -> [Token] +special _ ((_,'-') : (_,'-') : cs) = skip cs + where skip ((_,'-') : (_,'-') : (_,'>') : ds) = tokens' ds + skip (_ : ds) = skip ds + skip [] = [] -- unterminated comment + +special c ((_,'[') : (_,'C') : (_,'D') : (_,'A') : (_,'T') : (_,'A') : (_,'[') + : cs) = + let (xs,ts) = cdata cs + in TokText xs : tokens' ts + where cdata ((_,']') : (_,']') : (_,'>') : ds) = ([],ds) + cdata ((_,d) : ds) = let (xs,ys) = cdata ds in (d:xs,ys) + cdata [] = ([],[]) + +special c cs = + let (xs,ts) = munch "" 0 cs + in TokText ('<':'!':(reverse xs)) : tokens' ts + where munch acc nesting ((_,'>') : ds) + | nesting == (0::Int) = ('>':acc,ds) + | otherwise = munch ('>':acc) (nesting-1) ds + munch acc nesting ((_,'<') : ds) + = munch ('<':acc) (nesting+1) ds + munch acc n ((_,x) : ds) = munch (x:acc) n ds + munch acc _ [] = (acc,[]) -- unterminated DTD markup + +--special c cs = tag (c : cs) -- invalid specials are processed as tags + +linenumber :: Integer -> String -> LString +linenumber n s = + case s of + [] -> [] + ('\r':s') -> case s' of + ('\n':s'') -> next s'' + _ -> next s' + ('\n':s') -> next s' + (c :s') -> (n,c) : linenumber n s' + where + next s' = n' `seq` ((n,'\n'):linenumber n' s') where n' = n + 1 + + +qualName :: LString -> (String,LString) +qualName xs = breakn endName xs + where endName x = isSpace x || x == '=' || x == '>' || x == '/' + + + + + +tag :: LString -> [Token] +tag ((p,'/') : cs) = let (n,ds) = qualName (dropSpace cs) + in TokEnd p n : case (dropSpace ds) of + (_,'>') : es -> tokens' es + -- tag was not properly closed... + _ -> tokens' ds +tag [] = [] +tag cs = let (n,ds) = qualName cs + (as,b,ts) = attribs (dropSpace ds) + in TokStart (fst (head cs)) n as b : ts + +attribs :: LString -> ([Attr], Bool, [Token]) +attribs cs = case cs of + (_,'>') : ds -> ([], False, tokens' ds) + + (_,'/') : ds -> ([], True, case ds of + (_,'>') : es -> tokens' es + -- insert missing > ... + _ -> tokens' ds) + + (_,'?') : (_,'>') : ds -> ([], True, tokens' ds) + + -- doc ended within a tag.. + [] -> ([],False,[]) + + _ -> let (a,cs1) = attrib cs + (as,b,ts) = attribs cs1 + in (a:as,b,ts) + +attrib :: LString -> (Attr,LString) +attrib cs = let (ks,cs1) = qualName cs + (vs,cs2) = attr_val (dropSpace cs1) + in ((ks,decode_attr vs),dropSpace cs2) + +attr_val :: LString -> (String,LString) +attr_val ((_,'=') : cs) = string (dropSpace cs) +attr_val cs = ("",cs) + + +dropSpace :: LString -> LString +dropSpace = dropWhile (isSpace . snd) + +-- | Match the value for an attribute. For malformed XML we do +-- our best to guess the programmer's intention. +string :: LString -> (String,LString) +string ((_,'"') : cs) = break' ('"' ==) cs + +-- Allow attributes to be enclosed between ' '. +string ((_,'\'') : cs) = break' ('\'' ==) cs + +-- Allow attributes that are not enclosed by anything. +string cs = breakn eos cs + where eos x = isSpace x || x == '>' || x == '/' + + +break' :: (a -> Bool) -> [(b,a)] -> ([a],[(b,a)]) +break' p xs = let (as,bs) = breakn p xs + in (as, case bs of + [] -> [] + _ : cs -> cs) + +breakn :: (a -> Bool) -> [(b,a)] -> ([a],[(b,a)]) +breakn p l = (map snd as,bs) where (as,bs) = break (p . snd) l + + + +decode_attr :: String -> String +decode_attr cs = concatMap cvt (decode_text cs) + where cvt (TxtBit x) = x + cvt (CRefBit x) = case cref_to_char x of + Just c -> [c] + Nothing -> '&' : x ++ ";" + +data Txt = TxtBit String | CRefBit String deriving Show + +decode_text :: [Char] -> [Txt] +decode_text xs@('&' : cs) = case break (';' ==) cs of + (as,_:bs) -> CRefBit as : decode_text bs + _ -> [TxtBit xs] +decode_text [] = [] +decode_text cs = let (as,bs) = break ('&' ==) cs + in TxtBit as : decode_text bs + +cref_to_char :: [Char] -> Maybe Char +cref_to_char cs = case cs of + '#' : ds -> num_esc ds + "lt" -> Just '<' + "gt" -> Just '>' + "amp" -> Just '&' + "apos" -> Just '\'' + "quot" -> Just '"' + _ -> Nothing + +num_esc :: String -> Maybe Char +num_esc cs = case cs of + 'x' : ds -> check (readHex ds) + _ -> check (reads cs) + + where check [(n,"")] = cvt_char n + check _ = Nothing + +cvt_char :: Int -> Maybe Char +cvt_char x + | fromEnum (minBound :: Char) <= x && x <= fromEnum (maxBound::Char) + = Just (toEnum x) + | otherwise = Nothing + + +-- Parser -------------------------------------------------------------- + +-- | parseXML to a list of content chunks +parseXML :: String -> [XML] +parseXML = parse . tokens + +------------------------------------------------------------------------ + +parse :: [Token] -> [XML] +parse [] = [] +parse ts = let (es,_,ts1) = nodes [] ts + in es ++ parse ts1 + +nodes :: [String] -> [Token] -> ([XML], [String], [Token]) +nodes ps (TokCRef ref : ts) = + let (es,qs,ts1) = nodes ps ts + in (Data ref : es, qs, ts1) +nodes ps (TokText txt : ts) = + let (es,qs,ts1) = nodes ps ts + (more,es1) = case es of + Data cd : es1' -> (cd,es1') + _ -> ([],es) + in (Data (txt ++ more) : es1, qs, ts1) +nodes ps (TokStart p t as empty : ts) = (node : siblings, open, toks) + where + (node,(siblings,open,toks)) + | empty = (ETag t as, nodes ps ts) + | otherwise = let (es1,qs1,ts1) = nodes (t:ps) ts + in (Tag t as es1, + case qs1 of + [] -> nodes ps ts1 + _ : qs3 -> ([],qs3,ts1)) +nodes ps (TokEnd p t : ts) = case break (t ==) ps of + (as,_:_) -> ([],as,ts) + -- Unknown closing tag. Insert as text. + (_,[]) -> + let (es,qs,ts1) = nodes ps ts + in (Data "" : es,qs,ts1) +nodes ps [] = ([],ps,[]) From 8467e2eb24173721954dedec1f7c6d77f7a22a19 Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Sun, 7 Sep 2025 20:46:08 +0200 Subject: [PATCH 10/14] added tabularLinearize --- src/runtime/python/pypgf.c | 57 ++++++++++++++++++++++++++++++++++++-- 1 file changed, 55 insertions(+), 2 deletions(-) diff --git a/src/runtime/python/pypgf.c b/src/runtime/python/pypgf.c index 7e90c51ad..50803a58c 100644 --- a/src/runtime/python/pypgf.c +++ b/src/runtime/python/pypgf.c @@ -355,6 +355,59 @@ PgfLinearizationOutputIfaceVtbl pypgf_lin_out_iface_vtbl = (void*) pypgf_lin_out_flush }; +static PyObject* +Concr_tabularLinearize(ConcrObject* self, PyObject *args) +{ + ExprObject* pyexpr; + if (!PyArg_ParseTuple(args, "O!", &pgf_ExprType, &pyexpr)) + return NULL; + + PgfExn err; + PgfText **texts = + pgf_tabular_linearize(self->grammar->db, self->concr, (PgfExpr) pyexpr, NULL, + &marshaller, &err); + if (handleError(err) != PGF_EXN_NONE) { + return NULL; + } + + if (texts == NULL) { + Py_RETURN_NONE; + } + + PyObject *res = PyList_New(0); + if (!res) + goto fail; + + while (texts[0] != NULL && texts[1] != NULL) { + PyObject* pyfield = PyUnicode_FromStringAndSize(texts[0]->text, texts[0]->size); + free(texts[0]); texts++; + if (!pyfield) + goto fail; + + PyObject* pylin = PyUnicode_FromStringAndSize(texts[0]->text, texts[0]->size); + free(texts[0]); texts++; + if (!pylin) + goto fail; + + PyObject *tup = PyTuple_New(2); + PyTuple_SetItem(tup, 0, pyfield); + PyTuple_SetItem(tup, 1, pylin); + PyList_Append(res, tup); + Py_DECREF(tup); + } + + return res; + +fail: + Py_XDECREF(res); + + while (texts[0]) { + free(texts[0]); texts++; + } + + return NULL; +} + static PyObject* Concr_bracketedLinearize(ConcrObject* self, PyObject *args) { @@ -548,10 +601,10 @@ static PyMethodDef Concr_methods[] = { }, /*{"linearizeAll", (PyCFunction)Concr_linearizeAll, METH_VARARGS | METH_KEYWORDS, "Takes an abstract tree and linearizes with all variants" - }, + },*/ {"tabularLinearize", (PyCFunction)Concr_tabularLinearize, METH_VARARGS, "Takes an abstract tree and linearizes it to a table containing all fields" - },*/ + }, {"bracketedLinearize", (PyCFunction)Concr_bracketedLinearize, METH_VARARGS, "Takes an abstract tree and linearizes it to a bracketed string" }, From cc0a56cc480b1915e3926e0d8ba2dcce390e2a38 Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Tue, 9 Sep 2025 19:35:32 +0200 Subject: [PATCH 11/14] fix space leak in functions and functionsByCat --- src/runtime/python/pypgf.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/runtime/python/pypgf.c b/src/runtime/python/pypgf.c index 50803a58c..020171991 100644 --- a/src/runtime/python/pypgf.c +++ b/src/runtime/python/pypgf.c @@ -945,8 +945,8 @@ _collect_funs(PgfItor *fn, PgfText *key, object value, PgfExn *err) if (PyList_Append((PyObject*) clo->collection, py_name) != 0) { err->type = PGF_EXN_OTHER_ERROR; - Py_DECREF(py_name); } + Py_DECREF(py_name); } static PyObject * From 570d223302ede41affbbaa44ed9d311eccbfb5d7 Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Tue, 9 Sep 2025 19:48:38 +0200 Subject: [PATCH 12/14] space leak in _collect_cats --- src/runtime/python/pypgf.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/runtime/python/pypgf.c b/src/runtime/python/pypgf.c index 020171991..44f42ff22 100644 --- a/src/runtime/python/pypgf.c +++ b/src/runtime/python/pypgf.c @@ -859,8 +859,8 @@ _collect_cats(PgfItor *fn, PgfText *key, object value, PgfExn *err) if (PyList_Append((PyObject*) clo->collection, py_name) != 0) { err->type = PGF_EXN_OTHER_ERROR; - Py_DECREF(py_name); } + Py_DECREF(py_name); } static PyObject * From ae9ac01e00933e43030e5404333f71fb9e1878ae Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Tue, 16 Sep 2025 19:47:34 +0200 Subject: [PATCH 13/14] remove deprecated module --- src/compiler/api/GF/Grammar/PatternMatch.hs | 183 -------------------- src/compiler/gf.cabal | 1 - 2 files changed, 184 deletions(-) delete mode 100644 src/compiler/api/GF/Grammar/PatternMatch.hs diff --git a/src/compiler/api/GF/Grammar/PatternMatch.hs b/src/compiler/api/GF/Grammar/PatternMatch.hs deleted file mode 100644 index 53a99fe56..000000000 --- a/src/compiler/api/GF/Grammar/PatternMatch.hs +++ /dev/null @@ -1,183 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PatternMatch --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/12 12:38:29 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.7 $ --- --- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003 ------------------------------------------------------------------------------ - -module GF.Grammar.PatternMatch ( - matchPattern, - testOvershadow, - findMatch - ) where - -import GF.Data.Operations -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Grammar.Macros ---import GF.Grammar.Printer - -import Data.Maybe(fromMaybe) -import Control.Monad -import GF.Text.Pretty ---import Debug.Trace - -matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution) -matchPattern pts term = - if not (isInConstantForm term) - then raise (render ("variables occur in" <+> pp term)) - else do - term' <- mkK term - errIn (render ("trying patterns" <+> hsep (punctuate ',' (map fst pts)))) $ - findMatch [([p],t) | (p,t) <- pts] [term'] - where - -- to capture all Str with string pattern matching - mkK s = case s of - C _ _ -> do - s' <- getS s - return (K (unwords s')) - _ -> return s - - getS s = case s of - K w -> return [w] - C v w -> liftM2 (++) (getS v) (getS w) - Empty -> return [] - _ -> raise (render ("cannot get string from" <+> s)) - -testOvershadow :: ErrorMonad m => [Patt] -> [Term] -> m [Patt] -testOvershadow pts vs = do - let numpts = zip pts [0..] - let cases = [(p,EInt i) | (p,i) <- numpts] - ts <- mapM (liftM fst . matchPattern cases) vs - return [p | (p,i) <- numpts, notElem i [i | EInt i <- ts] ] - -findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution) -findMatch cases terms = case cases of - [] -> raise (render ("no applicable case for" <+> hsep (punctuate ',' terms))) - (patts,_):_ | length patts /= length terms -> - raise (render ("wrong number of args for patterns :" <+> hsep patts <+> - "cannot take" <+> hsep terms)) - (patts,val):cc -> case mapM tryMatch (zip patts terms) of - Ok substs -> return (val, concat substs) - _ -> findMatch cc terms - -tryMatch :: (Patt, Term) -> Err [(Ident, Term)] -tryMatch (p,t) = do - t' <- termForm t - trym p t' - where - trym p t' = - case (p,t') of --- (_,(x,Typed e ty,y)) -> trym p (x,e,y) -- Add this? /TH 2013-09-05 - (_,(x,Empty,y)) -> trym p (x,K [],y) -- because "" = [""] = [] - (PW, _) -> return [] -- optimization with wildcard - (PV x,([],K s,[])) -> return [(x,words2term (words s))] - (PV x, _) -> return [(x,t)] - (PString s, ([],K i,[])) | s==i -> return [] - (PInt s, ([],EInt i,[])) | s==i -> return [] - (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding? - (PC p pp, ([], Con f, tt)) | - p `eqStrIdent` f && length pp == length tt -> - do matches <- mapM tryMatch (zip pp tt) - return (concat matches) - - (PP (q,p) pp, ([], QC (r,f), tt)) | - -- q `eqStrIdent` r && --- not for inherited AR 10/10/2005 - p `eqStrIdent` f && length pp == length tt -> - do matches <- mapM tryMatch (zip pp tt) - return (concat matches) - ---- hack for AppPredef bug - (PP (q,p) pp, ([], Q (r,f), tt)) | - -- q `eqStrIdent` r && --- - p `eqStrIdent` f && length pp == length tt -> - do matches <- mapM tryMatch (zip pp tt) - return (concat matches) - - (PR r, ([],R r',[])) | - all (`elem` map fst r') (map fst r) -> - do matches <- mapM tryMatch - [(p,snd a) | (l,p) <- r, let Just a = lookup l r'] - return (concat matches) - (PT _ p',_) -> trym p' t' - - (PAs x p',([],K s,[])) -> do - subst <- trym p' t' - return $ (x,words2term (words s)) : subst - - (PAs x p',_) -> do - subst <- trym p' t' - return $ (x,t) : subst - - (PAlt p1 p2,_) -> checks [trym p1 t', trym p2 t'] - - (PNeg p',_) -> case tryMatch (p',t) of - Bad _ -> return [] - _ -> raise (render ("no match with negative pattern" <+> p)) - - (PSeq min1 max1 p1 min2 max2 p2, ([],K s, [])) -> matchPSeq min1 max1 p1 min2 max2 p2 s - - (PRep _ _ p1, ([],K s, [])) -> checks [ - trym (foldr (const (PSeq 0 Nothing p1 0 Nothing)) (PString "") - [1..n]) t' | n <- [0 .. length s] - ] >> - return [] - - (PChar, ([],K [_], [])) -> return [] - (PChars cs, ([],K [c], [])) | elem c cs -> return [] - - _ -> raise (render ("no match in case expr for" <+> t)) - - words2term [] = Empty - words2term [w] = K w - words2term (w:ws) = C (K w) (words2term ws) - -matchPSeq min1 max1 p1 min2 max2 p2 s = - do let n = length s - lo = min1 `max` (n-fromMaybe n max2) - hi = (n-min2) `min` (fromMaybe n max1) - cuts = [splitAt i s | i <- [lo..hi]] - matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts] - return (concat matches) - -isInConstantForm :: Term -> Bool -isInConstantForm trm = case trm of - Cn _ -> True - Con _ -> True - Q _ -> True - QC _ -> True - Abs _ _ _ -> True - C c a -> isInConstantForm c && isInConstantForm a - App c a -> isInConstantForm c && isInConstantForm a - R r -> all (isInConstantForm . snd . snd) r - K _ -> True - Empty -> True - EInt _ -> True - V ty ts -> isInConstantForm ty && all isInConstantForm ts -- TH 2013-09-05 --- Typed e t-> isInConstantForm e && isInConstantForm t -- Add this? TH 2013-09-05 - - _ -> False ---- isInArgVarForm trm -{- -- unused and suspicuous, see contP in GF.Compile.Compute.Concrete instead -varsOfPatt :: Patt -> [Ident] -varsOfPatt p = case p of - PV x -> [x] - PC _ ps -> concat $ map varsOfPatt ps - PP _ ps -> concat $ map varsOfPatt ps - PR r -> concat $ map (varsOfPatt . snd) r - PT _ q -> varsOfPatt q - _ -> [] - --- | to search matching parameter combinations in tables -isMatchingForms :: [Patt] -> [Term] -> Bool -isMatchingForms ps ts = all match (zip ps ts') where - match (PC c cs, (Cn d, ds)) = c == d && isMatchingForms cs ds - match _ = True - ts' = map appForm ts - --} diff --git a/src/compiler/gf.cabal b/src/compiler/gf.cabal index a4f6bd7cf..e79a7fdad 100644 --- a/src/compiler/gf.cabal +++ b/src/compiler/gf.cabal @@ -146,7 +146,6 @@ library GF.Grammar.Lookup GF.Grammar.Macros GF.Grammar.Parser - GF.Grammar.PatternMatch GF.Grammar.Predef GF.Grammar.Printer GF.Grammar.ShowTerm From cd5ef68b4da595c2b19aa767dfb49924212923f4 Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Tue, 16 Sep 2025 19:52:04 +0200 Subject: [PATCH 14/14] Variants is a functor --- .../api/GF/Compile/Compute/Concrete2.hs | 50 +++++++++---------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs index 3cfb3f772..1af64bf83 100644 --- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs +++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs @@ -3,7 +3,7 @@ module GF.Compile.Compute.Concrete2 (Env, Scope, Value(..), Variants(..), OptionInfo(..), ConstValue(..), Globals(..), PredefTable, EvalM, - mapVariants, mapVariantsC, unvariants, + mapVariantsC, unvariants, runEvalM, runEvalMWithInput, stdPredef, globals, PredefImpl, Predef(..), ($\), pdCanonicalArgs, pdArity, @@ -97,9 +97,9 @@ data Variants a = VarFree [a] | VarOpts Value [(Value, a)] -mapVariants :: (a -> b) -> Variants a -> Variants b -mapVariants f (VarFree vs) = VarFree (f <$> vs) -mapVariants f (VarOpts n cs) = VarOpts n (second f <$> cs) +instance Functor Variants where + fmap f (VarFree vs) = VarFree (f <$> vs) + fmap f (VarOpts n cs) = VarOpts n (second f <$> cs) mapVariantsC :: (Choice -> a -> b) -> Choice -> Variants a -> Variants b mapVariantsC f c (VarFree vs) = VarFree (mapC f c vs) @@ -139,7 +139,7 @@ data ConstValue a instance Functor ConstValue where fmap f (Const c) = Const (f c) - fmap f (CFV i vs) = CFV i (mapVariants (fmap f) vs) + fmap f (CFV i vs) = CFV i (fmap (fmap f) vs) fmap f (CSusp i k) = CSusp i (fmap f . k) fmap f RunTime = RunTime fmap f NonExist = NonExist @@ -148,8 +148,8 @@ instance Applicative ConstValue where pure = Const (Const f) <*> (Const x) = Const (f x) - (CFV s vs) <*> v2 = CFV s (mapVariants (<*> v2) vs) - v1 <*> (CFV s vs) = CFV s (mapVariants (v1 <*>) vs) + (CFV s vs) <*> v2 = CFV s (fmap (<*> v2) vs) + v1 <*> (CFV s vs) = CFV s (fmap (v1 <*>) vs) (CSusp i k) <*> v2 = CSusp i (\v -> k v <*> v2) v1 <*> (CSusp i k) = CSusp i (\v -> v1 <*> k v) NonExist <*> _ = NonExist @@ -192,7 +192,7 @@ eval g env s (P t lbl) vs = let project (VR as) = case lookup lbl a Nothing -> VError ("Missing value for label" <+> pp lbl $$ "in" <+> pp (P t lbl)) Just v -> apply g v vs - project (VFV s fvs) = VFV s (mapVariants project fvs) + project (VFV s fvs) = VFV s (fmap project fvs) project (VMeta i vs) = VSusp i (\v -> project (apply g v vs)) [] project (VSusp i k vs) = VSusp i (\v -> project (apply g (k v) vs)) [] project v = VP v lbl vs @@ -201,8 +201,8 @@ eval g env s (ExtR t1 t2) [] = let (s1,s2) = split s extend (VR as1) (VR as2) = VR (foldl (\as (lbl,v) -> update lbl v as) as1 as2) extend (VRecType as1 e1) (VRecType as2 e2)=VRecType (foldl (\as (lbl,o,v) -> update3 lbl o v as) as1 as2) (e1 || e2) - extend (VFV i fvs) v2 = VFV i (mapVariants (`extend` v2) fvs) - extend v1 (VFV i fvs) = VFV i (mapVariants (v1 `extend`) fvs) + extend (VFV i fvs) v2 = VFV i (fmap (`extend` v2) fvs) + extend v1 (VFV i fvs) = VFV i (fmap (v1 `extend`) fvs) extend (VMeta i vs) v2 = VSusp i (\v -> extend (apply g v vs) v2) [] extend v1 (VMeta i vs) = VSusp i (\v -> extend v1 (apply g v vs)) [] extend (VSusp i k vs) v2 = VSusp i (\v -> extend (apply g (k v) vs) v2) [] @@ -230,7 +230,7 @@ eval g env s (S t1 t2) vs = let (!s1,!s2) = split s Success tys ws -> case tys of [ty] -> vtableSelect g v0 ty tvs v2 vs tys -> vtableSelect g v0 (FV (reverse tys)) tvs v2 vs - select (VFV i fvs) = VFV i (mapVariants select fvs) + select (VFV i fvs) = VFV i (fmap select fvs) select (VMeta i vs) = VSusp i (\v -> select (apply g v vs)) [] select (VSusp i k vs) = VSusp i (\v -> select (apply g (k v) vs)) [] select v1 = v0 @@ -253,8 +253,8 @@ eval g env s (C t1 t2) [] = let (!s1,!s2) = split s concat v1 VEmpty = v1 concat VEmpty v2 = v2 - concat (VFV i fvs) v2 = VFV i (mapVariants (`concat` v2) fvs) - concat v1 (VFV i fvs) = VFV i (mapVariants (v1 `concat`) fvs) + concat (VFV i fvs) v2 = VFV i (fmap (`concat` v2) fvs) + concat v1 (VFV i fvs) = VFV i (fmap (v1 `concat`) fvs) concat (VMeta i vs) v2 = VSusp i (\v -> concat (apply g v vs) v2) [] concat v1 (VMeta i vs) = VSusp i (\v -> concat v1 (apply g v vs)) [] concat (VSusp i k vs) v2 = VSusp i (\v -> concat (apply g (k v) vs) v2) [] @@ -276,8 +276,8 @@ eval g env s (Glue t1 t2) [] = let (!s1,!s2) = split s glue v (VAlts d vas) = VAlts (glue v d) [(glue v v',ss) | (v',ss) <- vas] glue (VAlts d vas) (VStr s) = pre d vas s glue (VAlts d vas) v = glue d v - glue (VFV i fvs) v2 = VFV i (mapVariants (`glue` v2) fvs) - glue v1 (VFV i fvs) = VFV i (mapVariants (v1 `glue`) fvs) + glue (VFV i fvs) v2 = VFV i (fmap (`glue` v2) fvs) + glue v1 (VFV i fvs) = VFV i (fmap (v1 `glue`) fvs) glue (VMeta i vs) v2 = VSusp i (\v -> glue (apply g v vs) v2) [] glue v1 (VMeta i vs) = VSusp i (\v -> glue v1 (apply g v vs)) [] glue (VSusp i k vs) v2 = VSusp i (\v -> glue (apply g (k v) vs) v2) [] @@ -327,7 +327,7 @@ evalPredef g@(Gl gr pds) c n args = case Map.lookup n pds of Nothing -> VApp c (cPredef,n) args Just def -> let valueOf (Const res) = res - valueOf (CFV i vs) = VFV i (mapVariants valueOf vs) + valueOf (CFV i vs) = VFV i (fmap valueOf vs) valueOf (CSusp i k) = VSusp i (valueOf . k) [] valueOf RunTime = VApp c (cPredef,n) args valueOf NonExist = VApp c (cPredef,cNonExist) [] @@ -362,7 +362,7 @@ apply g (VApp c f@(m,n) vs0) vs | m == cPredef = evalPredef g c n (vs0++vs) | otherwise = VApp c f (vs0++vs) apply g (VGen i vs0) vs = VGen i (vs0++vs) -apply g (VFV i fvs) vs = VFV i (mapVariants (\v -> apply g v vs) fvs) +apply g (VFV i fvs) vs = VFV i (fmap (\v -> apply g v vs) fvs) apply g (VS v1 v2 vs') vs = VS v1 v2 (vs'++vs) apply g (VClosure env s (Abs b x t)) (v:vs) = eval g ((x,v):env) s t vs apply g v [] = v @@ -546,7 +546,7 @@ patternMatch g s v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0 (p, VMeta i vs) -> VSusp i (\v -> match' env p ps eqs (apply g v vs) args) [] (p, VGen i vs) -> v0 (p, VSusp i k vs) -> VSusp i (\v -> match' env p ps eqs (apply g (k v) vs) args) [] - (p, VFV s vs) -> VFV s (mapVariants (\arg -> match' env p ps eqs arg args) vs) + (p, VFV s vs) -> VFV s (fmap (\arg -> match' env p ps eqs arg args) vs) (PP q qs, VApp c r vs) | q == r -> match env (qs++ps) eqs (vs++args) (PR pas, VR as) -> matchRec env (reverse pas) as ps eqs args @@ -605,7 +605,7 @@ vtableSelect g v0 ty cs v2 vs = where select (Const (i,_)) = cs !! i select (CSusp i k) = VSusp i (\v -> select (k v)) [] - select (CFV c vs) = VFV c (mapVariants select vs) + select (CFV c vs) = VFV c (fmap select vs) select _ = v0 value2index (VMeta i vs) ty = CSusp i (\v -> value2index (apply g v vs) ty) @@ -645,7 +645,7 @@ vtableSelect g v0 ty cs v2 vs = Gl gr _ = g value2index (VInt n) ty | Just max <- isTypeInts ty = Const (fromIntegral n,fromIntegral max+1) - value2index (VFV c vs) ty = CFV c (mapVariants (\v -> value2index v ty) vs) + value2index (VFV c vs) ty = CFV c (fmap (\v -> value2index v ty) vs) value2index v ty = RunTime @@ -1088,7 +1088,7 @@ value2string' g VEmpty b ws qs = Const (b,ws,qs) value2string' g (VC v1 v2) b ws qs = concat v1 (value2string' g v2 b ws qs) where concat v1 (Const (b,ws,qs)) = value2string' g v1 b ws qs - concat v1 (CFV c vs) = CFV c (mapVariants (concat v1) vs) + concat v1 (CFV c vs) = CFV c (fmap (concat v1) vs) concat v1 res = res value2string' g (VApp c q []) b ws qs | q == (cPredef,cNonExist) = NonExist @@ -1122,7 +1122,7 @@ value2string' g (VAlts vd vas) b ws qs = | or [startsWith s w | VStr s <- ss] = value2string' g v | otherwise = pre vd vas w value2string' g (VFV s vs) b ws qs = - CFV s (mapVariants (\v -> value2string' g v b ws qs) vs) + CFV s (fmap (\v -> value2string' g v b ws qs) vs) value2string' _ _ _ _ _ = RunTime startsWith [] _ = True @@ -1139,13 +1139,13 @@ string2value' (w:ws) = VC (VStr w) (string2value' ws) value2int g (VMeta i vs) = CSusp i (\v -> value2int g (apply g v vs)) value2int g (VSusp i k vs) = CSusp i (\v -> value2int g (apply g (k v) vs)) value2int g (VInt n) = Const n -value2int g (VFV s vs) = CFV s (mapVariants (value2int g) vs) +value2int g (VFV s vs) = CFV s (fmap (value2int g) vs) value2int g _ = RunTime value2float g (VMeta i vs) = CSusp i (\v -> value2float g (apply g v vs)) value2float g (VSusp i k vs) = CSusp i (\v -> value2float g (apply g (k v) vs)) value2float g (VFlt f) = Const f -value2float g (VFV s vs) = CFV s (mapVariants (value2float g) vs) +value2float g (VFV s vs) = CFV s (fmap (value2float g) vs) value2float g _ = RunTime value2expr g xs (VApp _ (m,f) vs) @@ -1159,7 +1159,7 @@ value2expr g xs (VClosure env s (Abs b x t)) = in fmap (EAbs b (showIdent x')) (value2expr g (x':xs) v) value2expr g xs (VInt n) = pure (ELit (LInt n)) value2expr g xs (VFlt f) = pure (ELit (LFlt f)) -value2expr g xs (VFV s vs) = CFV s (mapVariants (value2expr g xs) vs) +value2expr g xs (VFV s vs) = CFV s (fmap (value2expr g xs) vs) value2expr g xs v = fmap (ELit . LStr) (value2string g v) newtype Choice = Choice { unchoice :: Integer }