diff options
Diffstat (limited to 'src')
119 files changed, 18444 insertions, 0 deletions
diff --git a/src/GF.hs b/src/GF.hs new file mode 100644 index 000000000..a75f4ee0c --- /dev/null +++ b/src/GF.hs @@ -0,0 +1,78 @@ +module Main where + +import Operations +import UseIO +import Option +import IOGrammar +import ShellState +import Shell +import SubShell +import PShell +import JGF +import UTF8 + +import Today (today) +import Arch +import System (getArgs) + +-- AR 19/4/2000 -- 11/11/2001 + +main :: IO () +main = do + xs <- getArgs + let (os,fs) = getOptions "-" xs + java = oElem forJava os + putStrLn $ if java then encodeUTF8 welcomeMsg else welcomeMsg + st <- case fs of + f:_ -> useIOE emptyShellState (shellStateFromFiles os emptyShellState f) + _ -> return emptyShellState + if null fs then return () else putCPU + if java then sessionLineJ st else do + gfInteract (initHState st) + return () + +gfInteract :: HState -> IO HState +gfInteract st@(env,_) = do + -- putStrFlush "> " M.F 25/01-02 prompt moved to Arch. + (s,cs) <- getCommandLines + case ifImpure cs of + + -- these are the three impure commands + Just (ICQuit,_) -> do + putStrLn "See you." + return st + Just (ICExecuteHistory file,_) -> do + ss <- readFileIf file + let co = pCommandLines ss + st' <- execLinesH s co st + gfInteract st' + Just (ICEarlierCommand i,_) -> do + let line = earlierCommandH st i + co = pCommandLine $ words line + st' <- execLinesH line [co] st -- s would not work in execLinesH + gfInteract st' + Just (ICEditSession,os) -> + editSession (addOptions os opts) env >> gfInteract st +{- ----- + Just (ICTranslateSession,os) -> + translateSession (addOptions os opts) env >> gfInteract st +-} + -- this is a normal command sequence + _ -> do + st' <- execLinesH s cs st + gfInteract st' + where + opts = globalOptions env + +welcomeMsg = + "Welcome to " ++ authorMsg ++++ welcomeArch ++ "\n\nType 'h' for help." + +authorMsg = unlines [ + "Grammatical Framework, Version 2.0-- (incomplete functionality)", +--- "Compiled March 26, 2003", + "Compiled " ++ today, + "Copyright (c) Markus Forsberg, Thomas Hallgren, Kristofer Johannisson,", + "Janna Khegai, Peter Ljunglöf, Petri Mäenpää, and Aarne Ranta", + "1998-2003, under GNU General Public License (GPL)", + "Bug reports to aarne@cs.chalmers.se" + ] diff --git a/src/GF/API.hs b/src/GF/API.hs new file mode 100644 index 000000000..d2a60d24c --- /dev/null +++ b/src/GF/API.hs @@ -0,0 +1,267 @@ +module API where + +import qualified AbsGF as GF +import qualified AbsGFC as A +import qualified Rename as R +import GetTree +import GFC +import Values + +-----import GetGrammar +-----import Compile +import IOGrammar +import Linear +import Parsing +import Morphology +import PPrCF +import CFIdent +import PGrammar +import Randomized (mkRandomTree) +import Zipper + +import MMacros +import TypeCheck +import CMacros + +import Option +import Custom +import ShellState +import Linear +import GFC +import qualified Grammar as G +import PrGrammar +import qualified Compute as Co +import qualified Ident as I +import qualified GrammarToCanon as GC +import qualified CanonToGrammar as CG + +import Editing + +----import GrammarToXML + +----import GrammarToMGrammar as M + +import Arch (myStdGen) + +import UTF8 +import Operations +import UseIO + +import List (nub) +import Monad (liftM) +import System (system) + +-- Application Programmer's Interface to GF; also used by Shell. AR 10/11/2001 + +type GFGrammar = StateGrammar +type GFCat = CFCat +type Ident = I.Ident + +-- these are enough for many simple applications + +{- ----- +file2grammar :: FilePath -> IO GFGrammar +file2grammar = do + egr <- appIOE $ optFile2grammar (iOpts [beSilent]) + err putStrLn return egr +-} + +linearize :: GFGrammar -> Tree -> String +linearize sgr = err id id . optLinearizeTree opts sgr where + opts = addOption firstLin $ stateOptions sgr + +linearizeToAll :: [GFGrammar] -> Tree -> [String] +linearizeToAll grs t = [linearize gr t | gr <- grs] + +parse :: GFGrammar -> CFCat -> String -> [Tree] +parse sgr cat = errVal [] . parseString noOptions sgr cat + +parseAny :: [GFGrammar] -> CFCat -> String -> [Tree] +parseAny grs cat s = concat [parse gr cat s | gr <- grs] + +translate :: GFGrammar -> GFGrammar -> CFCat -> String -> [String] +translate ig og cat = map (linearize og) . parse ig cat + +translateToAll :: GFGrammar -> [GFGrammar] -> CFCat -> String -> [String] +translateToAll ig ogs cat = concat . map (linearizeToAll ogs) . parse ig cat + +translateFromAny :: [GFGrammar] -> GFGrammar -> CFCat -> String -> [String] +translateFromAny igs og cat s = concat [translate ig og cat s | ig <- igs] + +translateBetweenAll :: [GFGrammar] -> CFCat -> String -> [String] +translateBetweenAll grs cat = concat . map (linearizeToAll grs) . parseAny grs cat + +homonyms :: GFGrammar -> CFCat -> Tree -> [Tree] +homonyms gr cat = nub . parse gr cat . linearize gr + +hasAmbiguousLin :: GFGrammar -> CFCat -> Tree -> Bool +hasAmbiguousLin gr cat t = case (homonyms gr cat t) of + _:_:_ -> True + _ -> False + +{- ---- +-- returns printname if one exists; othewrise linearizes with metas +printOrLin :: GFGrammar -> Fun -> String +printOrLin gr = printOrLinearize (stateGrammarST gr) + +-- reads a syntax file and writes it in a format wanted +transformGrammarFile :: Options -> FilePath -> IO String +transformGrammarFile opts file = do + sy <- useIOE GF.emptySyntax $ getSyntax opts file + return $ optPrintSyntax opts sy +-} + +-- then stg for customizable and internal use + +{- ----- +optFile2grammar :: Options -> FilePath -> IOE GFGrammar +optFile2grammar os f = do + gr <- ioeErr $ compileModule os f + return $ grammar2stateGrammar gr + +optFile2grammarE :: Options -> FilePath -> IOE GFGrammar +optFile2grammarE = optFile2grammar +-} + +string2treeInState :: GFGrammar -> String -> State -> Err Tree +string2treeInState gr s st = do + let metas = allMetas st + t <- pTerm s + annotate (grammar gr) $ qualifTerm (absId gr) $ refreshMetas metas t + +string2srcTerm :: G.SourceGrammar -> I.Ident -> String -> Err G.Term +string2srcTerm gr m s = do + t <- pTerm s + R.renameSourceTerm gr m t + +randomTreesIO :: Options -> GFGrammar -> Int -> IO [Tree] +randomTreesIO opts gr n = do + gen <- myStdGen mx + t <- err (\s -> putStrLnFlush s >> return []) (return . singleton) $ + mkRandomTree gen mx g cat + ts <- if n==1 then return [] else randomTreesIO opts gr (n-1) + return $ t ++ ts + where + cat = firstAbsCat opts gr + g = grammar gr + mx = optIntOrN opts flagDepth 41 + +speechGenerate :: Options -> String -> IO () +speechGenerate opts str = do + let lan = maybe "" (" --language" +++) $ getOptVal opts speechLanguage + system ("echo" +++ "\"" ++ str ++ "\" | festival --tts" ++ lan) + return () + +optLinearizeTreeVal :: Options -> GFGrammar -> Tree -> String +optLinearizeTreeVal opts gr = err id id . optLinearizeTree opts gr + +optLinearizeTree :: Options -> GFGrammar -> Tree -> Err String +optLinearizeTree opts gr t + | oElem showRecord opts = liftM prt $ linearizeNoMark g c t + | otherwise = return $ linTree2string g c t + where + g = grammar gr + c = cncId gr + +{- ---- + untoksl . lin where + gr = concreteOf (stateGrammarST sgr) + lin -- options mutually exclusive, with priority: struct, rec, table, one + | oElem showStruct opts = markedLinString True gr . tree2loc + | oElem showRecord opts = err id prt . linTerm gr + | oElem tableLin opts = err id (concatMap prLinTable) . allLinsAsStrs gr + | oElem firstLin opts = unlines . map sstr . take 1 . allLinStrings gr + | otherwise = unlines . map sstr . optIntOrAll opts flagNumber . allLinStrings gr + untoks = customOrDefault opts' useUntokenizer customUntokenizer sgr + opts' = addOptions opts $ stateOptions sgr + untoksl = unlines . map untoks . lines +-} + +{- +optLinearizeArgForm :: Options -> StateGrammar -> [Term] -> Term -> String +optLinearizeArgForm opts sgr fs ts0 = untoksl $ lin ts where + gr = concreteOf (stateGrammarST sgr) + ts = annotateTrm sgr ts0 + ms = map (renameTrm (lookupConcrete gr)) fs + lin -- options mutually exclusive, with priority: struct, rec, table + | oElem tableLin opts = err id (concatMap prLinTable) . allLinsForForms gr ms + | otherwise = err id (unlines . map sstr . tkStrs . concat) . allLinsForForms gr ms + tkStrs = concat . map snd . concat . map snd + untoks = customOrDefault opts' useUntokenizer customUntokenizer sgr + opts' = addOptions opts $ stateOptions sgr + untoksl = unlines . map untoks . lines +-} + +optParseArg :: Options -> GFGrammar -> String -> [Tree] +optParseArg opts gr = err (const []) id . optParseArgErr opts gr + +optParseArgErr :: Options -> GFGrammar -> String -> Err [Tree] +optParseArgErr opts gr = liftM fst . optParseArgErrMsg opts gr + +optParseArgErrMsg :: Options -> GFGrammar -> String -> Err ([Tree],String) +optParseArgErrMsg opts gr s = + let cat = firstCatOpts opts gr + in parseStringMsg opts gr cat s + +-- analyses word by word +morphoAnalyse :: Options -> GFGrammar -> String -> String +morphoAnalyse opts gr + | oElem beShort opts = morphoTextShort mo + | otherwise = morphoText mo + where + mo = morpho gr + +{- +prExpXML :: StateGrammar -> Term -> [String] +prExpXML gr = prElementX . term2elemx (stateAbstract gr) + +prMultiGrammar :: Options -> ShellState -> String +prMultiGrammar opts = M.showMGrammar (oElem optimizeCanon opts) +-} +-- access to customizable commands + +optPrintGrammar :: Options -> StateGrammar -> String +optPrintGrammar opts = customOrDefault opts grammarPrinter customGrammarPrinter + +optPrintSyntax :: Options -> GF.Grammar -> String +optPrintSyntax opts = customOrDefault opts grammarPrinter customSyntaxPrinter + +{- ---- +optPrintTree :: Options -> GFGrammar -> Tree -> String +optPrintTree opts = customOrDefault opts grammarPrinter customTermPrinter + +-- look for string command (-filter=x) +optStringCommand :: Options -> GFGrammar -> String -> String +optStringCommand opts g = + optIntOrAll opts flagLength . + customOrDefault opts filterString customStringCommand g + +optTreeCommand :: Options -> GFGrammar -> Tree -> [Tree] +optTreeCommand opts st = + optIntOrAll opts flagNumber . + customOrDefault opts termCommand customTermCommand st +-} + +{- +-- wraps term in a function and optionally computes the result + +wrapByFun :: Options -> StateGrammar -> Ident -> Term -> Term +wrapByFun opts g f t = + if oElem doCompute opts + then err (const t) id $ computeAbsTerm (stateAbstract g) (appCons f [t]) + else appCons f [t] + +optTransfer :: Options -> StateGrammar -> Term -> Term +optTransfer opts g = case getOptVal opts transferFun of + Just f -> wrapByFun (addOption doCompute opts) g (string2id f) + _ -> id +-} +optTokenizer :: Options -> GFGrammar -> String -> String +optTokenizer opts gr = show . customOrDefault opts useTokenizer customTokenizer gr + +-- performs UTF8 if the language name is not *U.gf ; should be by gr option --- +optEncodeUTF8 :: Language -> GFGrammar -> String -> String +optEncodeUTF8 lang gr = case reverse (prLanguage lang) of + 'U':_ -> id + _ -> encodeUTF8 + diff --git a/src/GF/API/IOGrammar.hs b/src/GF/API/IOGrammar.hs new file mode 100644 index 000000000..a00ef18a6 --- /dev/null +++ b/src/GF/API/IOGrammar.hs @@ -0,0 +1,42 @@ +module IOGrammar where + +import Option +import Abstract +import qualified GFC +import PGrammar +import TypeCheck +import Compile +import ShellState + +import Operations +import UseIO +import Arch + +import Monad (liftM) + +-- for reading grammars and terms from strings and files + +--- a heuristic way of renaming constants is used +string2absTerm :: String -> String -> Term +string2absTerm m = renameTermIn m . pTrm + +renameTermIn :: String -> Term -> Term +renameTermIn m = refreshMetas [] . rename [] where + rename vs t = case t of + Abs x b -> Abs x (rename (x:vs) b) + Vr c -> if elem c vs then t else Q (zIdent m) c + App f a -> App (rename vs f) (rename vs a) + _ -> t + +string2annotTree :: GFC.CanonGrammar -> Ident -> String -> Err Tree +string2annotTree gr m = annotate gr . string2absTerm (prt m) ---- prt + +----string2paramList :: ConcreteST -> String -> [Term] +---string2paramList st = map (renameTrm (lookupConcrete st) . patt2term) . pPattList + +shellStateFromFiles :: Options -> ShellState -> FilePath -> IOE ShellState +shellStateFromFiles opts st file = do + let osb = addOptions (options [beVerbose, emitCode]) opts --- + grts <- compileModule osb st file + ioeErr $ updateShellState opts st grts + --- liftM (changeModTimes rts) $ grammar2shellState opts gr diff --git a/src/GF/CF/CF.hs b/src/GF/CF/CF.hs new file mode 100644 index 000000000..0cff68b97 --- /dev/null +++ b/src/GF/CF/CF.hs @@ -0,0 +1,180 @@ +module CF where + +import Operations +import Str +import AbsGFC +import GFC +import CFIdent +import List (nub,nubBy) +import Char (isUpper, isLower, toUpper, toLower) + +-- context-free grammars. AR 15/12/1999 -- 30/3/2000 -- 2/6/2001 -- 3/12/2001 + +-- CF grammar data types + +-- abstract type CF. +-- Invariant: each category has all its rules grouped with it +-- also: the list is never empty (the category is just missing then) +newtype CF = CF ([(CFCat,[CFRule])], CFPredef) +type CFRule = (CFFun, (CFCat, [CFItem])) + +-- CFPredef is a hack for variable symbols and literals; normally = const [] +data CFItem = CFTerm RegExp | CFNonterm CFCat deriving (Eq, Ord,Show) + +newtype CFTree = CFTree (CFFun,(CFCat, [CFTree])) deriving (Eq, Show) + +type CFPredef = CFTok -> [(CFCat, CFFun)] -- recognize literals, variables, etc + +-- Wadler style + return information +type CFParser = [CFTok] -> ([(CFTree,[CFTok])],String) + +cfParseResults :: ([(CFTree,[CFTok])],String) -> [CFTree] +cfParseResults rs = [b | (b,[]) <- fst rs] + +-- terminals are regular expressions on words; to be completed to full regexp +data RegExp = + RegAlts [CFWord] -- list of alternative words + | RegSpec CFTok -- special token + deriving (Eq, Ord, Show) + +type CFWord = String + +-- the above types should be kept abstract, and the following functions used + +-- to construct CF grammars + +emptyCF :: CF +emptyCF = CF ([], emptyCFPredef) + +emptyCFPredef :: CFPredef +emptyCFPredef = const [] + +rules2CF :: [CFRule] -> CF +rules2CF rs = CF (groupCFRules rs, emptyCFPredef) + +groupCFRules :: [CFRule] -> [(CFCat,[CFRule])] +groupCFRules = foldr ins [] where + ins rule crs = case crs of + (c,r) : rs | compatCF c cat -> (c,rule:r) : rs + cr : rs -> cr : ins rule rs + _ -> [(cat,[rule])] + where + cat = valCatCF rule + +-- to construct rules + +-- make a rule from a single token without constituents +atomCFRule :: CFCat -> CFFun -> CFTok -> CFRule +atomCFRule c f s = (f, (c, [atomCFTerm s])) + +-- usual terminal +atomCFTerm :: CFTok -> CFItem +atomCFTerm = CFTerm . atomRegExp + +atomRegExp :: CFTok -> RegExp +atomRegExp t = case t of + TS s -> RegAlts [s] + _ -> RegSpec t + +-- terminal consisting of alternatives +altsCFTerm :: [String] -> CFItem +altsCFTerm = CFTerm . RegAlts + + +-- to construct trees + +-- make a tree without constituents +atomCFTree :: CFCat -> CFFun -> CFTree +atomCFTree c f = buildCFTree c f [] + +-- make a tree with constituents. +buildCFTree :: CFCat -> CFFun -> [CFTree] -> CFTree +buildCFTree c f trees = CFTree (f,(c,trees)) + +{- ---- +cfMeta0 :: CFTree +cfMeta0 = atomCFTree uCFCat metaCFFun + +-- used in happy +litCFTree :: String -> CFTree --- Maybe CFTree +litCFTree s = maybe cfMeta0 id $ do + (c,f) <- getCFLiteral s + return $ buildCFTree c f [] +-} + +-- to decide whether a token matches a terminal item + +matchCFTerm :: CFItem -> CFTok -> Bool +matchCFTerm (CFTerm t) s = satRegExp t s +matchCFTerm _ _ = False + +satRegExp :: RegExp -> CFTok -> Bool +satRegExp r t = case (r,t) of + (RegAlts tt, TS s) -> elem s tt + (RegAlts tt, TC s) -> or [elem s' tt | s' <- caseUpperOrLower s] + (RegSpec x, _) -> t == x --- + _ -> False + where + caseUpperOrLower s = case s of + c:cs | isUpper c -> [s, toLower c : cs] + c:cs | isLower c -> [s, toUpper c : cs] + _ -> [s] + +-- to analyse a CF grammar + +catsOfCF :: CF -> [CFCat] +catsOfCF (CF (rr,_)) = map fst rr + +rulesOfCF :: CF -> [CFRule] +rulesOfCF (CF (rr,_)) = concatMap snd rr + +ruleGroupsOfCF :: CF -> [(CFCat,[CFRule])] +ruleGroupsOfCF (CF (rr,_)) = rr + +rulesForCFCat :: CF -> CFCat -> [CFRule] +rulesForCFCat (CF (rr,_)) cat = maybe [] id $ lookup cat rr + +valCatCF :: CFRule -> CFCat +valCatCF (_,(c,_)) = c + +valItemsCF :: CFRule -> [CFItem] +valItemsCF (_,(_,i)) = i + +valFunCF :: CFRule -> CFFun +valFunCF (f,(_,_)) = f + +startCat :: CF -> CFCat +startCat (CF (rr,_)) = fst (head rr) --- hardly useful + +predefOfCF :: CF -> CFPredef +predefOfCF (CF (_,f)) = f + +appCFPredef :: CF -> CFTok -> [(CFCat, CFFun)] +appCFPredef = ($) . predefOfCF + +valCFItem :: CFItem -> Either RegExp CFCat +valCFItem (CFTerm r) = Left r +valCFItem (CFNonterm nt) = Right nt + +cfTokens :: CF -> [CFWord] +cfTokens cf = nub $ concat $ [ wordsOfRegExp i | r <- rulesOfCF cf, + CFTerm i <- valItemsCF r] + +wordsOfRegExp :: RegExp -> [CFWord] +wordsOfRegExp (RegAlts tt) = tt +wordsOfRegExp _ = [] + +forCFItem :: CFTok -> CFRule -> Bool +forCFItem a (_,(_, CFTerm r : _)) = satRegExp r a +forCFItem _ _ = False + +isCircularCF :: CFRule -> Bool +isCircularCF (_,(c', CFNonterm c:[])) = compatCF c' c +isCircularCF _ = False +--- we should make a test of circular chains, too + +-- coercion to the older predef cf type + +predefRules :: CFPredef -> CFTok -> [CFRule] +predefRules pre s = [atomCFRule c f s | (c,f) <- pre s] + diff --git a/src/GF/CF/CFIdent.hs b/src/GF/CF/CFIdent.hs new file mode 100644 index 000000000..d9c451adb --- /dev/null +++ b/src/GF/CF/CFIdent.hs @@ -0,0 +1,151 @@ +module CFIdent where + +import Operations +import GFC +import Ident +import AbsGFC +import PrGrammar +import Str +import Char (toLower, toUpper) + +-- symbols (categories, functions) for context-free grammars. + +-- these types should be abstract + +data CFTok = + TS String -- normal strings + | TC String -- strings that are ambiguous between upper or lower case + | TL String -- string literals + | TI Int -- integer literals + | TV Ident -- variables + | TM Int String -- metavariables; the integer identifies it + deriving (Eq, Ord, Show) + +newtype CFCat = CFCat (CIdent,Label) deriving (Eq, Ord, Show) + +tS, tC, tL, tI, tV, tM :: String -> CFTok +tS = TS +tC = TC +tL = TL +tI = TI . read +tV = TV . identC +tM = TM 0 + +tInt :: Int -> CFTok +tInt = TI + +prCFTok :: CFTok -> String +prCFTok t = case t of + TS s -> s + TC s -> s + TL s -> s + TI i -> show i + TV x -> prt x + TM i _ -> "?" --- + +-- to build trees: the Atom contains a GF function, Cn | Meta | Vr | Literal +newtype CFFun = CFFun (Atom, Profile) deriving (Eq,Show) + +type Profile = [([[Int]],[Int])] + + +-- the following functions should be used instead of constructors + +-- to construct CF functions + +mkCFFun :: Atom -> CFFun +mkCFFun t = CFFun (t,[]) + +{- ---- +getCFLiteral :: String -> Maybe (CFCat, CFFun) +getCFLiteral s = case lookupLiteral' s of + Ok (c, lit) -> Just (cat2CFCat c, mkCFFun lit) + _ -> Nothing +-} + +varCFFun :: Ident -> CFFun +varCFFun = mkCFFun . AV + +consCFFun :: CIdent -> CFFun +consCFFun = mkCFFun . AC + +{- ---- +string2CFFun :: String -> CFFun +string2CFFun = consCFFun . Ident +-} + +cfFun2String :: CFFun -> String +cfFun2String (CFFun (f,_)) = prt f + +cfFun2Profile :: CFFun -> Profile +cfFun2Profile (CFFun (_,p)) = p + +{- ---- +strPro2cfFun :: String -> Profile -> CFFun +strPro2cfFun str p = (CFFun (AC (Ident str), p)) +-} + +metaCFFun :: CFFun +metaCFFun = mkCFFun $ AM 0 + +-- to construct CF categories + +-- belongs elsewhere +mkCIdent :: String -> String -> CIdent +mkCIdent m c = CIQ (identC m) (identC c) + +ident2CFCat :: CIdent -> Ident -> CFCat +ident2CFCat mc d = CFCat (mc, L d) + +-- standard way of making cf cat: label s +string2CFCat :: String -> String -> CFCat +string2CFCat m c = ident2CFCat (mkCIdent m c) (identC "s") + +idents2CFCat :: Ident -> Ident -> CFCat +idents2CFCat m c = ident2CFCat (CIQ m c) (identC "s") + +catVarCF :: CFCat +catVarCF = ident2CFCat (mkCIdent "_" "#Var") (identC "_") ---- + +{- ---- +uCFCat :: CFCat +uCFCat = cat2CFCat uCat +-} + +moduleOfCFCat :: CFCat -> Ident +moduleOfCFCat (CFCat (CIQ m _, _)) = m + +-- the opposite direction +cfCat2Cat :: CFCat -> CIdent +cfCat2Cat (CFCat (s,_)) = s + + +-- to construct CF tokens + +string2CFTok :: String -> CFTok +string2CFTok = tS + +str2cftoks :: Str -> [CFTok] +str2cftoks = map tS . words . sstr + +-- decide if two token lists look the same (in parser postprocessing) + +compatToks :: [CFTok] -> [CFTok] -> Bool +compatToks ts us = and [compatTok t u | (t,u) <- zip ts us] + +compatTok t u = any (`elem` (alts t)) (alts u) where + alts u = case u of + TC (c:s) -> [toLower c : s, toUpper c : s] + _ -> [prCFTok u] + +-- decide if two CFFuns have the same function head (profiles may differ) + +compatCFFun :: CFFun -> CFFun -> Bool +compatCFFun (CFFun (f,_)) (CFFun (g,_)) = f == g + +-- decide whether two categories match +-- the modifiers can be from different modules, but on the same extension +-- path, so there is no clash, and they can be safely ignored --- +compatCF :: CFCat -> CFCat -> Bool +----compatCF = (==) +compatCF (CFCat (CIQ _ c, l)) (CFCat (CIQ _ c', l')) = c==c' && l==l' diff --git a/src/GF/CF/CanonToCF.hs b/src/GF/CF/CanonToCF.hs new file mode 100644 index 000000000..6f7dc6d6b --- /dev/null +++ b/src/GF/CF/CanonToCF.hs @@ -0,0 +1,157 @@ +module CanonToCF where + +import Operations +import Option +import Ident +import AbsGFC +import GFC +import PrGrammar +import CMacros +import qualified Modules as M +import CF +import CFIdent +import List (nub) +import Monad + +-- AR 27/1/2000 -- 3/12/2001 -- 8/6/2003 + +-- The main function: for a given cnc module m, build the CF grammar with all the +-- rules coming from modules that m extends. The categories are qualified by +-- the abstract module name a that m is of. + +canon2cf :: Options -> CanonGrammar -> Ident -> Err CF +canon2cf opts gr c = do + let ms = M.allExtends gr c + a <- M.abstractOfConcrete gr c + let cncs = [m | (n, M.ModMod m) <- M.modules gr, elem n ms] + let mms = [(a, tree2list (M.jments m)) | m <- cncs] + rules0 <- liftM concat $ mapM (uncurry (cnc2cfCond opts)) mms + let rules = filter (not . isCircularCF) rules0 ---- temporarily here + let predef = const [] ---- mkCFPredef cfcats + return $ CF (groupCFRules rules, predef) + +cnc2cfCond :: Options -> Ident -> [(Ident,Info)] -> Err [CFRule] +cnc2cfCond opts m gr = + liftM concat $ + mapM lin2cf [(m,fun,cat,args,lin) | (fun, CncFun cat args lin _) <- gr] + +type IFun = Ident +type ICat = CIdent + +-- all CF rules corresponding to a linearization rule +lin2cf :: (Ident, IFun, ICat, [ArgVar], Term) -> Err [CFRule] +lin2cf (m,fun,cat,args,lin) = errIn ("building CF rule for" +++ prt fun) $ do + rhss0 <- allLinValues lin -- :: [(Label, [([Patt],Term)])] + rhss1 <- mapM (mkCFItems m) (concat rhss0) -- :: [(Label, [[PreCFItem]])] + mapM (mkCfRules m fun cat args) rhss1 >>= return . nub . concat + +-- making sequences of CF items from every branch in a linearization +mkCFItems :: Ident -> (Label, [([Patt],Term)]) -> Err (Label, [[PreCFItem]]) +mkCFItems m (lab,pts) = do + itemss <- mapM (term2CFItems m) (map snd pts) + return (lab, concat itemss) ---- combinations? (test!) + +-- making CF rules from sequences of CF items +mkCfRules :: Ident -> IFun -> ICat -> [ArgVar] -> (Label, [[PreCFItem]]) -> Err [CFRule] +mkCfRules m fun cat args (lab, itss) = mapM mkOneRule itss + where + mkOneRule its = do + let nonterms = zip [0..] [(pos,d,v) | PNonterm _ pos d v <- its] + profile = mkProfile nonterms + cfcat = CFCat (redirectIdent m cat,lab) + cffun = CFFun (AC (CIQ m fun), profile) + cfits = map precf2cf its + return (cffun,(cfcat,cfits)) + mkProfile nonterms = map mkOne args + where + mkOne (A c i) = mkOne (AB c 0 i) + mkOne (AB _ b i) = (map mkB [0..b-1], [k | (k,(j,_,True)) <- nonterms, j==i]) + where + mkB j = [p | (p,(k, LV l,False)) <- nonterms, k == i, l == j] + +-- intermediate data structure of CFItems with information for profiles +data PreCFItem = + PTerm RegExp -- like ordinary Terminal + | PNonterm CIdent Integer Label Bool -- cat, position, part/bind, whether arg + deriving Eq + +precf2cf :: PreCFItem -> CFItem +precf2cf (PTerm r) = CFTerm r +precf2cf (PNonterm cm _ (L c) True) = CFNonterm (ident2CFCat cm c) +precf2cf (PNonterm _ _ _ False) = CFNonterm catVarCF + + +-- the main job in translating linearization rules into sequences of cf items +term2CFItems :: Ident -> Term -> Err [[PreCFItem]] +term2CFItems m t = errIn "forming cf items" $ case t of + S c _ -> t2c c + + T _ cc -> do + its <- mapM t2c [t | Cas _ t <- cc] + tryMkCFTerm (concat its) + + C t1 t2 -> do + its1 <- t2c t1 + its2 <- t2c t2 + return [x ++ y | x <- its1, y <- its2] + + FV ts -> do + its <- mapM t2c ts + tryMkCFTerm (concat its) + + P arg s -> extrR arg s + + K (KS s) -> return [[PTerm (RegAlts [s]) | not (null s)]] + + E -> return [[]] + + K (KP d vs) -> do + let its = [PTerm (RegAlts [s]) | s <- d] + let itss = [[PTerm (RegAlts [s]) | s <- t] | Var t _ <- vs] + tryMkCFTerm (its : itss) + + _ -> prtBad "no cf for" t ---- + + where + + t2c = term2CFItems m + + -- optimize the number of rules by a factorization + tryMkCFTerm :: [[PreCFItem]] -> Err [[PreCFItem]] + tryMkCFTerm ii@(its:itss) | all (\x -> length x == length its) itss = + case mapM mkOne (counterparts ii) of + Ok tt -> return [tt] + _ -> return ii + where + mkOne cfits = case mapM mkOneTerm cfits of + Ok tt -> return $ PTerm (RegAlts (concat (nub tt))) + _ -> mkOneNonTerm cfits + mkOneTerm (PTerm (RegAlts t)) = return t + mkOneTerm _ = Bad "" + mkOneNonTerm (n@(PNonterm _ _ _ _) : cc) = + if all (== n) cc + then return n + else Bad "" + mkOneNonTerm _ = Bad "" + counterparts ll = [map (!! i) ll | i <- [0..length (head ll) - 1]] + tryMkCFTerm itss = return itss + + extrR arg lab = case (arg,lab) of + (Arg (A cat pos), l@(L _)) -> return [[PNonterm (CIQ m cat) pos l True]] + (Arg (A cat pos), l@(LV _)) -> return [[PNonterm (CIQ m cat) pos l False]] + (Arg (AB cat pos b), l@(L _)) -> return [[PNonterm (CIQ m cat) pos l True]] + (Arg (AB cat pos b), l@(LV _)) -> return [[PNonterm (CIQ m cat) pos l False]] + ---- ?? + _ -> prtBad "cannot extract record field from" arg + +{- Proof + 1 @ 4 catVarCF :: CFCat +PNonterm CIdent Integer Label Bool -- cat, position, part/bind, whether arg + + +mkCFPredef :: [CFCat] -> CFPredef +mkCFPredef cats s = + [(cat, metaCFFun) | TM _ _ <- [s], cat <- cats] ++ + [(cat, varCFFun x) | TV x <- [s], cat <- cats] ++ + [(cat, lit) | TL t <- [s], Just (cat,lit) <- [getCFLiteral t]] ++ + [(cat, lit) | TI i <- [s], Just (cat,lit) <- [getCFLiteral (show i)]] --- +-} diff --git a/src/GF/CF/ChartParser.hs b/src/GF/CF/ChartParser.hs new file mode 100644 index 000000000..09d538244 --- /dev/null +++ b/src/GF/CF/ChartParser.hs @@ -0,0 +1,166 @@ + +module ChartParser (chartParser) where + +import Operations +import CF +import CFIdent +import PPrCF (prCFItem) + +import OrdSet +import OrdMap2 + +import List (groupBy) + +type Token = CFTok +type Name = CFFun +type Category = CFItem +type Grammar = ([Production], Terminal) +type Production = (Name, Category, [Category]) +type Terminal = Token -> [(Category, Maybe Name)] +type GParser = Grammar -> Category -> [Token] -> ([ParseTree],String) +data ParseTree = Node Name Category [ParseTree] | Leaf Token + +-------------------------------------------------- +-- converting between GF parsing and CFG parsing + +buildParser :: GParser -> CF -> CFCat -> CFParser +buildParser gparser cf = parse + where + parse = \start input -> + let parse2 = parse' (CFNonterm start) input in + ([(parse2tree t, []) | t <- fst parse2], snd parse2) + parse' = gparser (cf2grammar cf) + +cf2grammar :: CF -> Grammar +cf2grammar cf = (productions, terminal) + where + productions = [ (name, CFNonterm cat, rhs) | + (name, (cat, rhs)) <- cfRules ] + terminal tok = [ (CFNonterm cat, Just name) | + (cat, name) <- cfPredef tok ] + ++ + [ (item, Nothing) | + item <- elems rhsItems, + matchCFTerm item tok ] + cfRules = rulesOfCF cf + cfPredef = predefOfCF cf + rhsItems :: Set Category + rhsItems = union [ makeSet rhs | (_, (_, rhs)) <- cfRules ] + +parse2tree :: ParseTree -> CFTree +parse2tree (Node name (CFNonterm cat) trees) = CFTree (name, (cat, trees')) + where + trees' = [ parse2tree t | t@(Node _ _ _) <- trees ] -- ignore leafs + +maybeNode :: Maybe Name -> Category -> Token -> ParseTree +maybeNode (Just name) cat tok = Node name cat [Leaf tok] +maybeNode Nothing _ tok = Leaf tok + + +-------------------------------------------------- +-- chart parsing (bottom up kilbury-like) + +type Chart = [CState] +type CState = Set Edge +type Edge = (Int, Category, [Category]) +type Passive = (Int, Int, Category) + +chartParser :: CF -> CFCat -> CFParser +chartParser = buildParser chartParser0 + +chartParser0 :: GParser +chartParser0 (productions, terminal) = cparse + where + emptyCats :: Set Category + emptyCats = empties emptySet + where + empties cats | cats==cats' = cats + | otherwise = empties cats' + where cats' = makeSet [ cat | (_, cat, rhs) <- productions, + all (`elemSet` cats) rhs ] + + grammarMap :: Map Category [(Name, [Category])] + grammarMap = makeMapWith (++) + [ (cat, [(name,rhs)]) | (name, cat, rhs) <- productions ] + + leftCornerMap :: Map Category (Set (Category,[Category])) + leftCornerMap = makeMapWith (<++>) [ (a, unitSet (b, bs)) | + (_, b, abs) <- productions, + (a : bs) <- removeNullable abs ] + + removeNullable :: [Category] -> [[Category]] + removeNullable [] = [] + removeNullable cats@(cat:cats') + | cat `elemSet` emptyCats = cats : removeNullable cats' + | otherwise = [cats] + + cparse :: Category -> [Token] -> ([ParseTree], String) + cparse start input = case lookup (0, length input, start) edgeTrees of + Just trees -> (trees, "Chart:" ++++ prChart passiveEdges) + Nothing -> ([], "Chart:" ++++ prChart passiveEdges) + where + finalChart :: Chart + finalChart = map buildState initialChart + + finalChartMap :: [Map Category (Set Edge)] + finalChartMap = map stateMap finalChart + + stateMap :: CState -> Map Category (Set Edge) + stateMap state = makeMapWith (<++>) [ (a, unitSet (i,b,bs)) | + (i, b, a:bs) <- elems state ] + + initialChart :: Chart + initialChart = emptySet : map initialState (zip [0..] input) + where initialState (j, sym) = makeSet [ (j, cat, []) | + (cat, _) <- terminal sym ] + + buildState :: CState -> CState + buildState = limit more + where more (j, a, []) = ordSet [ (j, b, bs) | + (b, bs) <- elems (lookupWith emptySet leftCornerMap a) ] + <++> + lookupWith emptySet (finalChartMap !! j) a + more (j, b, a:bs) = ordSet [ (j, b, bs) | + a `elemSet` emptyCats ] + + passiveEdges :: [Passive] + passiveEdges = [ (i, j, cat) | + (j, state) <- zip [0..] finalChart, + (i, cat, []) <- elems state ] + ++ + [ (i, i, cat) | + i <- [0 .. length input], + cat <- elems emptyCats ] + + edgeTrees :: [ (Passive, [ParseTree]) ] + edgeTrees = [ (edge, treesFor edge) | edge <- passiveEdges ] + + edgeTreesMap :: Map (Int, Category) [(Int, [ParseTree])] + edgeTreesMap = makeMapWith (++) [ ((i,c), [(j,trees)]) | + ((i,j,c), trees) <- edgeTrees ] + + treesFor :: Passive -> [ParseTree] + treesFor (i, j, cat) = [ Node name cat trees | + (name, rhs) <- lookupWith [] grammarMap cat, + trees <- children rhs i j ] + ++ + [ maybeNode name cat tok | + i == j-1, + let tok = input !! i, + Just name <- [lookup cat (terminal tok)] ] + + children :: [Category] -> Int -> Int -> [[ParseTree]] + children [] i k = [ [] | i == k ] + children (c:cs) i k = [ tree : rest | + i <= k, + (j, trees) <- lookupWith [] edgeTreesMap (i,c), + rest <- children cs j k, + tree <- trees ] + + +-- AR 10/12/2002 + +prChart :: [Passive] -> String +prChart = unlines . map (unwords . map prOne) . positions where + prOne (i,j,it) = show i ++ "-" ++ show j ++ "-" ++ prCFItem it + positions = groupBy (\ (i,_,_) (j,_,_) -> i == j) diff --git a/src/GF/CF/PPrCF.hs b/src/GF/CF/PPrCF.hs new file mode 100644 index 000000000..ff4b64e66 --- /dev/null +++ b/src/GF/CF/PPrCF.hs @@ -0,0 +1,59 @@ +module PPrCF where + +import Operations +import CF +import CFIdent +import AbsGFC +import PrGrammar + +-- printing and parsing CF grammars, rules, and trees AR 26/1/2000 -- 9/6/2003 +---- use the Print class instead! + +prCF :: CF -> String +prCF = unlines . (map prCFRule) . rulesOfCF -- hiding the literal recogn function + +prCFTree :: CFTree -> String +prCFTree (CFTree (fun, (_,trees))) = prCFFun fun ++ prs trees where + prs [] = "" + prs ts = " " ++ unwords (map ps ts) + ps t@(CFTree (_,(_,[]))) = prCFTree t + ps t = prParenth (prCFTree t) + +prCFRule :: CFRule -> String +prCFRule (fun,(cat,its)) = + prCFFun fun ++ "." +++ prCFCat cat +++ "::=" +++ + unwords (map prCFItem its) +++ ";" + +prCFFun :: CFFun -> String +prCFFun = prCFFun' True ---- False -- print profiles for debug + +prCFFun' :: Bool -> CFFun -> String +prCFFun' profs (CFFun (t, p)) = prt t ++ pp p where + pp p = if (not profs || normal p) then "" else "_" ++ concat (map show p) + normal p = and [x==y && null b | ((b,x),y) <- zip p (map (:[]) [0..])] + +prCFCat :: CFCat -> String +prCFCat (CFCat (c,l)) = prt c ++ "-" ++ prt l ---- + +prCFItem (CFNonterm c) = prCFCat c +prCFItem (CFTerm a) = prRegExp a + +prRegExp (RegAlts tt) = case tt of + [t] -> prQuotedString t + _ -> prParenth (prTList " | " (map prQuotedString tt)) + +{- ---- +-- rules have an amazingly easy parser, if we use the format +-- fun. C -> item1 item2 ... where unquoted items are treated as cats +-- Actually would be nice to add profiles to this. + +getCFRule :: String -> Maybe CFRule +getCFRule s = getcf (wrds s) where + getcf ww | length ww > 2 && ww !! 2 `elem` ["->", "::="] = + Just (string2CFFun (init fun), (string2CFCat cat, map mkIt its)) where + fun : cat : _ : its = words s + mkIt ('"':w@(_:_)) = atomCFTerm (string2CFTok (init w)) + mkIt w = CFNonterm (string2CFCat w) + getcf _ = Nothing + wrds = takeWhile (/= ";") . words -- to permit semicolon in the end +-}
\ No newline at end of file diff --git a/src/GF/CF/Profile.hs b/src/GF/CF/Profile.hs new file mode 100644 index 000000000..6dbb5f85a --- /dev/null +++ b/src/GF/CF/Profile.hs @@ -0,0 +1,95 @@ +module Profile (postParse) where + +import AbsGFC +import GFC +import qualified Ident as I +import CMacros +---import MMacros +import CF +import CFIdent +import PPrCF -- for error msg +import PrGrammar + +import Operations + +import Monad +import List (nub) + + +-- restoring parse trees for discontinuous constituents, bindings, etc. AR 25/1/2001 +-- revised 8/4/2002 for the new profile structure + +postParse :: CFTree -> Err Exp +postParse tree = do + iterm <- errIn "postprocessing initial parse tree" $ tree2term tree + return $ term2trm iterm + +-- an intermediate data structure +data ITerm = ITerm (Atom, BindVs) [ITerm] | IMeta deriving (Eq,Show) +type BindVs = [[I.Ident]] + +-- the job is done in two passes: +-- (1) tree2term: restore constituent order from Profile +-- (2) term2trm: restore Bindings from Binds + +tree2term :: CFTree -> Err ITerm +tree2term (CFTree (cff@(CFFun (fun,pro)), (_,trees))) = case fun of + AM _ -> return IMeta + _ -> do + args <- mapM mkArg pro + binds <- mapM mkBinds pro + return $ ITerm (fun, binds) args + where + mkArg (_,arg) = case arg of + [x] -> do -- one occurrence + trx <- trees !? x + tree2term trx + [] -> return IMeta -- suppression + _ -> do -- reduplication + trees' <- mapM (trees !?) arg + xs1 <- mapM tree2term trees' + xs2 <- checkArity xs1 + unif xs2 + + checkArity xs = if length (nub [length xx | ITerm _ xx <- xs']) > 1 + then Bad "arity error" + else return xs' + where xs' = [t | t@(ITerm _ _) <- xs] + unif [] = return $ IMeta + unif xs@(ITerm fp@(f,_) xx : ts) = do + let hs = [h | ITerm (h,_) _ <- ts] + testErr (all (==f) hs) -- if fails, hs must be nonempty + ("unification expects" +++ prt f +++ "but found" +++ prt (head hs)) + xx' <- mapM unifArg [0 .. length xx - 1] + return $ ITerm fp xx' + where + unifArg i = tryUnif [zz !! i | ITerm _ zz <- xs] + tryUnif xx = case [t | t@(ITerm _ _) <- xx] of + [] -> return IMeta + x:xs -> if all (==x) xs + then return x + else Bad "failed to unify" + + mkBinds (xss,_) = mapM mkBind xss + mkBind xs = do + ts <- mapM (trees !?) xs + let vs = [x | CFTree (CFFun (AV x,_),(_,[])) <- ts] + testErr (length ts == length vs) "non-variable in bound position" + case vs of + [x] -> return x + [] -> return $ I.identC "h_" ---- uBoundVar + y:ys -> do + testErr (all (==y) ys) ("fail to unify bindings of" +++ prt y) + return y + +term2trm :: ITerm -> Exp +term2trm IMeta = EAtom (AM 0) ---- mExp0 +term2trm (ITerm (fun, binds) terms) = + let bterms = zip binds terms + in mkAppAtom fun [mkAbsR xs (term2trm t) | (xs,t) <- bterms] + + --- these are deprecated + where + mkAbsR c e = foldr EAbs e c + mkAppAtom a = mkApp (EAtom a) + mkApp = foldl EApp
\ No newline at end of file diff --git a/src/GF/Canon/AbsGFC.hs b/src/GF/Canon/AbsGFC.hs new file mode 100644 index 000000000..361c59d34 --- /dev/null +++ b/src/GF/Canon/AbsGFC.hs @@ -0,0 +1,160 @@ +module AbsGFC where + +import Ident --H + +-- Haskell module generated by the BNF converter, except --H + +-- newtype Ident = Ident String deriving (Eq,Ord,Show) --H +data Canon = + Gr [Module] + deriving (Eq,Ord,Show) + +data Module = + Mod ModType Extend Open [Flag] [Def] + deriving (Eq,Ord,Show) + +data ModType = + MTAbs Ident + | MTCnc Ident Ident + | MTRes Ident + deriving (Eq,Ord,Show) + +data Extend = + Ext Ident + | NoExt + deriving (Eq,Ord,Show) + +data Open = + NoOpens + | Opens [Ident] + deriving (Eq,Ord,Show) + +data Flag = + Flg Ident Ident + deriving (Eq,Ord,Show) + +data Def = + AbsDCat Ident [Decl] [CIdent] + | AbsDFun Ident Exp Exp + | ResDPar Ident [ParDef] + | ResDOper Ident CType Term + | CncDCat Ident CType Term Term + | CncDFun Ident CIdent [ArgVar] Term Term + | AnyDInd Ident Status Ident + deriving (Eq,Ord,Show) + +data ParDef = + ParD Ident [CType] + deriving (Eq,Ord,Show) + +data Status = + Canon + | NonCan + deriving (Eq,Ord,Show) + +data CIdent = + CIQ Ident Ident + deriving (Eq,Ord,Show) + +data Exp = + EApp Exp Exp + | EProd Ident Exp Exp + | EAbs Ident Exp + | EAtom Atom + | EEq [Equation] + deriving (Eq,Ord,Show) + +data Sort = + SType + deriving (Eq,Ord,Show) + +data Equation = + Equ [APatt] Exp + deriving (Eq,Ord,Show) + +data APatt = + APC CIdent [APatt] + | APV Ident + | APS String + | API Integer + | APW + deriving (Eq,Ord,Show) + +data Atom = + AC CIdent + | AD CIdent + | AV Ident + | AM Integer + | AS String + | AI Integer + | AT Sort + deriving (Eq,Ord,Show) + +data Decl = + Decl Ident Exp + deriving (Eq,Ord,Show) + +data CType = + RecType [Labelling] + | Table CType CType + | Cn CIdent + | TStr + deriving (Eq,Ord,Show) + +data Labelling = + Lbg Label CType + deriving (Eq,Ord,Show) + +data Term = + Arg ArgVar + | I CIdent + | Con CIdent [Term] + | LI Ident + | R [Assign] + | P Term Label + | T CType [Case] + | S Term Term + | C Term Term + | FV [Term] + | K Tokn + | E + deriving (Eq,Ord,Show) + +data Tokn = + KS String + | KP [String] [Variant] + deriving (Eq,Ord,Show) + +data Assign = + Ass Label Term + deriving (Eq,Ord,Show) + +data Case = + Cas [Patt] Term + deriving (Eq,Ord,Show) + +data Variant = + Var [String] [String] + deriving (Eq,Ord,Show) + +data Label = + L Ident + | LV Integer + deriving (Eq,Ord,Show) + +data ArgVar = + A Ident Integer + | AB Ident Integer Integer + deriving (Eq,Ord,Show) + +data Patt = + PC CIdent [Patt] + | PV Ident + | PW + | PR [PattAssign] + deriving (Eq,Ord,Show) + +data PattAssign = + PAss Label Patt + deriving (Eq,Ord,Show) + diff --git a/src/GF/Canon/CMacros.hs b/src/GF/Canon/CMacros.hs new file mode 100644 index 000000000..8c1841fcc --- /dev/null +++ b/src/GF/Canon/CMacros.hs @@ -0,0 +1,234 @@ +module CMacros where + +import AbsGFC +import GFC +import qualified Ident as A ---- no need to qualif? 21/9 +import PrGrammar +import Str + +import Operations + +import Char +import Monad + +-- macros for concrete syntax in GFC that do not need lookup in a grammar + +markFocus :: Term -> Term +markFocus = markSubterm "[*" "*]" + +markSubterm :: String -> String -> Term -> Term +markSubterm beg end t = case t of + R rs -> R $ map markField rs + T ty cs -> T ty [Cas p (mark v) | Cas p v <- cs] + _ -> foldr1 C [tK beg, t, tK end] -- t : Str guaranteed? + where + mark = markSubterm beg end + markField lt@(Ass l t) = if isLinLabel l then (Ass l (mark t)) else lt + isLinLabel (L (A.IC s)) = case s of ---- + 's':cs -> all isDigit cs + _ -> False + +tK :: String -> Term +tK = K . KS + +term2patt :: Term -> Err Patt +term2patt trm = case trm of + Con c aa -> do + aa' <- mapM term2patt aa + return (PC c aa') + R r -> do + let (ll,aa) = unzip [(l,a) | Ass l a <- r] + aa' <- mapM term2patt aa + return (PR (map (uncurry PAss) (zip ll aa'))) + LI x -> return $ PV x + _ -> prtBad "no pattern corresponds to term" trm + +patt2term :: Patt -> Term +patt2term p = case p of + PC x ps -> Con x (map patt2term ps) + PV x -> LI x + PW -> anyTerm ---- + PR pas -> R [ Ass lbl (patt2term q) | PAss lbl q <- pas ] + +anyTerm :: Term +anyTerm = LI (A.identC "_") --- should not happen + +matchPatt cs0 trm = term2patt trm >>= match cs0 where + match cs t = + case cs of + Cas ps b :_ | elem t ps -> return b + _:cs' -> match cs' t + [] -> Bad $ "pattern not found for" +++ prt t + +++ "among" ++++ unlines (map prt cs0) ---- debug + +defLinType :: CType +defLinType = RecType [Lbg (L (A.identC "s")) TStr] + +defLindef :: Term +defLindef = R [Ass (L (A.identC "s")) (Arg (A (A.identC "str") 0))] + +strsFromTerm :: Term -> Err [Str] +strsFromTerm t = case t of + K (KS s) -> return [str s] + K (KP d vs) -> return $ [Str [TN d [(s,v) | Var s v <- vs]]] + C s t -> do + s' <- strsFromTerm s + t' <- strsFromTerm t + return [plusStr x y | x <- s', y <- t'] + FV ts -> liftM concat $ mapM strsFromTerm ts + E -> return [str []] + _ -> return [str ("BUG[" ++ prt t ++ "]")] ---- debug +---- _ -> prtBad "cannot get Str from term " t + +-- recursively collect all branches in a table +allInTable :: Term -> [Term] +allInTable t = case t of + T _ ts -> concatMap (\ (Cas _ v) -> allInTable v) ts --- expand ? + _ -> [t] + +-- to gather s-fields; assumes term in normal form, preserves label +allLinFields :: Term -> Err [[(Label,Term)]] +allLinFields trm = case trm of +---- R rs -> return [[(l,t) | (l,(Just ty,t)) <- rs, isStrType ty]] -- good + R rs -> return [[(l,t) | Ass l t <- rs, isLinLabel l]] ---- bad + FV ts -> do + lts <- mapM allLinFields ts + return $ concat lts + _ -> prtBad "fields can only be sought in a record not in" trm + +---- deprecated +isLinLabel l = case l of + L (A.IC ('s':cs)) | all isDigit cs -> True + _ -> False + +-- to gather ultimate cases in a table; preserves pattern list +allCaseValues :: Term -> [([Patt],Term)] +allCaseValues trm = case trm of + T _ cs -> [(p:ps, t) | Cas pp t0 <- cs, p <- pp, (ps,t) <- allCaseValues t0] + _ -> [([],trm)] + +-- to gather all linearizations; assumes normal form, preserves label and args +allLinValues :: Term -> Err [[(Label,[([Patt],Term)])]] +allLinValues trm = do + lts <- allLinFields trm + mapM (mapPairsM (return . allCaseValues)) lts + +redirectIdent n f@(CIQ _ c) = CIQ n c + + +{- ---- to be removed 21/9 +-- to analyse types and terms into eta normal form + +typeForm :: Exp -> Err (Context, Exp, [Exp]) +typeForm e = do + (cont,val) <- getContext e + (cat,args) <- getArgs val + return (cont,cat,args) + +getContext :: Exp -> Err (Context, Exp) +getContext e = case e of + EProd x a b -> do + (g,b') <- getContext b + return ((x,a):g,b') + _ -> return ([],e) + +valAtom :: Exp -> Err Atom +valAtom e = do + (_,val,_) <- typeForm e + case val of + EAtom a -> return a + _ -> prtBad "atom expected instead of" val + +valCat :: Exp -> Err CIdent +valCat e = do + a <- valAtom e + case a of + AC c -> return c + _ -> prtBad "cat expected instead of" a + +termForm :: Exp -> Err ([A.Ident], Exp, [Exp]) +termForm e = do + (cont,val) <- getBinds e + (cat,args) <- getArgs val + return (cont,cat,args) + +getBinds :: Exp -> Err ([A.Ident], Exp) +getBinds e = case e of + EAbs x b -> do + (g,b') <- getBinds b + return (x:g,b') + _ -> return ([],e) + +getArgs :: Exp -> Err (Exp,[Exp]) +getArgs = get [] where + get xs e = case e of + EApp f a -> get (a:xs) f + _ -> return (e, reverse xs) + +-- the inverses of these + +mkProd :: Context -> Exp -> Exp +mkProd c e = foldr (uncurry EProd) e c + +mkApp :: Exp -> [Exp] -> Exp +mkApp = foldl EApp + +mkAppAtom :: Atom -> [Exp] -> Exp +mkAppAtom a = mkApp (EAtom a) + +mkAppCons :: CIdent -> [Exp] -> Exp +mkAppCons c = mkAppAtom $ AC c + +mkType :: Context -> Exp -> [Exp] -> Exp +mkType c e xs = mkProd c $ mkApp e xs + +mkAbs :: Context -> Exp -> Exp +mkAbs c e = foldr EAbs e $ map fst c + +mkTerm :: Context -> Exp -> [Exp] -> Exp +mkTerm c e xs = mkAbs c $ mkApp e xs + +mkAbsR :: [A.Ident] -> Exp -> Exp +mkAbsR c e = foldr EAbs e c + +mkTermR :: [A.Ident] -> Exp -> [Exp] -> Exp +mkTermR c e xs = mkAbsR c $ mkApp e xs + +-- this is used to create heuristic menus +eqCatId :: Cat -> Atom -> Bool +eqCatId (CIQ _ c) b = case b of + AC (CIQ _ d) -> c == d + AD (CIQ _ d) -> c == d + _ -> False + +-- a very weak notion of "compatible value category" +compatCat :: Cat -> Type -> Bool +compatCat c t = case t of + EAtom b -> eqCatId c b + EApp f _ -> compatCat c f + _ -> False + +-- this is the way an atomic category looks as a type + +cat2type :: Cat -> Type +cat2type = EAtom . AC + +compatType :: Type -> Type -> Bool +compatType t = case t of + EAtom (AC c) -> compatCat c + _ -> (t ==) + +type Fun = CIdent +type Cat = CIdent +type Type = Exp + +mkFun, mkCat :: String -> String -> Fun +mkFun m f = CIQ (A.identC m) (A.identC f) +mkCat = mkFun + +mkFunC, mkCatC :: String -> Fun +mkFunC s = let (m,f) = span (/= '.') s in mkFun m (drop 1 f) +mkCatC = mkFunC + +-} + diff --git a/src/GF/Canon/CanonToGrammar.hs b/src/GF/Canon/CanonToGrammar.hs new file mode 100644 index 000000000..550dc37a4 --- /dev/null +++ b/src/GF/Canon/CanonToGrammar.hs @@ -0,0 +1,167 @@ +module CanonToGrammar where + +import AbsGFC +import GFC +import MkGFC +---import CMacros +import qualified Modules as M +import qualified Option as O +import qualified Grammar as G +import qualified Macros as F + +import Ident +import Operations + +import Monad + +-- a decompiler. AR 12/6/2003 + +canon2sourceModule :: CanonModule -> Err G.SourceModule +canon2sourceModule (i,mi) = do + i' <- redIdent i + info' <- case mi of + M.ModMod m -> do + (e,os) <- redExtOpen m + flags <- mapM redFlag $ M.flags m + (abstr,mt) <- case M.mtype m of + M.MTConcrete a -> do + a' <- redIdent a + return (a', M.MTConcrete a') + M.MTAbstract -> return (i',M.MTAbstract) --- c' not needed + M.MTResource -> return (i',M.MTResource) --- c' not needed + defs <- mapMTree redInfo $ M.jments m + return $ M.ModMod $ M.Module mt flags e os defs + _ -> Bad $ "cannot decompile module type" + return (i',info') + where + redExtOpen m = do + e' <- case M.extends m of + Just e -> liftM Just $ redIdent e + _ -> return Nothing + os' <- mapM (\ (M.OSimple i) -> liftM (\i -> M.OQualif i i) (redIdent i)) $ + M.opens m + return (e',os') + +redInfo :: (Ident,Info) -> Err (Ident,G.Info) +redInfo (c,info) = errIn ("decompiling abstract" +++ show c) $ do + c' <- redIdent c + info' <- case info of + AbsCat cont fs -> do + return $ G.AbsCat (Yes cont) (Yes fs) + AbsFun typ df -> do + return $ G.AbsFun (Yes typ) (Yes df) + + ResPar par -> liftM (G.ResParam . Yes) $ mapM redParam par + + CncCat pty ptr ppr -> do + ty' <- redCType pty + trm' <- redCTerm ptr + ppr' <- redCTerm ppr + return $ G.CncCat (Yes ty') (Yes trm') (Yes ppr') + CncFun (CIQ abstr cat) xx body ppr -> do + xx' <- mapM redArgVar xx + body' <- redCTerm body + ppr' <- redCTerm ppr + return $ G.CncFun Nothing (Yes (F.mkAbs xx' body')) (Yes ppr') + + AnyInd b c -> liftM (G.AnyInd b) $ redIdent c + + return (c',info') + +redQIdent :: CIdent -> Err G.QIdent +redQIdent (CIQ m c) = liftM2 (,) (redIdent m) (redIdent c) + +redIdent :: Ident -> Err Ident +redIdent = return + +redFlag :: Flag -> Err O.Option +redFlag (Flg f x) = return $ O.Opt (prIdent f,[prIdent x]) + +redDecl :: Decl -> Err G.Decl +redDecl (Decl x a) = liftM2 (,) (redIdent x) (redTerm a) + +redType :: Exp -> Err G.Type +redType = redTerm + +redTerm :: Exp -> Err G.Term +redTerm t = return $ trExp t + +-- resource + +redParam (ParD c cont) = do + c' <- redIdent c + cont' <- mapM redCType cont + return $ (c', [(IW,t) | t <- cont']) + +-- concrete syntax + +redCType :: CType -> Err G.Type +redCType t = case t of + RecType lbs -> do + let (ls,ts) = unzip [(l,t) | Lbg l t <- lbs] + ls' = map redLabel ls + ts' <- mapM redCType ts + return $ G.RecType $ zip ls' ts' + Table p v -> liftM2 G.Table (redCType p) (redCType v) + Cn mc -> liftM (uncurry G.QC) $ redQIdent mc + TStr -> return $ F.typeStr + +redCTerm :: Term -> Err G.Term +redCTerm x = case x of + Arg argvar -> liftM G.Vr $ redArgVar argvar + I cident -> liftM (uncurry G.Q) $ redQIdent cident + Con cident terms -> liftM2 F.mkApp + (liftM (uncurry G.QC) $ redQIdent cident) + (mapM redCTerm terms) + LI id -> liftM G.Vr $ redIdent id + R assigns -> do + let (ls,ts) = unzip [(l,t) | Ass l t <- assigns] + let ls' = map redLabel ls + ts' <- mapM redCTerm ts + return $ G.R [(l,(Nothing,t)) | (l,t) <- zip ls' ts'] + P term label -> liftM2 G.P (redCTerm term) (return $ redLabel label) + T ctype cases -> do + ctype' <- redCType ctype + let (ps,ts) = unzip [(p,t) | Cas ps t <- cases, p <- ps] --- destroys sharing + ps' <- mapM redPatt ps + ts' <- mapM redCTerm ts --- duplicates work for shared rhss + let tinfo = case ps' of + [G.PV _] -> G.TTyped ctype' + _ -> G.TComp ctype' + return $ G.T tinfo $ zip ps' ts' + S term0 term -> liftM2 G.S (redCTerm term0) (redCTerm term) + C term0 term -> liftM2 G.C (redCTerm term0) (redCTerm term) + FV terms -> liftM G.FV $ mapM redCTerm terms + K (KS str) -> return $ G.K str + E -> return $ G.Empty + K (KP d vs) -> return $ + G.Alts (tList d,[(tList s, G.Strs $ map G.K v) | Var s v <- vs]) + where + tList ss = case ss of --- this should be in Macros + [] -> G.Empty + _ -> foldr1 G.C $ map G.K ss + +failure x = Bad $ "not yet" +++ show x ---- + +redArgVar :: ArgVar -> Err Ident +redArgVar x = case x of + A x i -> return $ IA (prIdent x, fromInteger i) + AB x b i -> return $ IAV (prIdent x, fromInteger b, fromInteger i) + +redLabel :: Label -> G.Label +redLabel (L x) = G.LIdent $ prIdent x +redLabel (LV i) = G.LVar $ fromInteger i + +redPatt :: Patt -> Err G.Patt +redPatt p = case p of + PV x -> liftM G.PV $ redIdent x + PC mc ps -> do + (m,c) <- redQIdent mc + liftM (G.PP m c) (mapM redPatt ps) + PR rs -> do + let (ls,ts) = unzip [(l,t) | PAss l t <- rs] + ls' = map redLabel ls + ts <- mapM redPatt ts + return $ G.PR $ zip ls' ts + _ -> Bad $ "cannot recompile pattern" +++ show p + diff --git a/src/GF/Canon/GFC.hs b/src/GF/Canon/GFC.hs new file mode 100644 index 000000000..63b697a35 --- /dev/null +++ b/src/GF/Canon/GFC.hs @@ -0,0 +1,48 @@ +module GFC where + +import AbsGFC +import PrintGFC +import qualified Abstract as A + +import Ident +import Option +import Zipper +import Operations +import qualified Modules as M + +import Char + +-- canonical GF. AR 10/9/2002 -- 9/5/2003 -- 21/9 + +type Context = [(Ident,Exp)] + +type CanonGrammar = M.MGrammar Ident Flag Info + +type CanonModInfo = M.ModInfo Ident Flag Info + +type CanonModule = (Ident, CanonModInfo) + +type CanonAbs = M.Module Ident Option Info + +data Info = + AbsCat A.Context [A.Fun] + | AbsFun A.Type A.Term + + | ResPar [ParDef] + | ResOper CType Term -- global constant + | CncCat CType Term Printname + | CncFun CIdent [ArgVar] Term Printname + | AnyInd Bool Ident + deriving (Show) + +type Printname = Term + +-- some printing ---- + +{- +prCanonModInfo :: (Ident,CanonModInfo) -> String +prCanonModInfo = printTree . info2mod + +prGrammar :: CanonGrammar -> String +prGrammar = printTree . grammar2canon +-} diff --git a/src/GF/Canon/GetGFC.hs b/src/GF/Canon/GetGFC.hs new file mode 100644 index 000000000..225b0712a --- /dev/null +++ b/src/GF/Canon/GetGFC.hs @@ -0,0 +1,22 @@ +module GetGFC where + +import Operations +import ParGFC +import GFC +import MkGFC +import Modules +import GetGrammar (err2err) --- +import UseIO + +getCanonModule :: FilePath -> IOE CanonModule +getCanonModule file = do + gr <- getCanonGrammar file + case modules gr of + [m] -> return m + _ -> ioeErr $ Bad "expected exactly one module in a file" + +getCanonGrammar :: FilePath -> IOE CanonGrammar +getCanonGrammar file = do + s <- ioeIO $ readFileIf file + c <- ioeErr $ err2err $ pCanon $ myLexer s + return $ canon2grammar c diff --git a/src/GF/Canon/LexGFC.hs b/src/GF/Canon/LexGFC.hs new file mode 100644 index 000000000..56048dce3 --- /dev/null +++ b/src/GF/Canon/LexGFC.hs @@ -0,0 +1,105 @@ + +module LexGFC where + +import Alex +import ErrM + +pTSpec p = PT p . TS + +ident p = PT p . eitherResIdent TV + +string p = PT p . TL . unescapeInitTail + +int p = PT p . TI + + +data Tok = + TS String -- reserved words + | TL String -- string literals + | TI String -- integer literals + | TV String -- identifiers + | TD String -- double precision float literals + | TC String -- character literals + + deriving (Eq,Show) + +data Token = + PT Posn Tok + | Err Posn + deriving Show + +tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l +tokenPos (Err (Pn _ l _) :_) = "line " ++ show l +tokenPos _ = "end of file" + +prToken t = case t of + PT _ (TS s) -> s + PT _ (TI s) -> s + PT _ (TV s) -> s + PT _ (TD s) -> s + PT _ (TC s) -> s + _ -> show t + +tokens:: String -> [Token] +tokens inp = scan tokens_scan inp + +tokens_scan:: Scan Token +tokens_scan = load_scan (tokens_acts,stop_act) tokens_lx + where + stop_act p "" = [] + stop_act p inp = [Err p] + +eitherResIdent :: (String -> Tok) -> String -> Tok +eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where + isResWord s = isInTree s $ + B "lin" (B "concrete" (B "abstract" (B "Type" (B "Str" N N) N) (B "cat" N N)) (B "fun" (B "flags" (B "data" N N) N) (B "in" N N))) (B "param" (B "open" (B "of" (B "lincat" N N) N) (B "oper" N N)) (B "table" (B "resource" (B "pre" N N) N) (B "variants" N N))) + +data BTree = N | B String BTree BTree deriving (Show) + +isInTree :: String -> BTree -> Bool +isInTree x tree = case tree of + N -> False + B a left right + | x < a -> isInTree x left + | x > a -> isInTree x right + | x == a -> True + +unescapeInitTail :: String -> String +unescapeInitTail = unesc . tail where + unesc s = case s of + '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs + '\\':'n':cs -> '\n' : unesc cs + '\\':'t':cs -> '\t' : unesc cs + '"':[] -> [] + c:cs -> c : unesc cs + _ -> [] + +tokens_acts = [("ident",ident),("int",int),("pTSpec",pTSpec),("string",string)] + +tokens_lx :: [(Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))] +tokens_lx = [lx__0_0,lx__1_0,lx__2_0,lx__3_0,lx__4_0,lx__5_0,lx__6_0,lx__7_0,lx__8_0,lx__9_0,lx__10_0,lx__11_0] +lx__0_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__0_0 = (False,[],-1,(('\t','\255'),[('\t',1),('\n',1),('\v',1),('\f',1),('\r',1),(' ',1),('!',6),('"',8),('$',6),('(',6),(')',6),('*',2),('+',5),(',',6),('-',3),('.',6),('/',6),('0',11),('1',11),('2',11),('3',11),('4',11),('5',11),('6',11),('7',11),('8',11),('9',11),(':',6),(';',6),('<',6),('=',4),('>',6),('?',6),('@',6),('A',7),('B',7),('C',7),('D',7),('E',7),('F',7),('G',7),('H',7),('I',7),('J',7),('K',7),('L',7),('M',7),('N',7),('O',7),('P',7),('Q',7),('R',7),('S',7),('T',7),('U',7),('V',7),('W',7),('X',7),('Y',7),('Z',7),('[',6),('\\',6),(']',6),('_',6),('a',7),('b',7),('c',7),('d',7),('e',7),('f',7),('g',7),('h',7),('i',7),('j',7),('k',7),('l',7),('m',7),('n',7),('o',7),('p',7),('q',7),('r',7),('s',7),('t',7),('u',7),('v',7),('w',7),('x',7),('y',7),('z',7),('{',6),('|',6),('}',6),('\192',7),('\193',7),('\194',7),('\195',7),('\196',7),('\197',7),('\198',7),('\199',7),('\200',7),('\201',7),('\202',7),('\203',7),('\204',7),('\205',7),('\206',7),('\207',7),('\208',7),('\209',7),('\210',7),('\211',7),('\212',7),('\213',7),('\214',7),('\216',7),('\217',7),('\218',7),('\219',7),('\220',7),('\221',7),('\222',7),('\223',7),('\224',7),('\225',7),('\226',7),('\227',7),('\228',7),('\229',7),('\230',7),('\231',7),('\232',7),('\233',7),('\234',7),('\235',7),('\236',7),('\237',7),('\238',7),('\239',7),('\240',7),('\241',7),('\242',7),('\243',7),('\244',7),('\245',7),('\246',7),('\248',7),('\249',7),('\250',7),('\251',7),('\252',7),('\253',7),('\254',7),('\255',7)])) +lx__1_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__1_0 = (True,[(0,"",[],Nothing,Nothing)],-1,(('\t',' '),[('\t',1),('\n',1),('\v',1),('\f',1),('\r',1),(' ',1)])) +lx__2_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__2_0 = (False,[],-1,(('*','*'),[('*',6)])) +lx__3_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__3_0 = (False,[],-1,(('>','>'),[('>',6)])) +lx__4_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__4_0 = (True,[(1,"pTSpec",[],Nothing,Nothing)],-1,(('>','>'),[('>',6)])) +lx__5_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__5_0 = (True,[(1,"pTSpec",[],Nothing,Nothing)],-1,(('+','+'),[('+',6)])) +lx__6_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__6_0 = (True,[(1,"pTSpec",[],Nothing,Nothing)],-1,(('0','0'),[])) +lx__7_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__7_0 = (True,[(2,"ident",[],Nothing,Nothing)],-1,(('\'','\255'),[('\'',7),('0',7),('1',7),('2',7),('3',7),('4',7),('5',7),('6',7),('7',7),('8',7),('9',7),('A',7),('B',7),('C',7),('D',7),('E',7),('F',7),('G',7),('H',7),('I',7),('J',7),('K',7),('L',7),('M',7),('N',7),('O',7),('P',7),('Q',7),('R',7),('S',7),('T',7),('U',7),('V',7),('W',7),('X',7),('Y',7),('Z',7),('_',7),('a',7),('b',7),('c',7),('d',7),('e',7),('f',7),('g',7),('h',7),('i',7),('j',7),('k',7),('l',7),('m',7),('n',7),('o',7),('p',7),('q',7),('r',7),('s',7),('t',7),('u',7),('v',7),('w',7),('x',7),('y',7),('z',7),('\192',7),('\193',7),('\194',7),('\195',7),('\196',7),('\197',7),('\198',7),('\199',7),('\200',7),('\201',7),('\202',7),('\203',7),('\204',7),('\205',7),('\206',7),('\207',7),('\208',7),('\209',7),('\210',7),('\211',7),('\212',7),('\213',7),('\214',7),('\216',7),('\217',7),('\218',7),('\219',7),('\220',7),('\221',7),('\222',7),('\223',7),('\224',7),('\225',7),('\226',7),('\227',7),('\228',7),('\229',7),('\230',7),('\231',7),('\232',7),('\233',7),('\234',7),('\235',7),('\236',7),('\237',7),('\238',7),('\239',7),('\240',7),('\241',7),('\242',7),('\243',7),('\244',7),('\245',7),('\246',7),('\248',7),('\249',7),('\250',7),('\251',7),('\252',7),('\253',7),('\254',7),('\255',7)])) +lx__8_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__8_0 = (False,[],8,(('\n','\\'),[('\n',-1),('"',10),('\\',9)])) +lx__9_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__9_0 = (False,[],-1,(('"','t'),[('"',8),('\'',8),('\\',8),('n',8),('t',8)])) +lx__10_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__10_0 = (True,[(3,"string",[],Nothing,Nothing)],-1,(('0','0'),[])) +lx__11_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__11_0 = (True,[(4,"int",[],Nothing,Nothing)],-1,(('0','9'),[('0',11),('1',11),('2',11),('3',11),('4',11),('5',11),('6',11),('7',11),('8',11),('9',11)])) + diff --git a/src/GF/Canon/Look.hs b/src/GF/Canon/Look.hs new file mode 100644 index 000000000..a71d024c2 --- /dev/null +++ b/src/GF/Canon/Look.hs @@ -0,0 +1,141 @@ +module Look where + +import AbsGFC +import GFC +import PrGrammar +import CMacros +----import Values +import MMacros +import qualified Modules as M + +import Operations + +import Monad +import List + +-- lookup in GFC. AR 2003 + +-- linearization lookup + +lookupCncInfo :: CanonGrammar -> CIdent -> Err Info +lookupCncInfo gr f@(CIQ m c) = do + mt <- M.lookupModule gr m + case mt of + M.ModMod a -> errIn ("module" +++ prt m) $ + lookupTree prt c $ M.jments a + _ -> prtBad "not concrete module" m + +lookupLin :: CanonGrammar -> CIdent -> Err Term +lookupLin gr f = do + info <- lookupCncInfo gr f + case info of + CncFun _ _ t _ -> return t + CncCat _ t _ -> return t + AnyInd _ n -> lookupLin gr $ redirectIdent n f + +lookupResInfo :: CanonGrammar -> CIdent -> Err Info +lookupResInfo gr f@(CIQ m c) = do + mt <- M.lookupModule gr m + case mt of + M.ModMod a -> lookupTree prt c $ M.jments a + _ -> prtBad "not resource module" m + +lookupGlobal :: CanonGrammar -> CIdent -> Err Term +lookupGlobal gr f = do + info <- lookupResInfo gr f + case info of + ResOper _ t -> return t + AnyInd _ n -> lookupGlobal gr $ redirectIdent n f + _ -> prtBad "cannot find global" f + +lookupParamValues :: CanonGrammar -> CIdent -> Err [Term] +lookupParamValues gr pt@(CIQ m _) = do + info <- lookupResInfo gr pt + case info of + ResPar ps -> liftM concat $ mapM mkPar ps + AnyInd _ n -> lookupParamValues gr $ redirectIdent n pt + _ -> prtBad "cannot find parameter type" pt + where + mkPar (ParD f co) = do + vs <- liftM combinations $ mapM (allParamValues gr) co + return $ map (Con (CIQ m f)) vs + +-- this is needed since param type can also be a record type + +allParamValues :: CanonGrammar -> CType -> Err [Term] +allParamValues cnc ptyp = case ptyp of + Cn pc -> lookupParamValues cnc pc + RecType r -> do + let (ls,tys) = unzip [(l,t) | Lbg l t <- r] + tss <- mapM allPV tys + return [R (map (uncurry Ass) (zip ls ts)) | ts <- combinations tss] + _ -> prtBad "cannot possibly find parameter values for" ptyp + where + allPV = allParamValues cnc + +-- runtime computation on GFC objects + +ccompute :: CanonGrammar -> [Term] -> Term -> Err Term +ccompute cnc = comp [] + where + comp g xs t = case t of + Arg (A _ i) -> errIn ("argument list") $ xs !? fromInteger i + Arg (AB _ _ i) -> errIn ("argument list for binding") $ xs !? fromInteger i + I c -> look c + LI c -> lookVar c g + + -- short-cut computation of selections: compute the table only if needed + S u v -> do + u' <- compt u + case u' of + T _ [Cas [PW] b] -> compt b + T _ [Cas [PV x] b] -> do + v' <- compt v + comp ((x,v') : g) xs b + T _ cs -> do + v' <- compt v + if noVar v' + then matchPatt cs v' >>= compt + else return $ S u' v' + + _ -> liftM (S u') $ compt v + + P u l -> do + u' <- compt u + case u' of + R rs -> maybe (Bad ("unknown label" +++ prt l +++ "in" +++ prt u')) + return $ + lookup l [ (x,y) | Ass x y <- rs] + _ -> return $ P u' l + FV ts -> liftM FV (mapM compt ts) + C E b -> compt b + C a E -> compt a + C a b -> do + a' <- compt a + b' <- compt b + return $ case (a',b') of + (E,_) -> b' + (_,E) -> a' + _ -> C a' b' + R rs -> liftM (R . map (uncurry Ass)) $ + mapPairsM compt [(l,r) | Ass l r <- rs] + + -- only expand the table when the table is really needed: use expandLin + T ty rs -> liftM (T ty . map (uncurry Cas)) $ + mapPairsM compt [(l,r) | Cas l r <- rs] + + Con c xs -> liftM (Con c) $ mapM compt xs + + _ -> return t + where + compt = comp g xs + look c = lookupGlobal cnc c + + lookVar c co = case lookup c co of + Just t -> return t + _ -> return $ LI c --- Bad $ "unknown local variable" +++ prt c --- + + noVar v = case v of + LI _ -> False + R rs -> all noVar [t | Ass _ t <- rs] + _ -> True --- other cases? diff --git a/src/GF/Canon/MkGFC.hs b/src/GF/Canon/MkGFC.hs new file mode 100644 index 000000000..d7641ca21 --- /dev/null +++ b/src/GF/Canon/MkGFC.hs @@ -0,0 +1,121 @@ +module MkGFC where + +import GFC +import AbsGFC +import qualified Abstract as A +import PrGrammar + +import Ident +import Operations +import qualified Modules as M + +prCanonModInfo :: CanonModule -> String +prCanonModInfo = prt . info2mod + +canon2grammar :: Canon -> CanonGrammar +canon2grammar (Gr modules) = M.MGrammar $ map mod2info modules where + mod2info m = case m of + Mod mt e os flags defs -> + let defs' = buildTree $ map def2info defs + (a,mt') = case mt of + MTAbs a -> (a,M.MTAbstract) + MTRes a -> (a,M.MTResource) + MTCnc a x -> (a,M.MTConcrete x) + in (a,M.ModMod (M.Module mt' flags (ee e) (oo os) defs')) + ee (Ext m) = Just m + ee _ = Nothing + oo (Opens ms) = map M.OSimple ms + oo _ = [] + +grammar2canon :: CanonGrammar -> Canon +grammar2canon (M.MGrammar modules) = Gr $ map info2mod modules + +info2mod m = case m of + (a, M.ModMod (M.Module mt flags me os defs)) -> + let defs' = map info2def $ tree2list defs + mt' = case mt of + M.MTAbstract -> MTAbs a + M.MTResource -> MTRes a + M.MTConcrete x -> MTCnc a x + in + Mod mt' (gfcE me) (gfcO os) flags defs' + where + gfcE = maybe NoExt Ext + gfcO os = if null os then NoOpens else Opens [m | M.OSimple m <- os] + + +-- these translations are meant to be trivial + +defs2infos = sorted2tree . map def2info + +def2info d = case d of + AbsDCat c cont fs -> (c,AbsCat (trCont cont) (trFs fs)) + AbsDFun c ty df -> (c,AbsFun (trExp ty) (trExp df)) + ResDPar c df -> (c,ResPar df) + ResDOper c ty df -> (c,ResOper ty df) + CncDCat c ty df pr -> (c, CncCat ty df pr) + CncDFun f c xs li pr -> (f, CncFun c xs li pr) + AnyDInd c b m -> (c, AnyInd (b == Canon) m) + +-- from file to internal + +trCont cont = [(x,trExp t) | Decl x t <- cont] + +trFs = map trQIdent + +trExp t = case t of + EProd x a b -> A.Prod x (trExp a) (trExp b) + EAbs x b -> A.Abs x (trExp b) + EApp f a -> A.App (trExp f) (trExp a) + EEq _ -> A.Eqs [] ---- eqs + _ -> trAt t + where + trAt (EAtom t) = case t of + AC c -> (uncurry A.Q) $ trQIdent c + AD c -> (uncurry A.QC) $ trQIdent c + AV v -> A.Vr v + AM i -> A.Meta $ A.MetaSymb $ fromInteger i + AT s -> A.Sort $ prt s + AS s -> A.K s + AI i -> A.EInt $ fromInteger i + +trQIdent (CIQ m c) = (m,c) + +-- from internal to file + +infos2defs = map info2def . tree2list + +info2def d = case d of + (c,AbsCat cont fs) -> AbsDCat c (rtCont cont) (rtFs fs) + (c,AbsFun ty df) -> AbsDFun c (rtExp ty) (rtExp df) + (c,ResPar df) -> ResDPar c df + (c,ResOper ty df) -> ResDOper c ty df + (c,CncCat ty df pr) -> CncDCat c ty df pr + (f,CncFun c xs li pr) -> CncDFun f c xs li pr + (c,AnyInd b m) -> AnyDInd c (if b then Canon else NonCan) m + +rtCont cont = [Decl (rtIdent x) (rtExp t) | (x,t) <- cont] + +rtFs = map rtQIdent + +rtExp t = case t of + A.Prod x a b -> EProd (rtIdent x) (rtExp a) (rtExp b) + A.Abs x b -> EAbs (rtIdent x) (rtExp b) + A.App f a -> EApp (rtExp f) (rtExp a) + A.Eqs _ -> EEq [] ---- eqs + _ -> EAtom $ rtAt t + where + rtAt t = case t of + A.Q m c -> AC $ rtQIdent (m,c) + A.QC m c -> AD $ rtQIdent (m,c) + A.Vr v -> AV v + A.Meta i -> AM $ toInteger $ A.metaSymbInt i + A.Sort "Type" -> AT SType + A.K s -> AS s + A.EInt i -> AI $ toInteger i + _ -> error $ "MkGFC.rt not defined for" +++ show t + +rtQIdent (m,c) = CIQ (rtIdent m) (rtIdent c) +rtIdent x + | isWildIdent x = identC "h_" --- needed in declarations + | otherwise = identC $ prt x --- diff --git a/src/GF/Canon/PrExp.hs b/src/GF/Canon/PrExp.hs new file mode 100644 index 000000000..6052f9a7f --- /dev/null +++ b/src/GF/Canon/PrExp.hs @@ -0,0 +1,36 @@ +module PrExp where + +import AbsGFC +import GFC + +import Operations + +-- some printing + +-- print trees without qualifications + +prExp :: Exp -> String +prExp e = case e of + EApp f a -> pr1 f +++ pr2 a + EAbsR x b -> "\\" ++ prtt x +++ "->" +++ prExp b + EAbs x _ b -> prExp $ EAbsR x b + EProd x a b -> "(\\" ++ prtt x +++ ":" +++ prExp a ++ ")" +++ "->" +++ prExp b + EAtomR a -> prAtom a + EAtom a _ -> prAtom a + _ -> prtt e + where + pr1 e = case e of + EAbsR _ _ -> prParenth $ prExp e + EAbs _ _ _ -> prParenth $ prExp e + EProd _ _ _ -> prParenth $ prExp e + _ -> prExp e + pr2 e = case e of + EApp _ _ -> prParenth $ prExp e + _ -> pr1 e + +prAtom a = case a of + AC c -> prCIdent c + AD c -> prCIdent c + _ -> prtt a + +prCIdent (CIQ _ c) = prtt c diff --git a/src/GF/Canon/PrintGFC.hs b/src/GF/Canon/PrintGFC.hs new file mode 100644 index 000000000..c4f2e7d62 --- /dev/null +++ b/src/GF/Canon/PrintGFC.hs @@ -0,0 +1,319 @@ +module PrintGFC where + +-- pretty-printer generated by the BNF converter, except handhacked spacing --H + +import Ident --H +import AbsGFC +import Char + +-- the top-level printing method +printTree :: Print a => a -> String +printTree = render . prt 0 + +-- you may want to change render and parenth + +render :: [String] -> String +render = rend 0 where + rend i ss = case ss of + "NEW" :ts -> realnew $ rend i ts --H + "<" :ts -> cons "<" $ rend i ts --H + "$" :ts -> cons "$" $ rend i ts --H + "?" :ts -> cons "?" $ rend i ts --H + "[" :ts -> cons "[" $ rend i ts + "(" :ts -> cons "(" $ rend i ts + "{" :ts -> cons "{" $ new (i+1) $ rend (i+1) ts + "}" : ";":ts -> new (i-1) $ space "}" $ cons ";" $ new (i-1) $ rend (i-1) ts + "}" :ts -> new (i-1) $ cons "}" $ new (i-1) $ rend (i-1) ts + ";" :ts -> cons ";" $ new i $ rend i ts + t : "," :ts -> cons t $ space "," $ rend i ts + t : ")" :ts -> cons t $ cons ")" $ rend i ts + t : "]" :ts -> cons t $ cons "]" $ rend i ts + t : ">" :ts -> cons t $ cons ">" $ rend i ts --H + t : "." :ts -> cons t $ cons "." $ rend i ts --H + t :ts -> realspace t $ rend i ts --H + _ -> "" + cons s t = s ++ t + space t s = t ++ " " ++ s --H + realspace t s = if null s then t else t ++ " " ++ s --H + new i s = s --H '\n' : replicate (2*i) ' ' ++ dropWhile isSpace s + realnew s = '\n':s --H + +parenth :: [String] -> [String] +parenth ss = ["("] ++ ss ++ [")"] + +-- the printer class does the job +class Print a where + prt :: Int -> a -> [String] + prtList :: [a] -> [String] + prtList = concat . map (prt 0) + +instance Print a => Print [a] where + prt _ = prtList + +instance Print Integer where + prt _ = (:[]) . show + +instance Print Double where + prt _ = (:[]) . show + +instance Print Char where + prt _ s = ["'" ++ mkEsc s ++ "'"] + prtList s = ["\"" ++ concatMap mkEsc s ++ "\""] + +mkEsc s = case s of + _ | elem s "\\\"'" -> '\\':[s] + '\n' -> "\\n" + '\t' -> "\\t" + _ -> [s] + +prPrec :: Int -> Int -> [String] -> [String] +prPrec i j = if j<i then parenth else id + + +instance Print Ident where + prt _ i = [prIdent i] + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [","] , prt 0 xs]) + + + +instance Print Canon where + prt i e = case e of + Gr modules -> prPrec i 0 (concat [prt 0 modules]) + + +instance Print Module where + prt i e = case e of + Mod modtype extend open flags defs -> prPrec i 0 (concat [prt 0 modtype , ["="] , prt 0 extend , prt 0 open , ["{"] , prt 0 flags , prt 0 defs , ["}"]]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 0 x , prt 0 xs]) + +instance Print ModType where + prt i e = case e of + MTAbs id -> prPrec i 0 (concat [["abstract"] , prt 0 id]) + MTCnc id0 id -> prPrec i 0 (concat [["concrete"] , prt 0 id0 , ["of"] , prt 0 id]) + MTRes id -> prPrec i 0 (concat [["resource"] , prt 0 id]) + + +instance Print Extend where + prt i e = case e of + Ext id -> prPrec i 0 (concat [prt 0 id , ["**"]]) + NoExt -> prPrec i 0 (concat []) + + +instance Print Open where + prt i e = case e of + NoOpens -> prPrec i 0 (concat []) + Opens ids -> prPrec i 0 (concat [["open"] , prt 0 ids , ["in"]]) + + +instance Print Flag where + prt i e = case e of + Flg id0 id -> prPrec i 0 (concat [["flags"] , prt 0 id0 , ["="] , prt 0 id]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print Def where + prt i e = case e of + AbsDCat id decls cidents -> prPrec i 0 (concat [["cat"] , prt 0 id , ["["] , prt 0 decls , ["]"] , ["="] , prt 0 cidents]) + AbsDFun id exp0 exp -> prPrec i 0 (concat [["fun"] , prt 0 id , [":"] , prt 0 exp0 , ["="] , prt 0 exp]) + ResDPar id pardefs -> prPrec i 0 (concat [["param"] , prt 0 id , ["="] , prt 0 pardefs]) + ResDOper id ctype term -> prPrec i 0 (concat [["oper"] , prt 0 id , [":"] , prt 0 ctype , ["="] , prt 0 term]) + CncDCat id ctype term0 term -> prPrec i 0 (concat [["lincat"] , prt 0 id , ["="] , prt 0 ctype , ["="] , prt 0 term0 , [";"] , prt 0 term]) + CncDFun id cident argvars term0 term -> prPrec i 0 (concat [["lin"] , prt 0 id , [":"] , prt 0 cident , ["="] , ["\\"] , prt 0 argvars , ["->"] , prt 0 term0 , [";"] , prt 0 term]) + AnyDInd id0 status id -> prPrec i 0 (concat [prt 0 id0 , prt 0 status , ["in"] , prt 0 id]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 0 x , [";","NEW"] , prt 0 xs]) --H + +instance Print ParDef where + prt i e = case e of + ParD id ctypes -> prPrec i 0 (concat [prt 0 id , prt 0 ctypes]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , ["|"] , prt 0 xs]) + +instance Print Status where + prt i e = case e of + Canon -> prPrec i 0 (concat [["data"]]) + NonCan -> prPrec i 0 (concat []) + + +instance Print CIdent where + prt i e = case e of + CIQ id0 id -> prPrec i 0 (concat [prt 0 id0 , ["."] , prt 0 id]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 0 x , prt 0 xs]) + +instance Print Exp where + prt i e = case e of + EApp exp0 exp -> prPrec i 1 (concat [prt 1 exp0 , prt 2 exp]) + EProd id exp0 exp -> prPrec i 0 (concat [["("] , prt 0 id , [":"] , prt 0 exp0 , [")"] , ["->"] , prt 0 exp]) + EAtom atom -> prPrec i 2 (concat [prt 0 atom]) + EAbs id exp -> prPrec i 0 (concat [["\\"] , prt 0 id , ["->"] , prt 0 exp]) + EEq equations -> prPrec i 0 (concat [["{"] , prt 0 equations , ["}"]]) + +instance Print Sort where + prt i e = case e of + SType -> prPrec i 0 (concat [["Type"]]) + +instance Print Equation where + prt i e = case e of + Equ apatts exp -> prPrec i 0 (concat [prt 0 apatts , ["->"] , prt 0 exp]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print APatt where + prt i e = case e of + APC cident apatts -> prPrec i 0 (concat [["("] , prt 0 cident , prt 0 apatts , [")"]]) + APV id -> prPrec i 0 (concat [prt 0 id]) + APS str -> prPrec i 0 (concat [prt 0 str]) + API n -> prPrec i 0 (concat [prt 0 n]) + APW -> prPrec i 0 (concat [["_"]]) + + prtList es = case es of + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , prt 0 xs]) + +instance Print Atom where + prt i e = case e of + AC cident -> prPrec i 0 (concat [prt 0 cident]) + AD cident -> prPrec i 0 (concat [["<"] , prt 0 cident , [">"]]) + AV id -> prPrec i 0 (concat [["$"] , prt 0 id]) + AM n -> prPrec i 0 (concat [["?"] , prt 0 n]) + AS str -> prPrec i 0 (concat [prt 0 str]) + AI n -> prPrec i 0 (concat [prt 0 n]) + AT sort -> prPrec i 0 (concat [prt 0 sort]) + + +instance Print Decl where + prt i e = case e of + Decl id exp -> prPrec i 0 (concat [prt 0 id , [":"] , prt 0 exp]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print CType where + prt i e = case e of + RecType labellings -> prPrec i 0 (concat [["{"] , prt 0 labellings , ["}"]]) + Table ctype0 ctype -> prPrec i 0 (concat [["("] , prt 0 ctype0 , ["=>"] , prt 0 ctype , [")"]]) + Cn cident -> prPrec i 0 (concat [prt 0 cident]) + TStr -> prPrec i 0 (concat [["Str"]]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 0 x , prt 0 xs]) + +instance Print Labelling where + prt i e = case e of + Lbg label ctype -> prPrec i 0 (concat [prt 0 label , [":"] , prt 0 ctype]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print Term where + prt i e = case e of + Arg argvar -> prPrec i 2 (concat [prt 0 argvar]) + I cident -> prPrec i 2 (concat [prt 0 cident]) + Con cident terms -> prPrec i 2 (concat [["<"] , prt 0 cident , prt 2 terms , [">"]]) + LI id -> prPrec i 2 (concat [["$"] , prt 0 id]) + R assigns -> prPrec i 2 (concat [["{"] , prt 0 assigns , ["}"]]) + P term label -> prPrec i 1 (concat [prt 2 term , ["."] , prt 0 label]) + T ctype cases -> prPrec i 1 (concat [["table"] , prt 0 ctype , ["{"] , prt 0 cases , ["}"]]) + S term0 term -> prPrec i 1 (concat [prt 1 term0 , ["!"] , prt 2 term]) + C term0 term -> prPrec i 0 (concat [prt 0 term0 , ["++"] , prt 1 term]) + FV terms -> prPrec i 1 (concat [["variants"] , ["{"] , prt 2 terms , ["}"]]) + K tokn -> prPrec i 2 (concat [prt 0 tokn]) + E -> prPrec i 2 (concat [["["] , ["]"]]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 2 x , prt 2 xs]) + +instance Print Tokn where + prt i e = case e of + KS str -> prPrec i 0 (concat [prt 0 str]) + KP strs variants -> prPrec i 0 (concat [["["] , ["pre"] , prt 0 strs , ["{"] , prt 0 variants , ["}"] , ["]"]]) + + +instance Print Assign where + prt i e = case e of + Ass label term -> prPrec i 0 (concat [prt 0 label , ["="] , prt 0 term]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print Case where + prt i e = case e of + Cas patts term -> prPrec i 0 (concat [prt 0 patts , ["=>"] , prt 0 term]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print Variant where + prt i e = case e of + Var strs0 strs -> prPrec i 0 (concat [prt 0 strs0 , ["/"] , prt 0 strs]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print Label where + prt i e = case e of + L id -> prPrec i 0 (concat [prt 0 id]) + LV n -> prPrec i 0 (concat [["$"] , prt 0 n]) + + +instance Print ArgVar where + prt i e = case e of + A id n -> prPrec i 0 (concat [prt 0 id , ["@"] , prt 0 n]) + AB id n0 n -> prPrec i 0 (concat [prt 0 id , ["+"] , prt 0 n0 , ["@"] , prt 0 n]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [","] , prt 0 xs]) + +instance Print Patt where + prt i e = case e of + PC cident patts -> prPrec i 0 (concat [["("] , prt 0 cident , prt 0 patts , [")"]]) + PV id -> prPrec i 0 (concat [prt 0 id]) + PW -> prPrec i 0 (concat [["_"]]) + PR pattassigns -> prPrec i 0 (concat [["{"] , prt 0 pattassigns , ["}"]]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 0 x , prt 0 xs]) + +instance Print PattAssign where + prt i e = case e of + PAss label patt -> prPrec i 0 (concat [prt 0 label , ["="] , prt 0 patt]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + + diff --git a/src/GF/Canon/Share.hs b/src/GF/Canon/Share.hs new file mode 100644 index 000000000..fc4d82b06 --- /dev/null +++ b/src/GF/Canon/Share.hs @@ -0,0 +1,116 @@ +module Share (shareModule, OptSpec, basicOpt, fullOpt) where + +import AbsGFC +import Ident +import GFC +import qualified CMacros as C +import Operations +import List +import qualified Modules as M + +-- optimization: sharing branches in tables. AR 25/4/2003 +-- following advice of Josef Svenningsson + +type OptSpec = [Integer] --- +doOptFactor opt = elem 2 opt +basicOpt = [] +fullOpt = [2] + +shareModule :: OptSpec -> (Ident, CanonModInfo) -> (Ident, CanonModInfo) +shareModule opt (i,m) = case m of + M.ModMod (M.Module mt fs me ops js) -> + (i,M.ModMod (M.Module mt fs me ops (mapTree (shareInfo opt) js))) + _ -> (i,m) + +shareInfo opt (c, CncCat ty t m) = (c, CncCat ty (shareOpt opt t) m) +shareInfo opt (c, CncFun k xs t m) = (c, CncFun k xs (shareOpt opt t) m) +shareInfo _ i = i + +-- the function putting together optimizations +shareOpt :: OptSpec -> Term -> Term +shareOpt opt + | doOptFactor opt = share . factor 0 + | otherwise = share + +-- we need no counter to create new variable names, since variables are +-- local to tables + +share :: Term -> Term +share t = case t of + T ty cs -> shareT ty [(p, share v) | Cas ps v <- cs, p <- ps] -- only substant. + R lts -> R [Ass l (share t) | Ass l t <- lts] + P t l -> P (share t) l + S t a -> S (share t) (share a) + C t a -> C (share t) (share a) + FV ts -> FV (map share ts) + + _ -> t -- including D, which is always born shared + + where + shareT ty = finalize ty . groupC . sortC + + sortC :: [(Patt,Term)] -> [(Patt,Term)] + sortC = sortBy $ \a b -> compare (snd a) (snd b) + + groupC :: [(Patt,Term)] -> [[(Patt,Term)]] + groupC = groupBy $ \a b -> snd a == snd b + + finalize :: CType -> [[(Patt,Term)]] -> Term + finalize ty css = T ty [Cas (map fst ps) t | ps@((_,t):_) <- css] + + +-- do even more: factor parametric branches + +factor :: Int -> Term -> Term +factor i t = case t of + T _ [_] -> t + T _ [] -> t + T ty cs -> T ty $ factors i [Cas [p] (factor (i+1) v) | Cas ps v <- cs, p <- ps] + R lts -> R [Ass l (factor i t) | Ass l t <- lts] + P t l -> P (factor i t) l + S t a -> S (factor i t) (factor i a) + C t a -> C (factor i t) (factor i a) + FV ts -> FV (map (factor i) ts) + + _ -> t + where + + factors i psvs = -- we know psvs has at least 2 elements + let p = pIdent i + vs' = map (mkFun p) psvs + in if allEqs vs' + then mkCase p vs' + else psvs + + mkFun p (Cas [patt] val) = replace (C.patt2term patt) (LI p) val + + allEqs (v:vs) = all (==v) vs + + mkCase p (v:_) = [Cas [PV p] v] + +pIdent i = identC ("p__" ++ show i) + + +-- we need to replace subterms + +replace :: Term -> Term -> Term -> Term +replace old new trm = case trm of + T ty cs -> T ty [Cas p (repl v) | Cas p v <- cs] + P t l -> P (repl t) l + S t a -> S (repl t) (repl a) + C t a -> C (repl t) (repl a) + FV ts -> FV (map repl ts) + + -- these are the important cases, since they can correspond to patterns + Con c ts | trm == old -> new + Con c ts -> Con c (map repl ts) + R _ | isRec && trm == old -> new + R lts -> R [Ass l (repl t) | Ass l t <- lts] + + _ -> trm + where + repl = replace old new + isRec = case trm of + R _ -> True + _ -> False + diff --git a/src/GF/Canon/SkelGFC.hs b/src/GF/Canon/SkelGFC.hs new file mode 100644 index 000000000..e75b66636 --- /dev/null +++ b/src/GF/Canon/SkelGFC.hs @@ -0,0 +1,199 @@ +module SkelGFC where + +import Ident + +-- Haskell module generated by the BNF converter + +import AbsGFC +import ErrM +type Result = Err String + +failure :: Show a => a -> Result +failure x = Bad $ "Undefined case: " ++ show x + +transIdent :: Ident -> Result +transIdent x = case x of + _ -> failure x + + +transCanon :: Canon -> Result +transCanon x = case x of + Gr modules -> failure x + + +transModule :: Module -> Result +transModule x = case x of + Mod modtype extend open flags defs -> failure x + + +transModType :: ModType -> Result +transModType x = case x of + MTAbs id -> failure x + MTCnc id0 id -> failure x + MTRes id -> failure x + + +transExtend :: Extend -> Result +transExtend x = case x of + Ext id -> failure x + NoExt -> failure x + + +transOpen :: Open -> Result +transOpen x = case x of + NoOpens -> failure x + Opens ids -> failure x + + +transFlag :: Flag -> Result +transFlag x = case x of + Flg id0 id -> failure x + + +transDef :: Def -> Result +transDef x = case x of + AbsDCat id decls cidents -> failure x + AbsDFun id exp0 exp -> failure x + ResDPar id pardefs -> failure x + ResDOper id ctype term -> failure x + CncDCat id ctype term0 term -> failure x + CncDFun id cident argvars term0 term -> failure x + AnyDInd id0 status id -> failure x + + +transParDef :: ParDef -> Result +transParDef x = case x of + ParD id ctypes -> failure x + + +transStatus :: Status -> Result +transStatus x = case x of + Canon -> failure x + NonCan -> failure x + + +transCIdent :: CIdent -> Result +transCIdent x = case x of + CIQ id0 id -> failure x + + +transExp :: Exp -> Result +transExp x = case x of + EApp exp0 exp -> failure x + EProd id exp0 exp -> failure x + EAbs id exp -> failure x + EAtom atom -> failure x + EEq equations -> failure x + + +transSort :: Sort -> Result +transSort x = case x of + SType -> failure x + + +transEquation :: Equation -> Result +transEquation x = case x of + Equ apatts exp -> failure x + + +transAPatt :: APatt -> Result +transAPatt x = case x of + APC cident apatts -> failure x + APV id -> failure x + APS str -> failure x + API n -> failure x + APW -> failure x + + +transAtom :: Atom -> Result +transAtom x = case x of + AC cident -> failure x + AD cident -> failure x + AV id -> failure x + AM n -> failure x + AS str -> failure x + AI n -> failure x + AT sort -> failure x + + +transDecl :: Decl -> Result +transDecl x = case x of + Decl id exp -> failure x + + +transCType :: CType -> Result +transCType x = case x of + RecType labellings -> failure x + Table ctype0 ctype -> failure x + Cn cident -> failure x + TStr -> failure x + + +transLabelling :: Labelling -> Result +transLabelling x = case x of + Lbg label ctype -> failure x + + +transTerm :: Term -> Result +transTerm x = case x of + Arg argvar -> failure x + I cident -> failure x + Con cident terms -> failure x + LI id -> failure x + R assigns -> failure x + P term label -> failure x + T ctype cases -> failure x + S term0 term -> failure x + C term0 term -> failure x + FV terms -> failure x + K tokn -> failure x + E -> failure x + + +transTokn :: Tokn -> Result +transTokn x = case x of + KS str -> failure x + KP strs variants -> failure x + + +transAssign :: Assign -> Result +transAssign x = case x of + Ass label term -> failure x + + +transCase :: Case -> Result +transCase x = case x of + Cas patts term -> failure x + + +transVariant :: Variant -> Result +transVariant x = case x of + Var strs0 strs -> failure x + + +transLabel :: Label -> Result +transLabel x = case x of + L id -> failure x + LV n -> failure x + + +transArgVar :: ArgVar -> Result +transArgVar x = case x of + A id n -> failure x + AB id n0 n -> failure x + + +transPatt :: Patt -> Result +transPatt x = case x of + PC cident patts -> failure x + PV id -> failure x + PW -> failure x + PR pattassigns -> failure x + + +transPattAssign :: PattAssign -> Result +transPattAssign x = case x of + PAss label patt -> failure x + + + diff --git a/src/GF/Canon/TestGFC.hs b/src/GF/Canon/TestGFC.hs new file mode 100644 index 000000000..2210f4df3 --- /dev/null +++ b/src/GF/Canon/TestGFC.hs @@ -0,0 +1,25 @@ +-- automatically generated by BNF Converter +module TestGFC where + +import LexGFC +import ParGFC +import SkelGFC +import PrintGFC +import AbsGFC + +import ErrM + +type ParseFun a = [Token] -> Err a + +myLLexer = myLexer + +runFile :: (Print a, Show a) => ParseFun a -> FilePath -> IO() +runFile p f = readFile f >>= run p + +run :: (Print a, Show a) => ParseFun a -> String -> IO() +run p s = case (p (myLLexer s)) of + Bad s -> do putStrLn "\nParse Failed...\n" + putStrLn s + Ok tree -> do putStrLn "\nParse Successful!" + putStrLn $ "\n[Abstract Syntax]\n\n" ++ show tree + putStrLn $ "\n[Linearized tree]\n\n" ++ printTree tree diff --git a/src/GF/Canon/Unlex.hs b/src/GF/Canon/Unlex.hs new file mode 100644 index 000000000..f665f4c85 --- /dev/null +++ b/src/GF/Canon/Unlex.hs @@ -0,0 +1,37 @@ +module Unlex where + +import Operations +import Str + +import Char +import List (isPrefixOf) + +-- elementary text postprocessing. AR 21/11/2001 + +formatAsText :: String -> String +formatAsText = unwords . format . cap . words where + format ws = case ws of + w : c : ww | major c -> (w ++ c) : format (cap ww) + w : c : ww | minor c -> (w ++ c) : format ww + c : ww | para c -> "\n\n" : format ww + w : ww -> w : format ww + [] -> [] + cap (p:(c:cs):ww) | para p = p : (toUpper c : cs) : ww + cap ((c:cs):ww) = (toUpper c : cs) : ww + cap [] = [] + major = flip elem (map (:[]) ".!?") + minor = flip elem (map (:[]) ",:;") + para = (=="<p>") + +unlex :: [Str] -> String +unlex = formatAsText . performBinds . concat . map sstr . take 1 ---- + +-- modified from GF/src/Text by adding hyphen +performBinds :: String -> String +performBinds = unwords . format . words where + format ws = case ws of + w : "-" : u : ws -> format ((w ++ "-" ++ u) : ws) + w : "&+" : u : ws -> format ((w ++ u) : ws) + w : ws -> w : format ws + [] -> [] + diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs new file mode 100644 index 000000000..544214cb9 --- /dev/null +++ b/src/GF/Compile/CheckGrammar.hs @@ -0,0 +1,665 @@ +module CheckGrammar where + +import Grammar +import Ident +import Modules +import Refresh ---- + +import TypeCheck + +import PrGrammar +import Lookup +import LookAbs +import Macros +import ReservedWords ---- +import PatternMatch + +import Operations +import CheckM + +import List +import Monad + +-- AR 4/12/1999 -- 1/4/2000 -- 8/9/2001 -- 15/5/2002 -- 27/11/2002 -- 18/6/2003 + +-- type checking also does the following modifications: +-- * types of operations and local constants are inferred and put in place +-- * both these types and linearization types are computed +-- * tables are type-annotated + +showCheckModule :: [SourceModule] -> SourceModule -> Err ([SourceModule],String) +showCheckModule mos m = do + (st,(_,msg)) <- checkStart $ checkModule mos m + return (st, unlines $ reverse msg) + +-- checking is performed in dependency order of modules + +checkModule :: [SourceModule] -> SourceModule -> Check [SourceModule] +checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod of + + ModMod mo@(Module mt fs me ops js) -> case mt of + MTAbstract -> do + js' <- mapMTree (checkAbsInfo gr name) js + return $ (name, ModMod (Module mt fs me ops js')) : ms + + MTResource -> do + js' <- mapMTree (checkResInfo gr) js + return $ (name, ModMod (Module mt fs me ops js')) : ms + + MTConcrete a -> do + ModMod abs <- checkErr $ lookupModule gr a + checkCompleteGrammar abs mo + js' <- mapMTree (checkCncInfo gr name (a,abs)) js + return $ (name, ModMod (Module mt fs me ops js')) : ms + _ -> return $ (name,mod) : ms + where + gr = MGrammar $ (name,mod):ms + +checkAbsInfo :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info) +checkAbsInfo st m (c,info) = do +---- checkReservedId c + case info of + AbsCat (Yes cont) _ -> mkCheck "category" $ + checkContext st cont ---- also cstrs + AbsFun (Yes typ) (Yes d) -> mkCheck "function" $ + checkTyp st typ ----- ++ + ----- checkEquation st (m,c) d ---- also if there's no def! + _ -> return (c,info) + where + mkCheck cat ss = case ss of + [] -> return (c,info) + ["[]"] -> return (c,info) ---- + _ -> checkErr $ prtBad (unlines ss ++++ "in" +++ cat) c + +checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check () +checkCompleteGrammar abs cnc = mapM_ checkWarn $ + checkComplete [f | (f, AbsFun (Yes _) _) <- abs'] cnc' + where + abs' = tree2list $ jments abs + cnc' = mapTree fst $ jments cnc + checkComplete sought given = foldr ckOne [] sought + where + ckOne f = if isInBinTree f given + then id + else (("Warning: no linearization of" +++ prt f):) + +-- General Principle: only Yes-values are checked. +-- A May-value has always been checked in its origin module. + +checkResInfo :: SourceGrammar -> (Ident,Info) -> Check (Ident,Info) +checkResInfo gr (c,info) = do + checkReservedId c + case info of + + ResOper pty pde -> chIn "operation" $ do + (pty', pde') <- case (pty,pde) of + (Yes ty, Yes de) -> do + ty' <- check ty typeType >>= comp . fst + (de',_) <- check de ty' + return (Yes ty', Yes de') + (Nope, Yes de) -> do + (de',ty') <- infer de + return (Yes ty', Yes de') + _ -> return (pty, pde) --- other cases are uninteresting + return (c, ResOper pty' pde') + + ResParam (Yes pcs) -> chIn "parameter type" $ do + mapM_ ((mapM_ (checkIfParType gr . snd)) . snd) pcs + return (c,info) + + _ -> return (c,info) + where + infer = inferLType gr + check = checkLType gr + chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") + comp = computeLType gr + +checkCncInfo :: SourceGrammar -> Ident -> (Ident,SourceAbs) -> + (Ident,Info) -> Check (Ident,Info) +checkCncInfo gr m (a,abs) (c,info) = do + checkReservedId c + case info of + + CncFun _ (Yes trm) mpr -> chIn "linearization of" $ do + typ <- checkErr $ lookupFunTypeSrc gr a c + cat0 <- checkErr $ valCat typ + (cont,val) <- linTypeOfType gr m typ -- creates arg vars + (trm',_) <- check trm (mkFunType (map snd cont) val) -- erases arg vars + checkPrintname gr mpr + cat <- return $ snd cat0 + return (c, CncFun (Just (cat,(cont,val))) (Yes trm') mpr) + -- cat for cf, typ for pe + + CncCat (Yes typ) mdef mpr -> chIn "linearization type of" $ do + typ' <- checkIfLinType gr typ + mdef' <- case mdef of + Yes def -> do + (def',_) <- checkLType gr def (mkFunType [typeStr] typ) + return $ Yes def' + _ -> return mdef + checkPrintname gr mpr + return (c,CncCat (Yes typ') mdef' mpr) + + _ -> return (c,info) + + where + env = gr + infer = inferLType gr + comp = computeLType gr + check = checkLType gr + chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") + +checkIfParType :: SourceGrammar -> Type -> Check () +checkIfParType st typ = checkCond ("Not parameter type" +++ prt typ) (isParType typ) + where + isParType ty = True ---- +{- case ty of + Cn typ -> case lookupConcrete st typ of + Ok (CncParType _ _ _) -> True + Ok (CncOper _ ty' _) -> isParType ty' + _ -> False + Q p t -> case lookupInPackage st (p,t) of + Ok (CncParType _ _ _) -> True + _ -> False + RecType r -> all (isParType . snd) r + _ -> False +-} + +checkIfStrType :: SourceGrammar -> Type -> Check () +checkIfStrType st typ = case typ of + Table arg val -> do + checkIfParType st arg + checkIfStrType st val + _ | typ == typeStr -> return () + _ -> prtFail "not a string type" typ + + +checkIfLinType :: SourceGrammar -> Type -> Check Type +checkIfLinType st typ0 = do + typ <- computeLType st typ0 + case typ of + RecType r -> do + let (lins,ihs) = partition (isLinLabel .fst) r + --- checkErr $ checkUnique $ map fst r + mapM_ checkInh ihs + mapM_ checkLin lins + _ -> prtFail "a linearization type must be a record type instead of" typ + return typ + + where + checkInh (label,typ) = checkIfParType st typ + checkLin (label,typ) = checkIfStrType st typ + + +computeLType :: SourceGrammar -> Type -> Check Type +computeLType gr t = do + g0 <- checkGetContext + let g = [(x, Vr x) | (x,_) <- g0] + checkInContext g $ comp t + where + comp ty = case ty of + + Q m ident -> do + ty' <- checkErr (lookupResDef gr m ident) + if ty' == ty then return ty else comp ty' --- is this necessary to test? + + Vr ident -> checkLookup ident -- never needed to compute! + + App f a -> do + f' <- comp f + a' <- comp a + case f' of + Abs x b -> checkInContext [(x,a')] $ comp b + _ -> return $ App f' a' + + Prod x a b -> do + a' <- comp a + b' <- checkInContext [(x,Vr x)] $ comp b + return $ Prod x a' b' + + Abs x b -> do + b' <- checkInContext [(x,Vr x)] $ comp b + return $ Abs x b' + + ExtR r s -> do + r' <- comp r + s' <- comp s + case (r',s') of + (RecType rs, RecType ss) -> return $ RecType (rs ++ ss) + _ -> return $ ExtR r' s' + + _ | isPredefConstant ty -> return ty + + _ -> composOp comp ty + +checkPrintname :: SourceGrammar -> Perh Term -> Check () +checkPrintname st (Yes t) = checkLType st t typeStr >> return () +checkPrintname _ _ = return () + +-- for grammars obtained otherwise than by parsing ---- update!! +checkReservedId :: Ident -> Check () +checkReservedId x = let c = prt x in + if isResWord c + then checkWarn ("Warning: reserved word used as identifier:" +++ c) + else return () + +-- the underlying algorithms + +inferLType :: SourceGrammar -> Term -> Check (Term, Type) +inferLType gr trm = case trm of + + Q m ident -> checks [ + termWith trm $ checkErr (lookupResType gr m ident) + , + checkErr (lookupResDef gr m ident) >>= infer + , + prtFail "cannot infer type of constant" trm + ] + + QC m ident -> checks [ + termWith trm $ checkErr (lookupResType gr m ident) + , + checkErr (lookupResDef gr m ident) >>= infer + , + prtFail "cannot infer type of canonical constant" trm + ] + + Vr ident -> termWith trm $ checkLookup ident + + App f a -> do + (f',fty) <- infer f + fty' <- comp fty + case fty' of + Prod z arg val -> do + a' <- justCheck a arg + ty <- if isWildIdent z + then return val + else substituteLType [(z,a')] val + return (App f' a',ty) + _ -> prtFail ("function type expected for" +++ prt f +++ "instead of") fty + + S f x -> do + (f', fty) <- infer f + case fty of + Table arg val -> do + x'<- justCheck x arg + return (S f' x', val) + _ -> prtFail "table lintype expected for the table in" trm + + P t i -> do + (t',ty) <- infer t --- ?? + ty' <- comp ty + termWith (P t' i) $ checkErr $ case ty' of + RecType ts -> maybeErr ("unknown label" +++ show i +++ "in" +++ show ty') $ + lookup i ts + _ -> prtBad ("record type expected for" +++ prt t +++ "instead of") ty' + + R r -> do + let (ls,fs) = unzip r + fsts <- mapM inferM fs + let ts = [ty | (Just ty,_) <- fsts] + checkCond ("cannot infer type of record"+++ prt trm) (length ts == length fsts) + return $ (R (zip ls fsts), RecType (zip ls ts)) + + T (TTyped arg) pts -> do + (_,val) <- checks $ map (inferCase (Just arg)) pts + check trm (Table arg val) + T (TComp arg) pts -> do + (_,val) <- checks $ map (inferCase (Just arg)) pts + check trm (Table arg val) + T ti pts -> do -- tries to guess: good in oper type inference + let pts' = [pt | pt@(p,_) <- pts, isConstPatt p] + if null pts' + then prtFail "cannot infer table type of" trm + else do + (arg,val) <- checks $ map (inferCase Nothing) pts' + check trm (Table arg val) + + K s -> do + if elem ' ' s + then checkWarn ("Warning: space in token \"" ++ s ++ + "\". Lexical analysis may fail.") + else return () + return (trm, typeTok) + + EInt i -> return (trm, typeInt) + + Empty -> return (trm, typeTok) + + C s1 s2 -> + check2 (flip justCheck typeStr) C s1 s2 typeStr + + Glue s1 s2 -> + check2 (flip justCheck typeStr) Glue s1 s2 typeStr ---- typeTok + + Strs ts -> do + ts' <- mapM (\t -> justCheck t typeStr) ts + return (Strs ts', typeStrs) + + Alts (t,aa) -> do + t' <- justCheck t typeStr + aa' <- flip mapM aa (\ (c,v) -> do + c' <- justCheck c typeStr + v' <- justCheck v typeStrs + return (c',v')) + return (Alts (t',aa'), typeStr) + + RecType r -> do + let (ls,ts) = unzip r + ts' <- mapM (flip justCheck typeType) ts + return (RecType (zip ls ts'), typeType) + + ExtR r s -> do + (r',rT) <- infer r + rT' <- comp rT + (s',sT) <- infer s + sT' <- comp sT + let trm' = ExtR r' s' + case (rT', sT') of + (RecType rs, RecType ss) -> return (trm', RecType (rs ++ ss)) + _ | rT' == typeType && sT' == typeType -> return (trm', typeType) + _ -> prtFail "records or record types expected in" trm + + Sort _ -> + termWith trm $ return typeType + + Prod x a b -> do + a' <- justCheck a typeType + b' <- checkInContext [(x,a')] $ justCheck b typeType + return (Prod x a' b', typeType) + + Table p t -> do + p' <- justCheck p typeType --- check p partype! + t' <- justCheck t typeType + return $ (Table p' t', typeType) + + FV vs -> do + (ty,_) <- checks $ map infer vs +--- checkIfComplexVariantType trm ty + check trm ty + + _ -> prtFail "cannot infer lintype of" trm + + where + env = gr + infer = inferLType env + comp = computeLType env + + check = checkLType env + + justCheck ty te = check ty te >>= return . fst + + -- for record fields, which may be typed + inferM (mty, t) = do + (t', ty') <- case mty of + Just ty -> check ty t + _ -> infer t + return (Just ty',t') + + inferCase mty (patt,term) = do + arg <- maybe (inferPatt patt) return mty + cont <- pattContext env arg patt + i <- checkUpdates cont + (_,val) <- infer term + checkResets i + return (arg,val) + isConstPatt p = case p of + PC _ ps -> True --- all isConstPatt ps + PP _ _ ps -> True --- all isConstPatt ps + PR ps -> all (isConstPatt . snd) ps + PT _ p -> isConstPatt p + _ -> False + + inferPatt p = case p of + PP q c ps -> checkErr $ lookupResType gr q c >>= valTypeCnc + _ -> infer (patt2term p) >>= return . snd + +checkLType :: SourceGrammar -> Term -> Type -> Check (Term, Type) +checkLType env trm typ0 = do + + typ <- comp typ0 + + case trm of + + Abs x c -> do + case typ of + Prod z a b -> do + checkUpdate (x,a) + (c',b') <- if isWildIdent z + then check c b + else do + b' <- checkIn "abs" $ substituteLType [(z,Vr x)] b + check c b' + checkReset + return $ (Abs x c', Prod x a b') + _ -> prtFail "product expected instead of" typ + + T _ [] -> + prtFail "found empty table in type" typ + T _ cs -> case typ of + Table arg val -> do + case allParamValues env arg of + Ok vs -> do + let ps0 = map fst cs + ps <- checkErr $ testOvershadow ps0 vs + if null ps + then return () + else checkWarn $ "Warning: patterns never reached:" +++ + concat (intersperse ", " (map prt ps)) + + _ -> return () -- happens with variable types + cs' <- mapM (checkCase arg val) cs + return (T (TTyped arg) cs', typ) + _ -> prtFail "table type expected for table instead of" typ + + R r -> case typ of --- why needed? because inference may be too difficult + RecType rr -> do + let (ls,_) = unzip rr -- labels of expected type + fsts <- mapM (checkM r) rr -- check that they are found in the record + return $ (R fsts, typ) -- normalize record + + _ -> prtFail "record type expected in type checking instead of" typ + + ExtR r s -> case typ of + _ | typ == typeType -> do + trm' <- comp trm + case trm' of + RecType _ -> termWith trm $ return typeType + _ -> prtFail "invalid record type extension" trm + RecType rr -> checks [ + do (r',ty) <- infer r + case ty of + RecType rr1 -> do + s' <- justCheck s (minusRecType rr rr1) + return $ (ExtR r' s', typ) + _ -> prtFail "record type expected in extension of" r + , + do (s',ty) <- infer s + case ty of + RecType rr2 -> do + r' <- justCheck r (minusRecType rr rr2) + return $ (ExtR r' s', typ) + _ -> prtFail "record type expected in extension with" s + ] + _ -> prtFail "record extension not meaningful for" typ + + FV vs -> do + ttys <- mapM (flip check typ) vs +--- checkIfComplexVariantType trm typ + return (FV (map fst ttys), typ) --- typ' ? + + S tab arg -> do + (tab',ty) <- infer tab + ty' <- comp ty + case ty' of + Table p t -> do + (arg',val) <- check arg p + checkEq typ t trm + return (S tab' arg', t) + _ -> prtFail "table type expected for applied table instead of" ty' + + Let (x,(mty,def)) body -> case mty of + Just ty -> do + (def',ty') <- check def ty + checkUpdate (x,ty') + body' <- justCheck body typ + checkReset + return (Let (x,(Just ty',def')) body', typ) + _ -> do + (def',ty) <- infer def -- tries to infer type of local constant + check (Let (x,(Just ty,def')) body) typ + + _ -> do + (trm',ty') <- infer trm + termWith trm' $ checkEq typ ty' trm' + where + cnc = env + infer = inferLType env + comp = computeLType env + + check = checkLType env + + justCheck ty te = check ty te >>= return . fst + + checkEq = checkEqLType env + + minusRecType rr rr1 = RecType [(l,v) | (l,v) <- rr, notElem l (map fst rr1)] + + checkM rms (l,ty) = case lookup l rms of + Just (Just ty0,t) -> do + checkEq ty ty0 t + (t',ty') <- check t ty + return (l,(Just ty',t')) + Just (_,t) -> do + (t',ty') <- check t ty + return (l,(Just ty',t')) + _ -> prtFail "cannot find value for label" l + + checkCase arg val (p,t) = do + cont <- pattContext env arg p + i <- checkUpdates cont + t' <- justCheck t val + checkResets i + return (p,t') + +pattContext :: LTEnv -> Type -> Patt -> Check Context +pattContext env typ p = case p of + PV x -> return [(x,typ)] + PP q c ps -> do + t <- checkErr $ lookupResType cnc q c + (cont,v) <- checkErr $ typeFormCnc t + checkCond ("wrong number of arguments for constructor in" +++ prt p) + (length cont == length ps) + checkEqLType env typ v (patt2term p) + mapM (uncurry (pattContext env)) (zip (map snd cont) ps) >>= return . concat + PR r -> do + typ' <- computeLType env typ + case typ' of + RecType t -> do + let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]] + mapM (uncurry (pattContext env)) pts >>= return . concat + _ -> prtFail "record type expected for pattern instead of" typ' + PT t p' -> do + checkEqLType env typ t (patt2term p') + pattContext env typ p' + + _ -> return [] ---- + where + cnc = env + +-- auxiliaries + +type LTEnv = SourceGrammar + +termWith :: Term -> Check Type -> Check (Term, Type) +termWith t ct = do + ty <- ct + return (t,ty) + +-- light-weight substitution for dep. types +substituteLType :: Context -> Type -> Check Type +substituteLType g t = case t of + Vr x -> return $ maybe t id $ lookup x g + _ -> composOp (substituteLType g) t + +-- compositional check/infer of binary operations +check2 :: (Term -> Check Term) -> (Term -> Term -> Term) -> + Term -> Term -> Type -> Check (Term,Type) +check2 chk con a b t = do + a' <- chk a + b' <- chk b + return (con a' b', t) + +checkEqLType :: LTEnv -> Type -> Type -> Term -> Check Type +checkEqLType env t u trm = do + t' <- comp t + u' <- comp u + if alpha [] t' u' + then return t' + else raise ("type of" +++ prt trm +++ + ": expected" +++ prt t' ++ ", inferred" +++ prt u') + where + alpha g t u = case (t,u) of --- quick hack version of TC.eqVal + (Prod x a b, Prod y c d) -> alpha g a c && alpha ((x,y):g) b d + + ---- this should be made in Rename + (Q m a, Q n b) | a == b -> elem m (allExtends env n) + || elem n (allExtends env m) + (QC m a, QC n b) | a == b -> elem m (allExtends env n) + || elem n (allExtends env m) + + (RecType rs, RecType ts) -> and [alpha g a b && l == k --- too strong req + | ((l,a),(k,b)) <- zip rs ts] + || -- if fails, try subtyping: + all (\ (l,a) -> + any (\ (k,b) -> alpha g a b && l == k) ts) rs + + (Table a b, Table c d) -> alpha g a c && alpha g b d + (Vr x, Vr y) -> x == y || elem (x,y) g || elem (y,x) g + _ -> t == u + --- the following should be one-way coercions only. AR 4/1/2001 + || elem t sTypes && elem u sTypes + || (t == typeType && u == typePType) + || (u == typeType && t == typePType) + + sTypes = [typeStr, typeTok, typeString] + comp = computeLType env + +-- linearization types and defaults + +linTypeOfType :: SourceGrammar -> Ident -> Type -> Check (Context,Type) +linTypeOfType cnc m typ = do + (cont,cat) <- checkErr $ typeSkeleton typ + val <- lookLin cat + args <- mapM mkLinArg (zip [0..] cont) + return (args, val) + where + mkLinArg (i,(n,mc@(m,cat))) = do + val <- lookLin mc + let vars = mkRecType varLabel $ replicate n typeStr + symb = argIdent n cat i + rec <- checkErr $ errIn ("extending" +++ prt vars +++ "with" +++ prt val) $ + plusRecType vars val + return (symb,rec) + lookLin (_,c) = checks [ --- rather: update with defLinType ? + checkErr (lookupLincat cnc m c) >>= computeLType cnc + ,return defLinType + ] + +{- +-- check if a type is complex in variants +-- Not so useful as one might think, since variants of a complex type +-- can be created indirectly: f (variants {True,False}) + +checkIfComplexVariantType :: Term -> Type -> Check () +checkIfComplexVariantType e t = case t of + Prod _ _ _ -> cs + Table _ _ -> cs + RecType (_:_:_) -> cs + _ -> return () + where + cs = case e of + FV (_:_) -> checkWarn $ "Warning:" +++ prt e +++ "has complex type" +++ prt t + _ -> return () + +-} diff --git a/src/GF/Compile/Compile.hs b/src/GF/Compile/Compile.hs new file mode 100644 index 000000000..1e49946a6 --- /dev/null +++ b/src/GF/Compile/Compile.hs @@ -0,0 +1,207 @@ +module Compile where + +import Grammar +import Ident +import Option +import PrGrammar +import Update +import Lookup +import Modules +import ModDeps +import ReadFiles +import ShellState +import MkResource + +-- the main compiler passes +import GetGrammar +import Rename +import Refresh +import CheckGrammar +import Optimize +import GrammarToCanon +import Share + +import qualified CanonToGrammar as CG + +import qualified GFC +import qualified MkGFC +import GetGFC + +import Operations +import UseIO +import Arch + +import Monad + +-- in batch mode: write code in a file + +batchCompile f = liftM fst $ compileModule defOpts emptyShellState f + where + defOpts = options [beVerbose, emitCode] +batchCompileOpt f = liftM fst $ compileModule defOpts emptyShellState f + where + defOpts = options [beVerbose, emitCode, optimizeCanon] + +batchCompileOld f = compileOld defOpts f + where + defOpts = options [beVerbose, emitCode] + +-- compile with one module as starting point + +compileModule :: Options -> ShellState -> FilePath -> + IOE (GFC.CanonGrammar, (SourceGrammar,[(FilePath,ModTime)])) +compileModule opts st file = do + let ps = pathListOpts opts + ioeIO $ print ps ---- + let putp = putPointE opts + let rfs = readFiles st + files <- getAllFiles ps rfs file + ioeIO $ print files ---- + let names = map (fileBody . justFileName) files + ioeIO $ print names ---- + let env0 = compileEnvShSt st names + (_,sgr,cgr) <- foldM (compileOne opts) env0 files + t <- ioeIO getNowTime + return $ (reverseModules cgr, -- to preserve dependency order + (reverseModules sgr, --- keepResModules opts sgr, --- keep all so far + [(f,t) | f <- files])) -- pass on the time of creation + +compileEnvShSt :: ShellState -> [ModName] -> CompileEnv +compileEnvShSt st fs = (0,sgr,cgr) where + cgr = MGrammar [m | m@(i,_) <- modules (canModules st), notInc i] + sgr = MGrammar [m | m@(i,_) <- modules (srcModules st), notIns i] + notInc i = notElem (prt i) $ map fileBody fs + notIns i = notElem (prt i) $ map fileBody fs + +pathListOpts :: Options -> [InitPath] +pathListOpts opts = maybe [""] pFilePaths $ getOptVal opts pathList + +reverseModules (MGrammar ms) = MGrammar $ reverse ms + +keepResModules :: Options -> SourceGrammar -> SourceGrammar +keepResModules opts gr = + if oElem retainOpers opts + then MGrammar $ reverse [(i,mi) | (i,mi) <- modules gr, isResourceModule mi] + else emptyMGrammar + + +-- the environment + +type CompileEnv = (Int,SourceGrammar, GFC.CanonGrammar) + +emptyCompileEnv :: CompileEnv +emptyCompileEnv = (0,emptyMGrammar,emptyMGrammar) + +extendCompileEnvInt (_,MGrammar ss, MGrammar cs) (k,sm,cm) = + return (k,MGrammar (sm:ss), MGrammar (cm:cs)) --- reverse later + +extendCompileEnv (k,s,c) (sm,cm) = extendCompileEnvInt (k,s,c) (k,sm,cm) + +compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv +compileOne opts env file = do + + let putp = putPointE opts + let gf = fileSuffix file + let path = justInitPath file + let name = fileBody file + + case gf of + -- for canonical gf, just read the file and update environment + "gfc" -> do + cm <- putp ("+ reading" +++ file) $ getCanonModule file + sm <- ioeErr $ CG.canon2sourceModule cm + extendCompileEnv env (sm, cm) + + -- for compiled resource, parse and organize, then update environment + "gfr" -> do + sm0 <- putp ("| parsing" +++ file) $ getSourceModule file + let mos = case env of (_,gr,_) -> modules gr + sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm0 + let gfc = gfcFile name + cm <- putp ("+ reading" +++ gfc) $ getCanonModule gfc + extendCompileEnv env (sm,cm) + + -- for gf source, do full compilation + _ -> do + sm0 <- putp ("- parsing" +++ file) $ getSourceModule file + (k',sm) <- makeSourceModule opts env sm0 + cm <- putp " generating code... " $ generateModuleCode opts path sm + extendCompileEnvInt env (k',sm,cm) + +-- dispatch reused resource at early stage + +makeSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule) +makeSourceModule opts env@(k,gr,can) mo@(i,mi) = case mi of + + ModMod m -> case mtype m of + MTReuse c -> do + sm <- ioeErr $ makeReuse gr i (extends m) c + let mo2 = (i, ModMod sm) + mos = modules gr + putp " type checking reused" $ ioeErr $ showCheckModule mos mo2 + return $ (k,mo2) + _ -> compileSourceModule opts env mo + where + putp = putPointE opts + +compileSourceModule :: Options -> CompileEnv -> SourceModule -> + IOE (Int,SourceModule) +compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do + + let putp = putPointE opts + mos = modules gr + + mo2:_ <- putp " renaming " $ ioeErr $ renameModule mos mo + + (mo3:_,warnings) <- putp " type checking" $ ioeErr $ showCheckModule mos mo2 + putStrE warnings + + (k',mo3r:_) <- ioeErr $ refreshModule (k,mos) mo3 + + mo4:_ <- putp " optimizing" $ ioeErr $ evalModule mos mo3r + + return (k',mo4) + +generateModuleCode :: Options -> InitPath -> SourceModule -> IOE GFC.CanonModule +generateModuleCode opts path minfo@(name,info) = do + let pname = prefixPathName path (prt name) + minfo0 <- ioeErr $ redModInfo minfo + minfo' <- return $ if optim + then shareModule fullOpt minfo0 -- parametrization and sharing + else shareModule basicOpt minfo0 -- sharing only + + -- for resource, also emit gfr + case info of + ModMod m | mtype m == MTResource && emit && nomulti -> do + let (file,out) = (gfrFile pname, prGrammar (MGrammar [minfo])) + ioeIO $ writeFile file out >> putStr (" wrote file" +++ file) + _ -> return () + (file,out) <- do + code <- return $ MkGFC.prCanonModInfo minfo' + return (gfcFile pname, code) + if emit && nomulti + then ioeIO $ writeFile file out >> putStr (" wrote file" +++ file) + else return () + return minfo' + where + nomulti = not $ oElem makeMulti opts + emit = oElem emitCode opts + optim = oElem optimizeCanon opts + +-- for old GF: sort into modules, write files, compile as usual + +compileOld :: Options -> FilePath -> IOE GFC.CanonGrammar +compileOld opts file = do + let putp = putPointE opts + grammar1 <- putp ("- parsing old gf" +++ file) $ getOldGrammar file + files <- mapM writeNewGF $ modules grammar1 + (_,_,grammar) <- foldM (compileOne opts) emptyCompileEnv files + return grammar + +writeNewGF :: SourceModule -> IOE FilePath +writeNewGF m@(i,_) = do + let file = gfFile $ prt i + ioeIO $ writeFile file $ prGrammar (MGrammar [m]) + ioeIO $ putStrLn $ "wrote file" +++ file + return file + diff --git a/src/GF/Compile/Extend.hs b/src/GF/Compile/Extend.hs new file mode 100644 index 000000000..66a632445 --- /dev/null +++ b/src/GF/Compile/Extend.hs @@ -0,0 +1,77 @@ +module Extend where + +import Grammar +import Ident +import PrGrammar +import Modules +import Update +import Macros +import Operations + +import Monad + +-- AR 14/5/2003 + +-- The top-level function $extendModInfo$ +-- extends a module symbol table by indirections to the module it extends + +extendModInfo :: Ident -> SourceModInfo -> SourceModInfo -> Err SourceModInfo +extendModInfo name old new = case (old,new) of + (ModMod m0, ModMod (Module mt fs _ ops js)) -> do + testErr (mtype m0 == mt) ("illegal extension type at module" +++ show name) + js' <- extendMod name (jments m0) js + return $ ModMod (Module mt fs Nothing ops js) + +-- this is what happens when extending a module: new information is inserted, +-- and the process is interrupted if unification fails + +extendMod :: Ident -> BinTree (Ident,Info) -> BinTree (Ident,Info) -> + Err (BinTree (Ident,Info)) +extendMod name old new = + foldM (tryInsert (extendAnyInfo name) (indirInfo name)) new $ tree2list old + +indirInfo :: Ident -> Info -> Info +indirInfo n info = AnyInd b n' where + (b,n') = case info of + ResValue _ -> (True,n) + ResParam _ -> (True,n) + AnyInd b k -> (b,k) + _ -> (False,n) ---- canonical in Abs + +{- ---- +case info of + AbsFun pty ptr -> AbsFun (perhIndir n pty) (perhIndir n ptr) + ---- find a suitable indirection for cat info! + + ResOper pty ptr -> ResOper (perhIndir n pty) (perhIndir n ptr) + ResParam pp -> ResParam (perhIndir n pp) + _ -> info + + CncCat pty ptr ppr -> CncCat (perhIndir n pty) (perhIndir n ptr) (perhIndir n ppr) + CncFun m ptr ppr -> CncFun m (perhIndir n ptr) (perhIndir n ppr) +-} + +perhIndir :: Ident -> Perh a -> Perh a +perhIndir n p = case p of + Yes _ -> May n + _ -> p + +extendAnyInfo :: Ident -> Info -> Info -> Err Info +extendAnyInfo n i j = case (i,j) of + (AbsCat mc1 mf1, AbsCat mc2 mf2) -> + liftM2 AbsCat (updatePerhaps n mc1 mc2) (updatePerhaps n mf1 mf2) --- add cstrs + (AbsFun mt1 md1, AbsFun mt2 md2) -> + liftM2 AbsFun (updatePerhaps n mt1 mt2) (updatePerhaps n md1 md2) --- add defs + + (ResParam mt1, ResParam mt2) -> liftM ResParam $ updatePerhaps n mt1 mt2 + (ResValue mt1, ResValue mt2) -> liftM ResValue $ updatePerhaps n mt1 mt2 + (ResOper mt1 m1, ResOper mt2 m2) -> + liftM2 ResOper (updatePerhaps n mt1 mt2) (updatePerhaps n m1 m2) + + (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> + liftM3 CncCat (updatePerhaps n mc1 mc2) + (updatePerhaps n mf1 mf2) (updatePerhaps n mp1 mp2) + (CncFun m mt1 md1, CncFun _ mt2 md2) -> + liftM2 (CncFun m) (updatePerhaps n mt1 mt2) (updatePerhaps n md1 md2) + + _ -> Bad $ "cannot unify information for" +++ show n diff --git a/src/GF/Compile/GetGrammar.hs b/src/GF/Compile/GetGrammar.hs new file mode 100644 index 000000000..fb3fbf5ad --- /dev/null +++ b/src/GF/Compile/GetGrammar.hs @@ -0,0 +1,71 @@ +module GetGrammar where + +import Operations +import qualified ErrM as E ---- + +import UseIO +import Grammar +import Modules +import PrGrammar +import qualified AbsGF as A +import SourceToGrammar +---- import Macros +---- import Rename +import Option +--- import Custom +import ParGF + +import ReadFiles ---- + +import List (nub) +import Monad (foldM) + +-- this module builds the internal GF grammar that is sent to the type checker + +getSourceModule :: FilePath -> IOE SourceModule +getSourceModule file = do + string <- readFileIOE file + let tokens = myLexer string + mo1 <- ioeErr $ err2err $ pModDef tokens + ioeErr $ transModDef mo1 + + +-- for old GF format with includes + +getOldGrammar :: FilePath -> IOE SourceGrammar +getOldGrammar file = do + defs <- parseOldGrammarFiles file + let g = A.OldGr A.NoIncl defs + ioeErr $ transOldGrammar g file + +parseOldGrammarFiles :: FilePath -> IOE [A.TopDef] +parseOldGrammarFiles file = do + putStrE $ "reading grammar of old format" +++ file + (_, g) <- getImports "" ([],[]) file + return g -- now we can throw away includes + where + getImports oldInitPath (oldImps, oldG) f = do + (path,s) <- readFileLibraryIOE oldInitPath f + if not (elem path oldImps) + then do + (imps,g) <- parseOldGrammar path + foldM (getImports (initFilePath path)) (path : oldImps, g ++ oldG) imps + else + return (oldImps, oldG) + +parseOldGrammar :: FilePath -> IOE ([FilePath],[A.TopDef]) +parseOldGrammar file = do + putStrE $ "reading old file" +++ file + s <- ioeIO $ readFileIf file + A.OldGr incl topdefs <- ioeErr $ err2err $ pOldGrammar $ myLexer $ fixNewlines s + includes <- ioeErr $ transInclude incl + return (includes, topdefs) + +---- + +err2err :: E.Err a -> Err a +err2err (E.Ok v) = Ok v +err2err (E.Bad s) = Bad s + +ioeEErr = ioeErr . err2err + diff --git a/src/GF/Compile/GrammarToCanon.hs b/src/GF/Compile/GrammarToCanon.hs new file mode 100644 index 000000000..d5977b510 --- /dev/null +++ b/src/GF/Compile/GrammarToCanon.hs @@ -0,0 +1,224 @@ +module GrammarToCanon where + +import Operations +import Zipper +import Option +import Grammar +import Ident +import PrGrammar +import Modules +import Macros +import qualified AbsGFC as G +import qualified GFC as C +import MkGFC +---- import Alias +import qualified PrintGFC as P + +import Monad + +-- compilation of optimized grammars to canonical GF. AR 5/10/2001 -- 12/5/2003 + +-- This is the top-level function printing a gfc file + +showGFC :: SourceGrammar -> String +showGFC = err id id . liftM (P.printTree . grammar2canon) . redGrammar + +-- any grammar, first trying without dependent types + +-- abstract syntax without dependent types + +redGrammar :: SourceGrammar -> Err C.CanonGrammar +redGrammar (MGrammar gr) = liftM MGrammar $ mapM redModInfo gr + +redModInfo :: (Ident, SourceModInfo) -> Err (Ident, C.CanonModInfo) +redModInfo (c,info) = do + c' <- redIdent c + info' <- case info of + ModMod m -> do + (e,os) <- redExtOpen m + flags <- mapM redFlag $ flags m + (a,mt) <- case mtype m of + MTConcrete a -> do + a' <- redIdent a + return (a', MTConcrete a') + MTAbstract -> return (c',MTAbstract) --- c' not needed + MTResource -> return (c',MTResource) --- c' not needed + defss <- mapM (redInfo a) $ tree2list $ jments m + defs <- return $ sorted2tree $ concat defss -- sorted, but reduced + return $ ModMod $ Module mt flags e os defs + return (c',info') + where + redExtOpen m = do + e' <- case extends m of + Just e -> liftM Just $ redIdent e + _ -> return Nothing + os' <- mapM (\ (OQualif _ i) -> liftM OSimple (redIdent i)) $ opens m + return (e',os') + +redInfo :: Ident -> (Ident,Info) -> Err [(Ident,C.Info)] +redInfo am (c,info) = errIn ("translating definition of" +++ prt c) $ do + c' <- redIdent c + case info of + AbsCat (Yes cont) pfs -> do + returns c' $ C.AbsCat cont [] ---- constrs + AbsFun (Yes typ) pdf -> do + returns c' $ C.AbsFun typ (Eqs []) ---- df + + ResParam (Yes ps) -> do + ps' <- mapM redParam ps + returns c' $ C.ResPar ps' + + CncCat pty ptr ppr -> case (pty,ptr) of + (Yes ty, Yes (Abs _ t)) -> do + ty' <- redCType ty + trm' <- redCTerm t + ppr' <- return $ G.FV [] ---- redCTerm + return [(c', C.CncCat ty' trm' ppr')] + _ -> prtBad "cannot reduce rule for" c + + CncFun mt ptr ppr -> case (mt,ptr) of + (Just (cat,_), Yes trm) -> do + cat' <- redIdent cat + (xx,body,_) <- termForm trm + xx' <- mapM redArgvar xx + body' <- errIn (prt body) $ redCTerm body ---- debug + ppr' <- return $ G.FV [] ---- redCTerm + return [(c',C.CncFun (G.CIQ am cat') xx' body' ppr')] + _ -> prtBad ("cannot reduce rule" +++ show info +++ "for") c ---- debug + + AnyInd s b -> do + b' <- redIdent b + returns c' $ C.AnyInd s b' + + _ -> return [] --- retain some operations + where + returns f i = return [(f,i)] + +redQIdent :: QIdent -> Err G.CIdent +redQIdent (m,c) = return $ G.CIQ m c + +redIdent :: Ident -> Err Ident +redIdent x + | isWildIdent x = return $ identC "h_" --- needed in declarations + | otherwise = return $ identC $ prt x --- + +redFlag :: Option -> Err G.Flag +redFlag (Opt (f,[x])) = return $ G.Flg (identC f) (identC x) +redFlag o = Bad $ "cannot reduce option" +++ prOpt o + +redDecl :: Decl -> Err G.Decl +redDecl (x,a) = liftM2 G.Decl (redIdent x) (redType a) + +redType :: Type -> Err G.Exp +redType = redTerm + +redTerm :: Type -> Err G.Exp +redTerm t = return $ rtExp t + +-- resource + +redParam :: Param -> Err G.ParDef +redParam (c,cont) = do + c' <- redIdent c + cont' <- mapM (redCType . snd) cont + return $ G.ParD c' cont' + +redArgvar :: Ident -> Err G.ArgVar +redArgvar x = case x of + IA (x,i) -> return $ G.A (identC x) (toInteger i) + IAV (x,b,i) -> return $ G.AB (identC x) (toInteger b) (toInteger i) + _ -> Bad $ "cannot reduce" +++ show x +++ "as argument variable" + +redLindef :: Term -> Err G.Term +redLindef t = case t of + Abs x b -> redCTerm b --- + _ -> redCTerm t + +redCType :: Type -> Err G.CType +redCType t = case t of + RecType lbs -> do + let (ls,ts) = unzip lbs + ls' = map redLabel ls + ts' <- mapM redCType ts + return $ G.RecType $ map (uncurry G.Lbg) $ zip ls' ts' + Table p v -> liftM2 G.Table (redCType p) (redCType v) + Q m c -> liftM G.Cn $ redQIdent (m,c) + QC m c -> liftM G.Cn $ redQIdent (m,c) + Sort "Str" -> return $ G.TStr + _ -> prtBad "cannot reduce to canonical the type" t + +redCTerm :: Term -> Err G.Term +redCTerm t = case t of + Vr x -> liftM G.Arg $ redArgvar x + App _ _ -> do -- only constructor applications can remain + (_,c,xx) <- termForm t + xx' <- mapM redCTerm xx + case c of + QC p c -> liftM2 G.Con (redQIdent (p,c)) (return xx') + _ -> prtBad "expected constructor head instead of" c + Q p c -> liftM G.I (redQIdent (p,c)) + QC p c -> liftM2 G.Con (redQIdent (p,c)) (return []) + R rs -> do + let (ls,tts) = unzip rs + ls' = map redLabel ls + ts <- mapM (redCTerm . snd) tts + return $ G.R $ map (uncurry G.Ass) $ zip ls' ts + P tr l -> do + tr' <- redCTerm tr + return $ G.P tr' (redLabel l) + T i cs -> do + ty <- getTableType i + ty' <- redCType ty + let (ps,ts) = unzip cs + ps' <- mapM redPatt ps + ts' <- mapM redCTerm ts + return $ G.T ty' $ map (uncurry G.Cas) $ zip (map singleton ps') ts' + S u v -> liftM2 G.S (redCTerm u) (redCTerm v) + K s -> return $ G.K (G.KS s) + C u v -> liftM2 G.C (redCTerm u) (redCTerm v) + FV ts -> liftM G.FV $ mapM redCTerm ts +--- Ready ss -> return $ G.Ready [redStr ss] --- obsolete + + Alts (d,vs) -> do --- + d' <- redCTermTok d + vs' <- mapM redVariant vs + return $ G.K $ G.KP d' vs' + + Empty -> return $ G.E + +--- Strs ss -> return $ G.Strs [s | K s <- ss] --- + +---- Glue obsolete in canon, should not occur here + Glue x y -> redCTerm (C x y) + + _ -> Bad ("cannot reduce term" +++ prt t) + +redPatt :: Patt -> Err G.Patt +redPatt p = case p of + PP m c ps -> liftM2 G.PC (redQIdent (m,c)) (mapM redPatt ps) + PR rs -> do + let (ls,tts) = unzip rs + ls' = map redLabel ls + ts <- mapM redPatt tts + return $ G.PR $ map (uncurry G.PAss) $ zip ls' ts + PT _ q -> redPatt q + _ -> prtBad "cannot reduce pattern" p + +redLabel :: Label -> G.Label +redLabel (LIdent s) = G.L $ identC s +redLabel (LVar i) = G.LV $ toInteger i + +redVariant :: (Term, Term) -> Err G.Variant +redVariant (v,c) = do + v' <- redCTermTok v + c' <- redCTermTok c + return $ G.Var v' c' + +redCTermTok :: Term -> Err [String] +redCTermTok t = case t of + K s -> return [s] + Empty -> return [] + C a b -> liftM2 (++) (redCTermTok a) (redCTermTok b) + Strs ss -> return [s | K s <- ss] --- + _ -> prtBad "cannot get strings from term" t + diff --git a/src/GF/Compile/MkResource.hs b/src/GF/Compile/MkResource.hs new file mode 100644 index 000000000..8b3a01793 --- /dev/null +++ b/src/GF/Compile/MkResource.hs @@ -0,0 +1,75 @@ +module MkResource where + +import Grammar +import Ident +import Modules +import Macros +import PrGrammar + +import Operations + +import Monad + +-- extracting resource r from abstract + concrete syntax +-- AR 21/8/2002 -- 22/6/2003 for GF with modules + +makeReuse :: SourceGrammar -> Ident -> Maybe Ident -> Ident -> Err SourceRes +makeReuse gr r me c = do + mc <- lookupModule gr c + + flags <- return [] --- no flags are passed: they would not make sense + + (ops,jms) <- case mc of + ModMod m -> case mtype m of + MTConcrete a -> do + ma <- lookupModule gr a + jmsA <- case ma of + ModMod m' -> return $ jments m' + _ -> prtBad "expected abstract to be the type of" a + liftM ((,) (opens m)) $ mkResDefs r a me (extends m) jmsA (jments m) + _ -> prtBad "expected concrete to be the type of" c + _ -> prtBad "expected concrete to be the type of" c + + return $ Module MTResource flags me ops jms + +mkResDefs :: Ident -> Ident -> Maybe Ident -> Maybe Ident -> + BinTree (Ident,Info) -> BinTree (Ident,Info) -> + Err (BinTree (Ident,Info)) +mkResDefs r a mext maext abs cnc = mapMTree mkOne abs where + + mkOne (f,info) = case info of + AbsCat _ _ -> do + typ <- err (const (return defLinType)) return $ look f + return (f, ResOper (Yes typeType) (Yes typ)) + AbsFun (Yes typ0) _ -> do + trm <- look f + typ <- redirTyp typ0 --- if isHardType typ0 then compute typ0 else ... + return (f, ResOper (Yes typ) (Yes trm)) + AnyInd b _ -> case mext of + Just ext -> return (f,AnyInd b ext) + _ -> prtBad "no indirection possible in" r + + look f = do + info <- lookupTree prt f cnc + case info of + CncCat (Yes ty) _ _ -> return ty + CncCat _ _ _ -> return defLinType + CncFun _ (Yes tr) _ -> return tr + _ -> prtBad "not enough information to reuse" f + + -- type constant qualifications changed from abstract to resource + redirTyp ty = case ty of + Q n c | n == a -> return $ Q r c + Q n c | Just n == maext -> case mext of + Just ext -> return $ Q ext c + _ -> prtBad "no indirection of type possible in" r + _ -> composOp redirTyp ty + +{- +-- for nicer printing of type signatures: preserves synonyms if not HO/dep type + +isHardType t = case t of + Prod x a b -> not (isWildIdent x) || isHardType a || isHardType b + App _ _ -> True + _ -> False +-} diff --git a/src/GF/Compile/ModDeps.hs b/src/GF/Compile/ModDeps.hs new file mode 100644 index 000000000..2aa042a95 --- /dev/null +++ b/src/GF/Compile/ModDeps.hs @@ -0,0 +1,88 @@ +module ModDeps where + +import Grammar +import Ident +import Option +import PrGrammar +import Update +import Lookup +import Modules + +import Operations + +import Monad + +-- AR 13/5/2003 + +-- to check uniqueness of module names and import names, the +-- appropriateness of import and extend types, +-- to build a dependency graph of modules, and to sort them topologically + +mkSourceGrammar :: [(Ident,SourceModInfo)] -> Err SourceGrammar +mkSourceGrammar ms = do + let ns = map fst ms + checkUniqueErr ns + mapM (checkUniqueImportNames ns . snd) ms + deps <- moduleDeps ms + deplist <- either + return + (\ms -> Bad $ "circular modules" +++ unwords (map show ms)) $ + topoTest deps + return $ MGrammar [(m, maybe undefined id $ lookup m ms) | IdentM m _ <- deplist] + +checkUniqueErr :: (Show i, Eq i) => [i] -> Err () +checkUniqueErr ms = do + let msg = checkUnique ms + if null msg then return () else Bad $ unlines msg + +-- check that import names don't clash with module names + +checkUniqueImportNames :: [Ident] -> SourceModInfo -> Err () +checkUniqueImportNames ns mo = case mo of + ModMod m -> test [n | OQualif n v <- opens m, n /= v] + + where + + test ms = testErr (all (`notElem` ns) ms) + ("import names clashing with module names among" +++ + unwords (map prt ms)) + +-- to decide what modules immediately depend on what, and check if the +-- dependencies are appropriate + +type Dependencies = [(IdentM Ident,[IdentM Ident])] + +moduleDeps :: [(Ident,SourceModInfo)] -> Err Dependencies +moduleDeps ms = mapM deps ms where + deps (c,mi) = errIn ("checking dependencies of module" +++ prt c) $ case mi of + ModMod m -> case mtype m of + MTConcrete a -> do + aty <- lookupModuleType gr a + testErr (aty == MTAbstract) "the for-module is not an abstract syntax" + chDep (IdentM c (MTConcrete a)) + (extends m) (MTConcrete a) (opens m) MTResource + t -> chDep (IdentM c t) (extends m) t (opens m) t + + chDep it es ety os oty = do + ests <- case es of + Just e -> liftM singleton $ lookupModuleType gr e + _ -> return [] + testErr (all (compatMType ety) ests) "inappropriate extension module type" + osts <- mapM (lookupModuleType gr . openedModule) os + testErr (all (==oty) osts) "inappropriate open module type" + let ab = case it of + IdentM _ (MTConcrete a) -> [IdentM a MTAbstract] + _ -> [] ---- + return (it, ab ++ + [IdentM e ety | Just e <- [es]] ++ + [IdentM (openedModule o) oty | o <- os]) + + -- check for superficial compatibility, not submodule relation etc + compatMType mt0 mt = case (mt0,mt) of + (MTConcrete _, MTConcrete _) -> True + (MTResourceImpl _, MTResourceImpl _) -> True + (MTReuse _, MTReuse _) -> True + ---- some more + _ -> mt0 == mt + + gr = MGrammar ms --- hack diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs new file mode 100644 index 000000000..c901c3911 --- /dev/null +++ b/src/GF/Compile/Optimize.hs @@ -0,0 +1,171 @@ +module Optimize where + +import Grammar +import Ident +import Modules +import PrGrammar +import Macros +import Lookup +import Refresh +import Compute +import CheckGrammar +import Update + +import Operations +import CheckM + +import Monad +import List + +-- partial evaluation of concrete syntax. AR 6/2001 -- 16/5/2003 +{- +evalGrammar :: SourceGrammar -> Err SourceGrammar +evalGrammar gr = do + gr2 <- refreshGrammar gr + mos <- foldM evalModule [] $ modules gr2 + return $ MGrammar $ reverse mos +-} +evalModule :: [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) -> + Err [(Ident,SourceModInfo)] +evalModule ms mo@(name,mod) = case mod of + + ModMod (Module mt fs me ops js) -> case mt of + MTResource -> do + let deps = allOperDependencies name js + ids <- topoSortOpers deps + MGrammar (mod' : _) <- foldM evalOp gr ids + return $ mod' : ms + MTConcrete a -> do + js' <- mapMTree (evalCncInfo gr0 name a) js + return $ (name, ModMod (Module mt fs me ops js')) : ms + + _ -> return $ (name,mod):ms + where + gr0 = MGrammar $ ms + gr = MGrammar $ (name,mod) : ms + + evalOp g@(MGrammar ((_, ModMod m) : _)) i = do + info <- lookupTree prt i $ jments m + info' <- evalResInfo gr (i,info) + return $ updateRes g name i info' + +-- only operations need be compiled in a resource, and this is local to each +-- definition since the module is traversed in topological order + +evalResInfo :: SourceGrammar -> (Ident,Info) -> Err Info +evalResInfo gr (c,info) = case info of + + ResOper pty pde -> eIn "operation" $ do + pde' <- case pde of + Yes de -> liftM yes $ comp de + _ -> return pde + return $ ResOper pty pde' + + _ -> return info + where + comp = computeConcrete gr + eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":") + + +evalCncInfo :: + SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info) +evalCncInfo gr cnc abs (c,info) = case info of + + CncCat ptyp pde ppr -> do + + pde' <- case (ptyp,pde) of + (Yes typ, Yes de) -> + liftM yes $ pEval ([(strVar, typeStr)], typ) de + (Yes typ, Nope) -> + liftM yes $ mkLinDefault gr typ >>= pEval ([(strVar, typeStr)],typ) + (May b, Nope) -> + return $ May b + _ -> return pde -- indirection + + ppr' <- return ppr ---- + + return (c, CncCat ptyp pde' ppr') + + CncFun (mt@(Just (_,ty))) pde ppr -> eIn ("linearization in type" +++ + show ty +++ "of") $ do + pde' <- case pde of + Yes de -> do + liftM yes $ pEval ty de + _ -> return pde + ppr' <- case ppr of + Yes pr -> liftM yes $ comp pr + _ -> return ppr + return $ (c, CncFun mt pde' ppr') -- only cat in type actually needed + + _ -> return (c,info) + where + comp = computeConcrete gr + pEval = partEval gr + eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":") + +-- the main function for compiling linearizations + +partEval :: SourceGrammar -> (Context,Type) -> Term -> Err Term +partEval gr (context, val) trm = do + let vars = map fst context + args = map Vr vars + subst = [(v, Vr v) | v <- vars] + trm1 = mkApp trm args + trm2 <- etaExpand val trm1 + trm3 <- comp subst trm2 + return $ mkAbs vars trm3 + + where + + comp g t = {- refreshTerm t >>= -} computeTerm gr g t + + etaExpand val t = recordExpand val t --- >>= caseEx -- done by comp + +-- here we must be careful not to reduce +-- variants {{s = "Auto" ; g = N} ; {s = "Wagen" ; g = M}} +-- {s = variants {"Auto" ; "Wagen"} ; g = variants {N ; M}} ; + +recordExpand :: Type -> Term -> Err Term +recordExpand typ trm = case unComputed typ of + RecType tys -> case trm of + FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs] + _ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys] + _ -> return trm + + +-- auxiliaries for compiling the resource + +allOperDependencies :: Ident -> BinTree (Ident,Info) -> [(Ident,[Ident])] +allOperDependencies m b = + [(f, nub (opty pty ++ opty pt)) | (f, ResOper pty pt) <- tree2list b] + where + opersIn t = case t of + Q n c | n == m -> [c] + _ -> collectOp opersIn t + opty (Yes ty) = opersIn ty + opty _ = [] + +topoSortOpers :: [(Ident,[Ident])] -> Err [Ident] +topoSortOpers st = do + let eops = topoTest st + either return (\ops -> Bad ("circular operations" +++ unwords (map prt (head ops)))) eops + +mkLinDefault :: SourceGrammar -> Type -> Err Term +mkLinDefault gr typ = do + case unComputed typ of + RecType lts -> mapPairsM mkDefField lts >>= (return . Abs strVar . R . mkAssign) + _ -> prtBad "linearization type must be a record type, not" typ + where + mkDefField typ = case unComputed typ of + Table p t -> do + t' <- mkDefField t + let T _ cs = mkWildCases t' + return $ T (TWild p) cs + Sort "Str" -> return $ Vr strVar + QC q p -> lookupFirstTag gr q p + RecType r -> do + let (ls,ts) = unzip r + ts' <- mapM mkDefField ts + return $ R $ [assign l t | (l,t) <- zip ls ts'] + _ -> prtBad "linearization type field cannot be" typ + diff --git a/src/GF/Compile/PGrammar.hs b/src/GF/Compile/PGrammar.hs new file mode 100644 index 000000000..06d9fc72e --- /dev/null +++ b/src/GF/Compile/PGrammar.hs @@ -0,0 +1,58 @@ +module PGrammar where + +---import LexGF +import ParGF +import SourceToGrammar +import Grammar +import Ident +import qualified AbsGFC as A +import qualified GFC as G +import GetGrammar +import Macros + +import Operations + +pTerm :: String -> Err Term +pTerm s = do + e <- err2err $ pExp $ myLexer s + transExp e + +pTrm :: String -> Term +pTrm = errVal (vr (zIdent "x")) . pTerm --- + +pTrms :: String -> [Term] +pTrms = map pTrm . sep [] where + sep t cs = case cs of + ',' : cs2 -> reverse t : sep [] cs2 + c : cs2 -> sep (c:t) cs2 + _ -> [reverse t] + +pTrm' :: String -> [Term] +pTrm' = err (const []) singleton . pTerm + +pMeta :: String -> Integer +pMeta _ = 0 --- + +pzIdent :: String -> Ident +pzIdent = zIdent + +{- +string2formsAndTerm :: String -> ([Term],Term) +string2formsAndTerm s = case s of + '[':_:_ -> case span (/=']') s of + (x,_:y) -> (pTrms (tail x), pTrm y) + _ -> ([],pTrm s) + _ -> ([], pTrm s) + +string2ident :: String -> Err Ident +string2ident s = return $ case s of + c:'_':i -> identV (readIntArg i,[c]) --- + _ -> zIdent s + +-- reads the Haskell datatype +readGrammar :: String -> Err GrammarST +readGrammar s = case [x | (x,t) <- reads s, ("","") <- lex t] of + [x] -> return x + [] -> Bad "no parse of Grammar" + _ -> Bad "ambiguous parse of Grammar" +-} diff --git a/src/GF/Compile/PrOld.hs b/src/GF/Compile/PrOld.hs new file mode 100644 index 000000000..acce0ab67 --- /dev/null +++ b/src/GF/Compile/PrOld.hs @@ -0,0 +1,69 @@ +module PrOld where + +import PrGrammar +import CanonToGrammar +import qualified GFC +import Grammar +import Ident +import Macros +import Modules +import qualified PrintGF as P +import GrammarToSource + +import List +import Operations +import UseIO + +-- a hack to print gf2 into gf1 readable files +-- Works only for canonical grammars, printed into GFC. Otherwise we would have +-- problems with qualified names. +--- printnames are not preserved, nor are lindefs + +printGrammarOld :: GFC.CanonGrammar -> String +printGrammarOld gr = err id id $ do + as0 <- mapM canon2sourceModule [im | im@(_,ModMod m) <- modules gr, isModAbs m] + cs0 <- mapM canon2sourceModule + [im | im@(_,ModMod m) <- modules gr, isModCnc m || isModRes m] + as1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) as0 + cs1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) cs0 + return $ unlines $ map prj $ srt as1 ++ srt cs1 + where + js (ModMod m) = jments m + srt = sortBy (\ (i,_) (j,_) -> compare i j) + prj ii = P.printTree $ trAnyDef ii + +stripInfo :: (Ident,Info) -> [(Ident,Info)] +stripInfo (c,i) = case i of + AbsCat (Yes co) (Yes fs) -> rc $ AbsCat (Yes (stripContext co)) nope + AbsFun (Yes ty) (Yes tr) -> rc $ AbsFun (Yes (stripTerm ty)) (Yes(stripTerm tr)) + AbsFun (Yes ty) _ -> rc $ AbsFun (Yes (stripTerm ty)) nope + ResParam (Yes ps) -> rc $ ResParam (Yes [(c,stripContext co) | (c,co)<- ps]) + CncCat (Yes ty) _ _ -> rc $ + CncCat (Yes (stripTerm ty)) nope nope + CncFun _ (Yes tr) _ -> rc $ CncFun Nothing (Yes (stripTerm tr)) nope + _ -> [] + where + rc j = [(c,j)] + +stripContext co = [(x, stripTerm t) | (x,t) <- co] + +stripTerm t = case t of + Q _ c -> Vr c + QC _ c -> Vr c + T ti cs -> T ti' [(stripPattern p, stripTerm c) | (p,c) <- cs] where + ti' = case ti of + TTyped ty -> TTyped $ stripTerm ty + TComp ty -> TComp $ stripTerm ty + TWild ty -> TWild $ stripTerm ty + _ -> ti + _ -> composSafeOp stripTerm t + +stripPattern p = case p of + PC c [] -> PV c + PP _ c [] -> PV c + PC c ps -> PC c (map stripPattern ps) + PP _ c ps -> PC c (map stripPattern ps) + PR lps -> PR [(l, stripPattern p) | (l,p) <- lps] + PT t p -> PT (stripTerm t) (stripPattern p) + _ -> p + diff --git a/src/GF/Compile/RemoveLiT.hs b/src/GF/Compile/RemoveLiT.hs new file mode 100644 index 000000000..0e45be8c0 --- /dev/null +++ b/src/GF/Compile/RemoveLiT.hs @@ -0,0 +1,51 @@ +module RemoveLiT (removeLiT) where + +import Grammar +import Ident +import Modules +import Macros +import Lookup + +import Operations + +import Monad + +-- remove obsolete (Lin C) expressions before doing anything else. AR 21/6/2003 + +-- What the program does is replace the occurrences of Lin C with the actual +-- definition T given in lincat C = T ; with {s : Str} if no lincat is found. +-- The procedule is uncertain, if T contains another Lin. + +removeLiT :: SourceGrammar -> Err SourceGrammar +removeLiT gr = liftM MGrammar $ mapM (remlModule gr) (modules gr) + +remlModule :: SourceGrammar -> (Ident,SourceModInfo) -> Err (Ident,SourceModInfo) +remlModule gr mi@(name,mod) = case mod of + ModMod (Module mt fs me ops js) -> do + js1 <- mapMTree (remlResInfo gr) js + let mod2 = ModMod $ Module mt fs me ops js1 + return $ (name,mod2) + _ -> return mi + +remlResInfo :: SourceGrammar -> (Ident,Info) -> Err (Ident,Info) +remlResInfo gr mi@(i,info) = case info of + ResOper pty ptr -> liftM ((,) i) $ liftM2 ResOper (ren pty) (ren ptr) + CncCat pty ptr ppr -> liftM ((,) i) $ liftM3 CncCat (ren pty) (ren ptr) (ren ppr) + CncFun mt ptr ppr -> liftM ((,) i) $ liftM2 (CncFun mt) (ren ptr) (ren ppr) + _ -> return mi + where + ren = remlPerh gr + +remlPerh gr pt = case pt of + Yes t -> liftM Yes $ remlTerm gr t + _ -> return pt + +remlTerm :: SourceGrammar -> Term -> Err Term +remlTerm gr trm = case trm of + LiT c -> look c >>= remlTerm gr + _ -> composOp (remlTerm gr) trm + where + look c = err (const $ return defLinType) return $ lookupLincat gr m c + m = case [cnc | (cnc,ModMod m) <- modules gr, isModCnc m] of + cnc:_ -> cnc -- actually there is always exactly one + _ -> zIdent "CNC" diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs new file mode 100644 index 000000000..1e45b5fcc --- /dev/null +++ b/src/GF/Compile/Rename.hs @@ -0,0 +1,263 @@ +module Rename where + +import Grammar +import Modules +import Ident +import Macros +import PrGrammar +import Lookup +import Extend +import Operations + +import Monad + +-- AR 14/5/2003 + +-- The top-level function $renameGrammar$ does several things: +-- * extends each module symbol table by indirections to extended module +-- * changes unqualified and as-qualified imports to absolutely qualified +-- * goes through the definitions and resolves names +-- Dependency analysis between modules has been performed before this pass. +-- Hence we can proceed by $fold$ing 'from left to right'. + +renameGrammar :: SourceGrammar -> Err SourceGrammar +renameGrammar g = liftM (MGrammar . reverse) $ foldM renameModule [] (modules g) + +-- this gives top-level access to renaming term input in the cc command +renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term +renameSourceTerm g m t = do + mo <- lookupErr m (modules g) + status <- buildStatus g m mo + renameTerm status [] t + +renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule] +renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of + ModMod (Module mt fs me ops js) -> do + (_,mod1@(ModMod m)) <- extendModule ms (name,mod) + let js1 = jments m + status <- buildStatus (MGrammar ms) name mod1 + js2 <- mapMTree (renameInfo status) js1 + let mod2 = ModMod $ Module mt fs me (map forceQualif ops) js2 + return $ (name,mod2) : ms + +extendModule :: [SourceModule] -> SourceModule -> Err SourceModule +extendModule ms (name,mod) = case mod of + ModMod (Module mt fs me ops js0) -> do + js <- case mt of +{- --- building the {s : Str} lincat + MTConcrete a -> do + ModMod ma <- lookupModule (MGrammar ms) a + let cats = [c | (c,AbsCat _ _) <- tree2list $ jments ma] + jscs = [(c,CncCat (yes defLinType) nope nope) | c <- cats] + return $ updatesTreeNondestr jscs js0 +-} + _ -> return js0 + js1 <- case me of + Just n -> do + m0 <- case lookup n ms of + Just (ModMod m) -> do + testErr (sameMType (mtype m) mt) + ("illegal extension type to module" +++ prt name) + return m + _ -> Bad $ "cannot find extended module" +++ prt n + extendMod n (jments m0) js + _ -> return js + return $ (name,ModMod (Module mt fs Nothing ops js1)) + + +type Status = (StatusTree, [(OpenSpec Ident, StatusTree)]) + +type StatusTree = BinTree (Ident,StatusInfo) + +type StatusInfo = Ident -> Term + +renameIdentTerm :: Status -> Term -> Err Term +renameIdentTerm env@(act,imps) t = case t of + Vr c -> do + f <- lookupTreeMany prt opens c + return $ f c + Cn c -> do + f <- lookupTreeMany prt opens c + return $ f c + Q m' c -> do + m <- lookupErr m' qualifs + f <- lookupTree prt c m + return $ f c + QC m' c -> do + m <- lookupErr m' qualifs + f <- lookupTree prt c m + return $ f c + _ -> return t + where + opens = act : [st | (OSimple _,st) <- imps] + qualifs = [ (m, st) | (OQualif m _, st) <- imps] + +--- would it make sense to optimize this by inlining? +renameIdentPatt :: Status -> Patt -> Err Patt +renameIdentPatt env p = do + let t = patt2term p + t' <- renameIdentTerm env t + term2patt t' + +info2status :: Maybe Ident -> (Ident,Info) -> (Ident,StatusInfo) +info2status mq (c,i) = (c, case i of + AbsFun _ (Yes (Con g)) | g == c -> maybe Con QC mq + ResValue _ -> maybe Con QC mq + ResParam _ -> maybe Con QC mq + AnyInd True m -> maybe Con (const (QC m)) mq + AnyInd False m -> maybe Cn (const (Q m)) mq + _ -> maybe Cn Q mq + ) + +tree2status :: OpenSpec Ident -> BinTree (Ident,Info) -> BinTree (Ident,StatusInfo) +tree2status o = case o of + OSimple i -> mapTree (info2status (Just i)) + OQualif i j -> mapTree (info2status (Just j)) + +buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Err Status +buildStatus gr c mo = let mo' = self2status c mo in case mo of + ModMod m -> do + let ops = opens m + mods <- mapM (lookupModule gr . openedModule) ops + let sts = map modInfo2status $ zip ops mods + return $ if isModCnc m + then (NT, sts) -- the module itself does not define any names + else (mo',sts) -- so the empty ident is not needed + +modInfo2status :: (OpenSpec Ident,SourceModInfo) -> (OpenSpec Ident, StatusTree) +modInfo2status (o,i) = (o,case i of + ModMod m -> tree2status o (jments m) + ) + +self2status :: Ident -> SourceModInfo -> StatusTree +self2status c i = case i of + ModMod m -> mapTree (info2status (Just c)) (jments m) -- qualify internal +--- ModMod m -> mapTree (resInfo2status Nothing) (jments m) +-- change Lookup.qualifAnnot if you change this + +forceQualif o = case o of + OSimple i -> OQualif i i + OQualif _ i -> OQualif i i + +renameInfo :: Status -> (Ident,Info) -> Err (Ident,Info) +renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $ + liftM ((,) i) $ case info of + AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco) + (return pfs) ---- + AbsFun pty ptr -> liftM2 AbsFun (ren pty) (ren ptr) + + ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr) + ResParam pp -> liftM ResParam (renPerh (mapM (renameParam status)) pp) + ResValue t -> liftM ResValue (ren t) + CncCat pty ptr ppr -> liftM3 CncCat (ren pty) (ren ptr) (ren ppr) + CncFun mt ptr ppr -> liftM2 (CncFun mt) (ren ptr) (ren ppr) + _ -> return info + where + ren = renPerh rent + rent = renameTerm status [] + +renPerh ren pt = case pt of + Yes t -> liftM Yes $ ren t + _ -> return pt + +renameTerm :: Status -> [Ident] -> Term -> Err Term +renameTerm env vars = ren vars where + ren vs trm = case trm of + Abs x b -> liftM (Abs x) (ren (x:vs) b) + Prod x a b -> liftM2 (Prod x) (ren vs a) (ren (x:vs) b) + Vr x + | elem x vs -> return trm + | otherwise -> renid trm + Cn _ -> renid trm + Con _ -> renid trm + Q _ _ -> renid trm + QC _ _ -> renid trm + +---- Eqs eqs -> Eqs (map (renameEquation consts vs) eqs) + T i cs -> do + i' <- case i of + TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source + _ -> return i + liftM (T i') $ mapM (renCase vs) cs + + Let (x,(m,a)) b -> do + m' <- case m of + Just ty -> liftM Just $ ren vs ty + _ -> return m + a' <- ren vs a + b' <- ren (x:vs) b + return $ Let (x,(m',a')) b' + + P t@(Vr r) l -- for constant t we know it is projection + | elem r vs -> return trm -- var proj first + | otherwise -> case renid (Q r (label2ident l)) of -- qualif second + Ok t -> return t + _ -> liftM (flip P l) $ renid t -- const proj last + + _ -> composOp (ren vs) trm + + renid = renameIdentTerm env + renCase vs (p,t) = do + (p',vs') <- renpatt p + t' <- ren (vs' ++ vs) t + return (p',t') + renpatt = renamePattern env + +-- vars not needed in env, since patterns always overshadow old vars + +renamePattern :: Status -> Patt -> Err (Patt,[Ident]) +renamePattern env patt = case patt of + + PC c ps -> do + c' <- renameIdentTerm env $ Cn c + psvss <- mapM renp ps + let (ps',vs) = unzip psvss + return $ case c' of + QC p d -> (PP p d ps', concat vs) + _ -> (PC c ps', concat vs) + +---- PP p c ps -> (PP p c ps',concat vs') where (ps',vs') = unzip $ map renp ps + + PV x -> case renid patt of + Ok p -> return (p,[]) + _ -> return (patt, [x]) + + PR r -> do + let (ls,ps) = unzip r + psvss <- mapM renp ps + let (ps',vs') = unzip psvss + return (PR (zip ls ps'), concat vs') + + _ -> return (patt,[]) + + where + renp = renamePattern env + renid = renameIdentPatt env + +renameParam :: Status -> (Ident, Context) -> Err (Ident, Context) +renameParam env (c,co) = do + co' <- renameContext env co + return (c,co') + +renameContext :: Status -> Context -> Err Context +renameContext b = renc [] where + renc vs cont = case cont of + (x,t) : xts + | isWildIdent x -> do + t' <- ren vs t + xts' <- renc vs xts + return $ (x,t') : xts' + | otherwise -> do + t' <- ren vs t + let vs' = x:vs + xts' <- renc vs' xts + return $ (x,t') : xts' + _ -> return cont + ren = renameTerm b + +{- +renameEquation :: Status -> [Ident] -> Equation -> Equation +renameEquation b vs (ps,t) = (ps',renameTerm b (concat vs' ++ vs) t) where + (ps',vs') = unzip $ map (renamePattern b vs) ps +-} + diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs new file mode 100644 index 000000000..f24c3b87c --- /dev/null +++ b/src/GF/Compile/ShellState.hs @@ -0,0 +1,338 @@ +module ShellState where + +import Operations +import GFC +import AbsGFC +---import CMacros +import Look +import qualified Modules as M +import qualified Grammar as G +import qualified PrGrammar as P +import CF +import CFIdent +import CanonToCF +import Morphology +import Option +import Ident +import Arch (ModTime) + +-- AR 11/11/2001 -- 17/6/2003 (for modules) ---- unfinished + +-- multilingual state with grammars and options +data ShellState = ShSt { + abstract :: Maybe Ident , -- pointer to actual abstract; nothing in empty st + concrete :: Maybe Ident , -- pointer to primary concrete + concretes :: [(Ident,Ident)], -- list of all concretes + canModules :: CanonGrammar , -- the place where abstracts and concretes reside + srcModules :: G.SourceGrammar , -- the place of saved resource modules + cfs :: [(Ident,CF)] , -- context-free grammars + morphos :: [(Ident,Morpho)], -- morphologies + gloptions :: Options, -- global options + readFiles :: [(FilePath,ModTime)],-- files read + absCats :: [(G.Cat,(G.Context, -- cats, their contexts, + [(G.Fun,G.Type)], -- functions to them, + [((G.Fun,Int),G.Type)]))], -- functions on them + statistics :: [Statistics] -- statistics on grammars + } + +data Statistics = + StDepTypes Bool -- whether there are dependent types + | StBoundVars [G.Cat] -- which categories have bound variables + --- -- etc + deriving (Eq,Ord) + +emptyShellState = ShSt { + abstract = Nothing, + concrete = Nothing, + concretes = [], + canModules = M.emptyMGrammar, + srcModules = M.emptyMGrammar, + cfs = [], + morphos = [], + gloptions = noOptions, + readFiles = [], + absCats = [], + statistics = [] + } + +type Language = Ident +language = identC +prLanguage = prIdent + +-- grammar for one language in a state, comprising its abs and cnc + +data StateGrammar = StGr { + absId :: Ident, + cncId :: Ident, + grammar :: CanonGrammar, + cf :: CF, + morpho :: Morpho + } + +emptyStateGrammar = StGr { + absId = identC "#EMPTY", --- + cncId = identC "#EMPTY", --- + grammar = M.emptyMGrammar, + cf = emptyCF, + morpho = emptyMorpho + } + +-- analysing shell grammar into parts +stateGrammarST = grammar +stateCF = cf +stateMorpho = morpho +stateOptions _ = noOptions ---- + +cncModuleIdST = stateGrammarST + +-- form a shell state from a canonical grammar + +grammar2shellState :: Options -> (CanonGrammar, G.SourceGrammar) -> Err ShellState +grammar2shellState opts (gr,sgr) = updateShellState opts emptyShellState (gr,(sgr,[])) + +-- update a shell state from a canonical grammar + +updateShellState :: Options -> ShellState -> + (CanonGrammar,(G.SourceGrammar,[(FilePath,ModTime)])) -> + Err ShellState +updateShellState opts sh (gr,(sgr,rts)) = do + let cgr = M.updateMGrammar (canModules sh) gr + a' = ifNull Nothing (return . last) $ allAbstracts cgr + abstr0 <- case abstract sh of + Just a -> do + --- test that abstract is compatible + return $ Just a + _ -> return a' + let concrs = maybe [] (allConcretes cgr) abstr0 + concr0 = ifNull Nothing (return . last) concrs + notInrts f = notElem f $ map fst rts + cfs <- mapM (canon2cf opts cgr) concrs --- would not need to update all... + + let funs = [] ---- funRulesOf cgr + let cats = [] ---- allCatsOf cgr + let csi = [] ---- +{- + [(c,(co, + [(fun,typ) | (fun,typ) <- funs, compatType tc typ], + funsOnTypeFs compatType funs tc)) + | (c,co) <- cats, let tc = cat2type c] +-} + let deps = True ---- not $ null $ allDepCats cgr + let binds = [] ---- allCatsWithBind cgr + + return $ ShSt { + abstract = abstr0, + concrete = concr0, + concretes = zip concrs concrs, + canModules = cgr, + srcModules = M.updateMGrammar (srcModules sh) sgr, + cfs = zip concrs cfs, + morphos = zip concrs (repeat emptyMorpho), + gloptions = opts, ---- -- global options + readFiles = [ft | ft@(f,_) <- readFiles sh, notInrts f] ++ rts, + absCats = csi, + statistics = [StDepTypes deps,StBoundVars binds] + } + +prShellStateInfo :: ShellState -> String +prShellStateInfo sh = unlines [ + "main abstract : " +++ maybe "(none)" P.prt (abstract sh), + "main concrete : " +++ maybe "(none)" P.prt (concrete sh), + "all concretes : " +++ unwords (map (P.prt . fst) (concretes sh)), + "canonical modules :" +++ unwords (map (P.prt .fst) (M.modules (canModules sh))), + "source modules : " +++ unwords (map (P.prt .fst) (M.modules (srcModules sh))), + "global options : " +++ prOpts (gloptions sh) + ] + + +-- form just one state grammar, if unique, from a canonical grammar + +grammar2stateGrammar :: Options -> CanonGrammar -> Err StateGrammar +grammar2stateGrammar opts gr = do + st <- grammar2shellState opts (gr,M.emptyMGrammar) + concr <- maybeErr "no concrete syntax" $ concrete st + return $ stateGrammarOfLang st concr + +-- all abstract modules +allAbstracts :: CanonGrammar -> [Ident] +allAbstracts gr = [i | (i,M.ModMod m) <- M.modules gr, M.mtype m == M.MTAbstract] + +-- the last abstract in dependency order +greatestAbstract :: CanonGrammar -> Maybe Ident +greatestAbstract gr = case allAbstracts gr of + [] -> Nothing + a -> return $ last a + +-- all concretes for a given abstract +allConcretes :: CanonGrammar -> Ident -> [Ident] +allConcretes gr a = [i | (i,M.ModMod m) <- M.modules gr, M.mtype m== M.MTConcrete a] + +stateGrammarOfLang :: ShellState -> Language -> StateGrammar +stateGrammarOfLang st l = StGr { + absId = maybe (identC "Abs") id (abstract st), --- + cncId = l, + grammar = canModules st, ---- only those needed for l + cf = maybe emptyCF id (lookup l (cfs st)), + morpho = maybe emptyMorpho id (lookup l (morphos st)) + } + +grammarOfLang st = stateGrammarST . stateGrammarOfLang st +cfOfLang st = stateCF . stateGrammarOfLang st +morphoOfLang st = stateMorpho . stateGrammarOfLang st +optionsOfLang st = stateOptions . stateGrammarOfLang st + +-- the last introduced grammar, stored in options, is the default for operations + +firstStateGrammar :: ShellState -> StateGrammar +firstStateGrammar st = errVal emptyStateGrammar $ do + concr <- maybeErr "no concrete syntax" $ concrete st + return $ stateGrammarOfLang st concr + +mkStateGrammar :: ShellState -> Language -> StateGrammar +mkStateGrammar = stateGrammarOfLang + +-- analysing shell state into parts +globalOptions = gloptions +allLanguages = map fst . concretes + +allStateGrammars = map snd . allStateGrammarsWithNames + +allStateGrammarsWithNames st = [(c, mkStateGrammar st c) | (c,_) <- concretes st] + +allGrammarFileNames st = [prLanguage c ++ ".gf" | (c,_) <- concretes st] --- + +{- +allActiveStateGrammarsWithNames (ShSt (ma,gs,_)) = + [(l, mkStateGrammar a c) | (l,((_,True),c)) <- gs, Just a <- [ma]] + + + +allActiveGrammars = map snd . allActiveStateGrammarsWithNames + +allGrammarSTs = map stateGrammarST . allStateGrammars +allCFs = map stateCF . allStateGrammars + +firstGrammarST = stateGrammarST . firstStateGrammar +firstAbstractST = abstractOf . firstGrammarST +firstConcreteST = concreteOf . firstGrammarST +-} +-- command-line option -language=foo overrides the actual grammar in state +grammarOfOptState :: Options -> ShellState -> StateGrammar +grammarOfOptState opts st = + maybe (firstStateGrammar st) (stateGrammarOfLang st . language) $ + getOptVal opts useLanguage + +-- command-line option -cat=foo overrides the possible start cat of a grammar +firstCatOpts :: Options -> StateGrammar -> CFCat +firstCatOpts opts sgr = + maybe (stateFirstCat sgr) (string2CFCat (P.prt (absId sgr))) $ + getOptVal opts firstCat + +-- a grammar can have start category as option startcat=foo ; default is S +stateFirstCat sgr = + maybe (string2CFCat a "S") (string2CFCat a) $ + getOptVal (stateOptions sgr) gStartCat + where + a = P.prt (absId sgr) + +-- the first cat for random generation +firstAbsCat :: Options -> StateGrammar -> G.QIdent +firstAbsCat opts sgr = + maybe (absId sgr, identC "S") (\c -> (absId sgr, identC c)) $ ---- + getOptVal opts firstCat + +{- +-- command-line option -cat=foo overrides the possible start cat of a grammar +stateTransferFun :: StateGrammar -> Maybe Fun +stateTransferFun sgr = getOptVal (stateOptions sgr) transferFun >>= return . zIdent + +stateConcrete = concreteOf . stateGrammarST +stateAbstract = abstractOf . stateGrammarST + +maybeStateAbstract (ShSt (ma,_,_)) = ma +hasStateAbstract = maybe False (const True) . maybeStateAbstract +abstractOfState = maybe emptyAbstractST id . maybeStateAbstract + +stateIsWord sg = isKnownWord (stateMorpho sg) + + +-- getting info on a language +existLang :: ShellState -> Language -> Bool +existLang st lang = elem lang (allLanguages st) + +stateConcreteOfLang :: ShellState -> Language -> StateConcrete +stateConcreteOfLang (ShSt (_,gs,_)) lang = + maybe emptyStateConcrete snd $ lookup lang gs + +fileOfLang :: ShellState -> Language -> FilePath +fileOfLang (ShSt (_,gs,_)) lang = + maybe nonExistingLangFile (fst .fst) $ lookup lang gs + +nonExistingLangFile = "NON-EXISTING LANGUAGE" --- + + +allLangOptions st lang = unionOptions (optionsOfLang st lang) (globalOptions st) + +-- construct state + +stateGrammar st cf mo opts = StGr ((st,cf,mo),opts) + +initShellState ab fs gs opts = + ShSt (Just ab, [(getLangName f, ((f,True),g)) | (f,g) <- zip fs gs], opts) +emptyInitShellState opts = ShSt (Nothing, [], opts) + +-- the second-last part of a file name is the default language name +getLangName :: String -> Language +getLangName file = language (if notElem '.' file then file else langname) where + elif = reverse file + xiferp = tail (dropWhile (/='.') elif) + langname = reverse (takeWhile (flip notElem "./") xiferp) + +-- option -language=foo overrides the default language name +getLangNameOpt :: Options -> String -> Language +getLangNameOpt opts file = + maybe (getLangName file) language $ getOptVal opts useLanguage +-} +-- modify state + +type ShellStateOper = ShellState -> ShellState + +reinitShellState :: ShellStateOper +reinitShellState = const emptyShellState + +{- +languageOn = languageOnOff True +languageOff = languageOnOff False + +languageOnOff :: Bool -> Language -> ShellStateOper +languageOnOff b lang (ShSt (ab,gs,os)) = ShSt (ab, gs', os) where + gs' = [if lang==l then (l,((f,b),g)) else i | i@(l,((f,_),g)) <- gs] + +updateLanguage :: FilePath -> (Language, StateConcrete) -> ShellStateOper +updateLanguage file (lang,gr) (ShSt (ab,gs,os)) = + ShSt (ab, updateAssoc (lang,((file,True),gr)) gs, os') where + os' = changeOptVal os useLanguage (prLanguage lang) -- actualizes the new lang + +initWithAbstract :: AbstractST -> ShellStateOper +initWithAbstract ab st@(ShSt (ma,cs,os)) = + maybe (ShSt (Just ab,cs,os)) (const st) ma + +removeLanguage :: Language -> ShellStateOper +removeLanguage lang (ShSt (ab,gs,os)) = ShSt (ab,removeAssoc lang gs, os) +-} +changeOptions :: (Options -> Options) -> ShellStateOper +changeOptions f (ShSt a c cs can src cfs ms os ff ts ss) = + ShSt a c cs can src cfs ms (f os) ff ts ss + +changeModTimes :: [(FilePath,ModTime)] -> ShellStateOper +changeModTimes mfs (ShSt a c cs can src cfs ms os ff ts ss) = + ShSt a c cs can src cfs ms os ff' ts ss + where + ff' = mfs ++ [mf | mf@(f,_) <- ff, notElem f (map fst mfs)] + +addGlobalOptions :: Options -> ShellStateOper +addGlobalOptions = changeOptions . addOptions + +removeGlobalOptions :: Options -> ShellStateOper +removeGlobalOptions = changeOptions . removeOptions + diff --git a/src/GF/Compile/Update.hs b/src/GF/Compile/Update.hs new file mode 100644 index 000000000..9bc16f03a --- /dev/null +++ b/src/GF/Compile/Update.hs @@ -0,0 +1,98 @@ +module Update where + +import Ident +import Grammar +import PrGrammar +import Modules + +import Operations + +import List +import Monad + +-- update a resource module by adding a new or changing an old definition + +updateRes :: SourceGrammar -> Ident -> Ident -> Info -> SourceGrammar +updateRes gr@(MGrammar ms) m i info = MGrammar $ map upd ms where + upd (n,mod) + | n /= m = (n,mod) + | n == m = case mod of + ModMod r -> (m,ModMod $ updateModule r i info) + _ -> (n,mod) --- no error msg + +-- combine a list of definitions into a balanced binary search tree + +buildAnyTree :: [(Ident,Info)] -> Err (BinTree (Ident, Info)) +buildAnyTree ias = do + ias' <- combineAnyInfos ias + return $ buildTree ias' + + +-- unifying information for abstract, resource, and concrete + +combineAnyInfos :: [(Ident,Info)] -> Err [(Ident,Info)] +combineAnyInfos = combineInfos unifyAnyInfo + +unifyAnyInfo :: Ident -> Info -> Info -> Err Info +unifyAnyInfo c i j = errIn ("combining information for" +++ prt c) $ case (i,j) of + (AbsCat mc1 mf1, AbsCat mc2 mf2) -> + liftM2 AbsCat (unifPerhaps mc1 mc2) (unifPerhaps mf1 mf2) ---- adding constrs + (AbsFun mt1 md1, AbsFun mt2 md2) -> + liftM2 AbsFun (unifPerhaps mt1 mt2) (unifAbsDefs md1 md2) ---- adding defs + + (ResParam mt1, ResParam mt2) -> liftM ResParam $ unifPerhaps mt1 mt2 + (ResOper mt1 m1, ResOper mt2 m2) -> + liftM2 ResOper (unifPerhaps mt1 mt2) (unifPerhaps m1 m2) + + (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> + liftM3 CncCat (unifPerhaps mc1 mc2) (unifPerhaps mf1 mf2) (unifPerhaps mp1 mp2) + (CncFun m mt1 md1, CncFun _ mt2 md2) -> + liftM2 (CncFun m) (unifPerhaps mt1 mt2) (unifPerhaps md1 md2) ---- adding defs + + _ -> Bad $ "cannot unify information for" +++ show i + +--- these auxiliaries should be somewhere else since they don't use the info types + +groupInfos :: Eq a => [(a,b)] -> [[(a,b)]] +groupInfos = groupBy (\i j -> fst i == fst j) + +sortInfos :: Ord a => [(a,b)] -> [(a,b)] +sortInfos = sortBy (\i j -> compare (fst i) (fst j)) + +combineInfos :: Ord a => (a -> b -> b -> Err b) -> [(a,b)] -> Err [(a,b)] +combineInfos f ris = do + let riss = groupInfos $ sortInfos ris + mapM (unifyInfos f) riss + +unifyInfos :: (a -> b -> b -> Err b) -> [(a,b)] -> Err (a,b) +unifyInfos _ [] = Bad "empty info list" +unifyInfos unif ris = do + let c = fst $ head ris + let infos = map snd ris + let ([i],is) = splitAt 1 infos + info <- foldM (unif c) i is + return (c,info) + +tryInsert :: Ord a => (b -> b -> Err b) -> (b -> b) -> + BinTree (a,b) -> (a,b) -> Err (BinTree (a,b)) +tryInsert unif indir tree z@(x, info) = case tree of + NT -> return $ BT (x, indir info) NT NT + BT c@(a,info0) left right + | x < a -> do + left' <- tryInsert unif indir left z + return $ BT c left' right + | x > a -> do + right' <- tryInsert unif indir right z + return $ BT c left right' + | x == a -> do + info' <- unif info info0 + return $ BT (x,info') left right + +--- addToMaybeList m c = maybe (return c) (\old -> return (c ++ old)) m + +unifAbsDefs :: Perh Term -> Perh Term -> Err (Perh Term) +unifAbsDefs p1 p2 = case (p1,p2) of + (Nope, _) -> return p2 + (_, Nope) -> return p1 + (Yes (Eqs bs), Yes (Eqs ds)) -> return $ yes $ Eqs $ bs ++ ds --- order! + _ -> Bad "update conflict" diff --git a/src/GF/Data/ErrM.hs b/src/GF/Data/ErrM.hs new file mode 100644 index 000000000..eb2078718 --- /dev/null +++ b/src/GF/Data/ErrM.hs @@ -0,0 +1,7 @@ +module ErrM ( + module Operations +) where + +import Operations + +-- hack for BNFC generated files. AR 21/9/2003 diff --git a/src/GF/Data/Operations.hs b/src/GF/Data/Operations.hs new file mode 100644 index 000000000..7110a7ac0 --- /dev/null +++ b/src/GF/Data/Operations.hs @@ -0,0 +1,559 @@ +module Operations where + +import Char (isSpace, toUpper, isSpace, isDigit) +import List (nub, sortBy, sort, deleteBy, nubBy) +import Monad (liftM2) + +infixr 5 +++ +infixr 5 ++- +infixr 5 ++++ +infixr 5 +++++ +infixl 9 !? + +-- some auxiliary GF operations. AR 19/6/1998 -- 6/2/2001 +-- Copyright (c) Aarne Ranta 1998-2000, under GNU General Public License (see GPL) + +ifNull :: b -> ([a] -> b) -> [a] -> b +ifNull b f xs = if null xs then b else f xs + +-- the Error monad + +data Err a = Ok a | Bad String -- like Maybe type with error msgs + deriving (Read, Show, Eq) + +instance Monad Err where + return = Ok + Ok a >>= f = f a + Bad s >>= f = Bad s + +-- analogue of maybe +err :: (String -> b) -> (a -> b) -> Err a -> b +err d f e = case e of + Ok a -> f a + Bad s -> d s + +-- add msg s to Maybe failures +maybeErr :: String -> Maybe a -> Err a +maybeErr s = maybe (Bad s) Ok + +testErr :: Bool -> String -> Err () +testErr cond msg = if cond then return () else Bad msg + +errVal :: a -> Err a -> a +errVal a = err (const a) id + +errIn :: String -> Err a -> Err a +errIn msg = err (\s -> Bad (s ++++ "OCCURRED IN" ++++ msg)) return + +-- used for extra error reports when developing GF +derrIn :: String -> Err a -> Err a +derrIn m = errIn m -- id + +performOps :: [a -> Err a] -> a -> Err a +performOps ops a = case ops of + f:fs -> f a >>= performOps fs + [] -> return a + +repeatUntilErr :: (a -> Bool) -> (a -> Err a) -> a -> Err a +repeatUntilErr cond f a = if cond a then return a else f a >>= repeatUntilErr cond f + +repeatUntil :: (a -> Bool) -> (a -> a) -> a -> a +repeatUntil cond f a = if cond a then a else repeatUntil cond f (f a) + +okError :: Err a -> a +okError = err (error "no result Ok") id + +isNotError :: Err a -> Bool +isNotError = err (const False) (const True) + +showBad :: Show a => String -> a -> Err b +showBad s a = Bad (s +++ show a) + +lookupErr :: (Eq a,Show a) => a -> [(a,b)] -> Err b +lookupErr a abs = maybeErr ("Unknown" +++ show a) (lookup a abs) + +lookupErrMsg :: (Eq a,Show a) => String -> a -> [(a,b)] -> Err b +lookupErrMsg m a abs = maybeErr (m +++ "gave unknown" +++ show a) (lookup a abs) + +lookupDefault :: Eq a => b -> a -> [(a,b)] -> b +lookupDefault d x l = maybe d id $ lookup x l + +updateLookupList :: Eq a => (a,b) -> [(a,b)] -> [(a,b)] +updateLookupList ab abs = insert ab [] abs where + insert c cc [] = cc ++ [c] + insert (a,b) cc ((a',b'):cc') = if a == a' + then cc ++ [(a,b)] ++ cc' + else insert (a,b) (cc ++ [(a',b')]) cc' + +mapPairListM :: Monad m => ((a,b) -> m c) -> [(a,b)] -> m [(a,c)] +mapPairListM f xys = + do yy' <- mapM f xys + return (zip (map fst xys) yy') + +mapPairsM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)] +mapPairsM f xys = + do let (xx,yy) = unzip xys + yy' <- mapM f yy + return (zip xx yy') + +pairM :: Monad a => (b -> a c) -> (b,b) -> a (c,c) +pairM op (t1,t2) = liftM2 (,) (op t1) (op t2) + +-- like mapM, but continue instead of halting with Err +mapErr :: (a -> Err b) -> [a] -> Err ([b], String) +mapErr f xs = Ok (ys, unlines ss) + where + (ys,ss) = ([y | Ok y <- fxs], [s | Bad s <- fxs]) + fxs = map f xs + +-- !! with the error monad +(!?) :: [a] -> Int -> Err a +xs !? i = foldr (const . return) (Bad "too few elements in list") $ drop i xs + +errList :: Err [a] -> [a] +errList = errVal [] + +singleton :: a -> [a] +singleton = (:[]) + +-- checking + +checkUnique :: (Show a, Eq a) => [a] -> [String] +checkUnique ss = ["overloaded" +++ show s | s <- nub overloads] where + overloads = filter overloaded ss + overloaded s = length (filter (==s) ss) > 1 + +titleIfNeeded :: a -> [a] -> [a] +titleIfNeeded a [] = [] +titleIfNeeded a as = a:as + +errMsg :: Err a -> [String] +errMsg (Bad m) = [m] +errMsg _ = [] + +errAndMsg :: Err a -> Err (a,[String]) +errAndMsg (Bad m) = Bad m +errAndMsg (Ok a) = return (a,[]) + +-- a three-valued maybe type to express indirections + +data Perhaps a b = Yes a | May b | Nope deriving (Show,Read,Eq,Ord) + +yes = Yes +may = May +nope = Nope + +mapP :: (a -> c) -> Perhaps a b -> Perhaps c b +mapP f p = case p of + Yes a -> Yes (f a) + May b -> May b + Nope -> Nope + +-- this is what happens when matching two values in the same module +unifPerhaps :: Perhaps a b -> Perhaps a b -> Err (Perhaps a b) +unifPerhaps p1 p2 = case (p1,p2) of + (Nope, _) -> return p2 + (_, Nope) -> return p1 + _ -> Bad "update conflict" + +-- this is what happens when updating a module extension +updatePerhaps :: b -> Perhaps a b -> Perhaps a b -> Err (Perhaps a b) +updatePerhaps old p1 p2 = case (p1,p2) of + (Yes a, Nope) -> return $ may old + (May older,Nope) -> return $ may older + (_, May a) -> Bad "strange indirection" + _ -> unifPerhaps p1 p2 + +-- binary search trees + +data BinTree a = NT | BT a (BinTree a) (BinTree a) deriving (Show,Read) + +isInBinTree :: (Ord a) => a -> BinTree a -> Bool +isInBinTree x tree = case tree of + NT -> False + BT a left right + | x < a -> isInBinTree x left + | x > a -> isInBinTree x right + | x == a -> True + +-- quick method to see if two trees have common elements +-- the complexity is O(log |old|, |new|) so the heuristic is that new is smaller + +commonsInTree :: (Ord a) => BinTree (a,b) -> BinTree (a,b) -> [(a,(b,b))] +commonsInTree old new = foldr inOld [] new' where + new' = tree2list new + inOld (x,v) xs = case justLookupTree x old of + Ok v' -> (x,(v',v)) : xs + _ -> xs + +justLookupTree :: (Ord a) => a -> BinTree (a,b) -> Err b +justLookupTree = lookupTree (const []) + +lookupTree :: (Ord a) => (a -> String) -> a -> BinTree (a,b) -> Err b +lookupTree pr x tree = case tree of + NT -> Bad ("no occurrence of element" +++ pr x) + BT (a,b) left right + | x < a -> lookupTree pr x left + | x > a -> lookupTree pr x right + | x == a -> return b + +lookupTreeEq :: (Ord a) => + (a -> String) -> (a -> a -> Bool) -> a -> BinTree (a,b) -> Err b +lookupTreeEq pr eq x tree = case tree of + NT -> Bad ("no occurrence of element equal to" +++ pr x) + BT (a,b) left right + | eq x a -> return b -- a weaker equality relation than == + | x < a -> lookupTreeEq pr eq x left + | x > a -> lookupTreeEq pr eq x right + +lookupTreeMany :: Ord a => (a -> String) -> [BinTree (a,b)] -> a -> Err b +lookupTreeMany pr (t:ts) x = case lookupTree pr x t of + Ok v -> return v + _ -> lookupTreeMany pr ts x +lookupTreeMany pr [] x = Bad $ "failed to find" +++ pr x + +-- destructive update + +updateTree :: (Ord a) => (a,b) -> BinTree (a,b) -> BinTree (a,b) +updateTree = updateTreeGen True + +-- destructive or not + +updateTreeGen :: (Ord a) => Bool -> (a,b) -> BinTree (a,b) -> BinTree (a,b) +updateTreeGen destr z@(x,y) tree = case tree of + NT -> BT z NT NT + BT c@(a,b) left right + | x < a -> let left' = updateTree z left in BT c left' right + | x > a -> let right' = updateTree z right in BT c left right' + | otherwise -> if destr + then BT z left right -- removing the old value of a + else tree -- retaining the old value if one exists + +updateTreeEq :: + (Ord a) => (a -> a -> Bool) -> (a,b) -> BinTree (a,b) -> BinTree (a,b) +updateTreeEq eq z@(x,y) tree = case tree of + NT -> BT z NT NT + BT c@(a,b) left right + | eq x a -> BT (a,y) left right -- removing the old value of a + | x < a -> let left' = updateTree z left in BT c left' right + | x > a -> let right' = updateTree z right in BT c left right' + +updatesTree :: (Ord a) => [(a,b)] -> BinTree (a,b) -> BinTree (a,b) +updatesTree (z:zs) tr = updateTree z t where t = updatesTree zs tr +updatesTree [] tr = tr + +updatesTreeNondestr :: (Ord a) => [(a,b)] -> BinTree (a,b) -> BinTree (a,b) +updatesTreeNondestr xs tr = case xs of + (z:zs) -> updateTreeGen False z t where t = updatesTreeNondestr zs tr + _ -> tr + +buildTree :: (Ord a) => [(a,b)] -> BinTree (a,b) +buildTree = sorted2tree . sortBy fs where + fs (x,_) (y,_) + | x < y = LT + | x > y = GT + | True = EQ +-- buildTree zz = updatesTree zz NT + +sorted2tree :: [(a,b)] -> BinTree (a,b) +sorted2tree [] = NT +sorted2tree xs = BT x (sorted2tree t1) (sorted2tree t2) where + (t1,(x:t2)) = splitAt (length xs `div` 2) xs + +mapTree :: (a -> b) -> BinTree a -> BinTree b +mapTree f NT = NT +mapTree f (BT a left right) = BT (f a) (mapTree f left) (mapTree f right) + +mapMTree :: Monad m => (a -> m b) -> BinTree a -> m (BinTree b) +mapMTree f NT = return NT +mapMTree f (BT a left right) = do + a' <- f a + left' <- mapMTree f left + right' <- mapMTree f right + return $ BT a' left' right' + +tree2list :: BinTree a -> [a] -- inorder +tree2list NT = [] +tree2list (BT z left right) = tree2list left ++ [z] ++ tree2list right + +depthTree :: BinTree a -> Int +depthTree NT = 0 +depthTree (BT _ left right) = 1 + max (depthTree left) (depthTree right) + +mergeTrees :: Ord a => BinTree (a,b) -> BinTree (a,b) -> BinTree (a,[b]) +mergeTrees old new = foldr upd new' (tree2list old) where + upd xy@(x,y) tree = case tree of + NT -> BT (x,[y]) NT NT + BT (a,bs) left right + | x < a -> let left' = upd xy left in BT (a,bs) left' right + | x > a -> let right' = upd xy right in BT (a,bs) left right' + | otherwise -> BT (a, y:bs) left right -- adding the new value + new' = mapTree (\ (i,d) -> (i,[d])) new + + +-- parsing + +type WParser a b = [a] -> [(b,[a])] -- old Wadler style parser + +wParseResults :: WParser a b -> [a] -> [b] +wParseResults p aa = [b | (b,[]) <- p aa] + +-- printing + +indent :: Int -> String -> String +indent i s = replicate i ' ' ++ s + +a +++ b = a ++ " " ++ b +a ++- "" = a +a ++- b = a +++ b +a ++++ b = a ++ "\n" ++ b +a +++++ b = a ++ "\n\n" ++ b + +prUpper :: String -> String +prUpper s = s1 ++ s2' where + (s1,s2) = span isSpace s + s2' = case s2 of + c:t -> toUpper c : t + _ -> s2 + +prReplicate n s = concat (replicate n s) + +prTList t ss = case ss of + [] -> "" + [s] -> s + s:ss -> s ++ t ++ prTList t ss + +prQuotedString x = "\"" ++ restoreEscapes x ++ "\"" + +prParenth s = if s == "" then "" else "(" ++ s ++ ")" + +prCurly s = "{" ++ s ++ "}" +prBracket s = "[" ++ s ++ "]" + +prArgList xx = prParenth (prTList "," xx) + +prSemicList = prTList " ; " + +prCurlyList = prCurly . prSemicList + +restoreEscapes s = + case s of + [] -> [] + '"' : t -> '\\' : '"' : restoreEscapes t + '\\': t -> '\\' : '\\' : restoreEscapes t + c : t -> c : restoreEscapes t + +numberedParagraphs :: [[String]] -> [String] +numberedParagraphs t = case t of + [] -> [] + p:[] -> p + _ -> concat [(show n ++ ".") : s | (n,s) <- zip [1..] t] + +prConjList :: String -> [String] -> String +prConjList c [] = "" +prConjList c [s] = s +prConjList c [s,t] = s +++ c +++ t +prConjList c (s:tt) = s ++ "," +++ prConjList c tt + +prIfEmpty :: String -> String -> String -> String -> String +prIfEmpty em _ _ [] = em +prIfEmpty em nem1 nem2 s = nem1 ++ s ++ nem2 + +-- Thomas Hallgren's wrap lines +--- optWrapLines = if argFlag "wraplines" True then wrapLines 0 else id +wrapLines n "" = "" +wrapLines n s@(c:cs) = + if isSpace c + then c:wrapLines (n+1) cs + else case lex s of + [(w,rest)] -> if n'>=76 + then '\n':w++wrapLines l rest + else w++wrapLines n' rest + where n' = n+l + l = length w + _ -> s -- give up!! + +-- LaTeX code producing functions + +dollar s = '$' : s ++ "$" +mbox s = "\\mbox{" ++ s ++ "}" +ital s = "{\\em" +++ s ++ "}" +boldf s = "{\\bf" +++ s ++ "}" +verbat s = "\\verbat!" ++ s ++ "!" + +mkLatexFile s = begindocument +++++ s +++++ enddocument + +begindocument = + "\\documentclass[a4paper,11pt]{article}" ++++ -- M.F. 25/01-02 + "\\setlength{\\parskip}{2mm}" ++++ + "\\setlength{\\parindent}{0mm}" ++++ + "\\setlength{\\oddsidemargin}{0mm}" ++++ + "\\setlength{\\evensidemargin}{-2mm}" ++++ + "\\setlength{\\topmargin}{-8mm}" ++++ + "\\setlength{\\textheight}{240mm}" ++++ + "\\setlength{\\textwidth}{158mm}" ++++ + "\\begin{document}\n" + +enddocument = + "\n\\end{document}\n" + +sortByLongest :: [[a]] -> [[a]] +sortByLongest = sortBy longer where + longer x y + | x' > y' = LT + | x' < y' = GT + | True = EQ + where + x' = length x + y' = length y + +combinations :: [[a]] -> [[a]] +combinations t = case t of + [] -> [[]] + aa:uu -> [a:u | a <- aa, u <- combinations uu] + +mkTextFile :: String -> IO () +mkTextFile name = do + s <- readFile name + let s' = prelude name ++ "\n\n" ++ heading name ++ "\n" ++ object s + writeFile (name ++ ".hs") s' + where + prelude name = "module " ++ name ++ " where" + heading name = "txt" ++ name ++ " =" + object s = mk s ++ " \"\"" + mk s = unlines [" \"" ++ escs line ++ "\" ++ \"\\n\" ++" | line <- lines s] + escs s = case s of + c:cs | elem c "\"\\" -> '\\' : c : escs cs + c:cs -> c : escs cs + _ -> s + +initFilePath :: FilePath -> FilePath +initFilePath f = reverse (dropWhile (/='/') (reverse f)) + +-- topological sorting with test of cyclicity + +topoTest :: Eq a => [(a,[a])] -> Either [a] [[a]] +topoTest g = if length g' == length g then Left g' else Right (cyclesIn g ++[[]]) + where + g' = topoSort g + +cyclesIn :: Eq a => [(a,[a])] -> [[a]] +cyclesIn deps = nubb $ clean $ filt $ iterFix findDep immediate where + immediate = [[y,x] | (x,xs) <- deps, y <- xs] + findDep chains = [y:x:chain | + x:chain <- chains, (x',xs) <- deps, x' == x, y <- xs, + notElem y (init chain)] + + clean = map remdup + nubb = nubBy (\x y -> y == reverse x) + filt = filter (\xs -> last xs == head xs) + remdup (x:xs) = x : remdup xs' where xs' = dropWhile (==x) xs + remdup [] = [] + + + +topoSort :: Eq a => [(a,[a])] -> [a] +topoSort g = reverse $ tsort 0 [ffs | ffs@(f,_) <- g, inDeg f == 0] [] where + tsort _ [] r = r + tsort k (ffs@(f,fs) : cs) r + | elem f r = tsort k cs r + | k > lx = r + | otherwise = tsort (k+1) cs (f : tsort (k+1) (info fs) r) + info hs = [(f,fs) | (f,fs) <- g, elem f hs] + inDeg f = length [t | (h,hs) <- g, t <- hs, t == f] + lx = length g + +-- the generic fix point iterator + +iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a] +iterFix more start = iter start start + where + iter old new = if (null new') + then old + else iter (new' ++ old) new' + where + new' = filter (`notElem` old) (more new) + +-- association lists + +updateAssoc :: Eq a => (a,b) -> [(a,b)] -> [(a,b)] +updateAssoc ab@(a,b) as = case as of + (x,y): xs | x == a -> (a,b):xs + xy : xs -> xy : updateAssoc ab xs + [] -> [ab] + +removeAssoc :: Eq a => a -> [(a,b)] -> [(a,b)] +removeAssoc a = filter ((/=a) . fst) + +-- chop into separator-separated parts + +chunks :: String -> [String] -> [[String]] +chunks sep ws = case span (/= sep) ws of + (a,_:b) -> a : bs where bs = chunks sep b + (a, []) -> if null a then [] else [a] + +readIntArg :: String -> Int +readIntArg n = if (not (null n) && all isDigit n) then read n else 0 + + +-- state monad with error; from Agda 6/11/2001 + +newtype STM s a = STM (s -> Err (a,s)) + +appSTM :: STM s a -> s -> Err (a,s) +appSTM (STM f) s = f s + +stm :: (s -> Err (a,s)) -> STM s a +stm = STM + +stmr :: (s -> (a,s)) -> STM s a +stmr f = stm (\s -> return (f s)) + +instance Monad (STM s) where + return a = STM (\s -> return (a,s)) + STM c >>= f = STM (\s -> do + (x,s') <- c s + let STM f' = f x + f' s') + +readSTM :: STM s s +readSTM = stmr (\s -> (s,s)) + +updateSTM :: (s -> s) -> STM s () +updateSTM f = stmr (\s -> ((),f s)) + +writeSTM :: s -> STM s () +writeSTM s = stmr (const ((),s)) + +done :: Monad m => m () +done = return () + +class Monad m => ErrorMonad m where + raise :: String -> m a + handle :: m a -> (String -> m a) -> m a + handle_ :: m a -> m a -> m a + handle_ a b = a `handle` (\_ -> b) + +instance ErrorMonad Err where + raise = Bad + handle a@(Ok _) _ = a + handle (Bad i) f = f i + +instance ErrorMonad (STM s) where + raise msg = STM (\s -> raise msg) + handle (STM f) g = STM (\s -> (f s) + `handle` (\e -> let STM g' = (g e) in + g' s)) +-- if the first check fails try another one +checkAgain :: ErrorMonad m => m a -> m a -> m a +checkAgain c1 c2 = handle_ c1 c2 + +checks :: ErrorMonad m => [m a] -> m a +checks [] = raise "no chance to pass" +checks cs = foldr1 checkAgain cs + +allChecks :: ErrorMonad m => [m a] -> m [a] +allChecks ms = case ms of + (m: ms) -> let rs = allChecks ms in handle_ (liftM2 (:) m rs) rs + _ -> return [] + diff --git a/src/GF/Data/OrdMap2.hs b/src/GF/Data/OrdMap2.hs new file mode 100644 index 000000000..f41d33139 --- /dev/null +++ b/src/GF/Data/OrdMap2.hs @@ -0,0 +1,118 @@ + + +-------------------------------------------------- +-- The class of ordered finite maps +-- as described in section 2.2.2 + +-- and an example implementation, +-- derived from the implementation in appendix A.2 + + +module OrdMap2 (OrdMap(..), Map) where + +import List (intersperse) + + +-------------------------------------------------- +-- the class of ordered finite maps + +class OrdMap m where + emptyMap :: Ord s => m s a + (|->) :: Ord s => s -> a -> m s a + isEmptyMap :: Ord s => m s a -> Bool + (?) :: Ord s => m s a -> s -> Maybe a + lookupWith :: Ord s => a -> m s a -> s -> a + mergeWith :: Ord s => (a -> a -> a) -> m s a -> m s a -> m s a + unionMapWith :: Ord s => (a -> a -> a) -> [m s a] -> m s a + makeMapWith :: Ord s => (a -> a -> a) -> [(s,a)] -> m s a + assocs :: Ord s => m s a -> [(s,a)] + ordMap :: Ord s => [(s,a)] -> m s a + mapMap :: Ord s => (a -> b) -> m s a -> m s b + + lookupWith z m s = case m ? s of + Just a -> a + Nothing -> z + + unionMapWith join = union + where union [] = emptyMap + union [xs] = xs + union xyss = mergeWith join (union xss) (union yss) + where (xss, yss) = split xyss + split (x:y:xyss) = let (xs, ys) = split xyss in (x:xs, y:ys) + split xs = (xs, []) + + +-------------------------------------------------- +-- finite maps as ordered associaiton lists, +-- paired with binary search trees + +data Map s a = Map [(s,a)] (TreeMap s a) + +instance (Eq s, Eq a) => Eq (Map s a) where + Map xs _ == Map ys _ = xs == ys + +instance (Show s, Show a) => Show (Map s a) where + show (Map ass _) = "{" ++ concat (intersperse "," (map show' ass)) ++ "}" + where show' (s,a) = show s ++ "|->" ++ show a + +instance OrdMap Map where + emptyMap = Map [] (makeTree []) + s |-> a = Map [(s,a)] (makeTree [(s,a)]) + + isEmptyMap (Map ass _) = null ass + + Map _ tree ? s = lookupTree s tree + + mergeWith join (Map xss _) (Map yss _) = Map xyss (makeTree xyss) + where xyss = merge xss yss + merge [] yss = yss + merge xss [] = xss + merge xss@(x@(s,x'):xss') yss@(y@(t,y'):yss') + = case compare s t of + LT -> x : merge xss' yss + GT -> y : merge xss yss' + EQ -> (s, join x' y') : merge xss' yss' + + makeMapWith join [] = emptyMap + makeMapWith join [(s,a)] = s |-> a + makeMapWith join xyss = mergeWith join (makeMapWith join xss) (makeMapWith join yss) + where (xss, yss) = split xyss + split (x:y:xys) = let (xs, ys) = split xys in (x:xs, y:ys) + split xs = (xs, []) + + assocs (Map xss _) = xss + ordMap xss = Map xss (makeTree xss) + + mapMap f (Map ass atree) = Map [ (s,f a) | (s,a) <- ass ] (mapTree f atree) + + +-------------------------------------------------- +-- binary search trees +-- for logarithmic lookup time + +data TreeMap s a = Nil | Node (TreeMap s a) s a (TreeMap s a) + +makeTree ass = tree + where + (tree,[]) = sl2bst (length ass) ass + sl2bst 0 ass = (Nil, ass) + sl2bst 1 ((s,a):ass) = (Node Nil s a Nil, ass) + sl2bst n ass = (Node ltree s a rtree, css) + where llen = (n-1) `div` 2 + rlen = n - 1 - llen + (ltree, (s,a):bss) = sl2bst llen ass + (rtree, css) = sl2bst rlen bss + +lookupTree s Nil = Nothing +lookupTree s (Node left s' a right) + = case compare s s' of + LT -> lookupTree s left + GT -> lookupTree s right + EQ -> Just a + +mapTree f Nil = Nil +mapTree f (Node left s a right) = Node (mapTree f left) s (f a) (mapTree f right) + + + + diff --git a/src/GF/Data/OrdSet.hs b/src/GF/Data/OrdSet.hs new file mode 100644 index 000000000..84169a699 --- /dev/null +++ b/src/GF/Data/OrdSet.hs @@ -0,0 +1,111 @@ + + +-------------------------------------------------- +-- The class of ordered sets +-- as described in section 2.2.1 + +-- and an example implementation, +-- derived from the implementation in appendix A.1 + + +module OrdSet (OrdSet(..), Set) where + +import List (intersperse) + + +-------------------------------------------------- +-- the class of ordered sets + +class OrdSet m where + emptySet :: Ord a => m a + unitSet :: Ord a => a -> m a + isEmpty :: Ord a => m a -> Bool + elemSet :: Ord a => a -> m a -> Bool + (<++>) :: Ord a => m a -> m a -> m a + (<\\>) :: Ord a => m a -> m a -> m a + plusMinus :: Ord a => m a -> m a -> (m a, m a) + union :: Ord a => [m a] -> m a + makeSet :: Ord a => [a] -> m a + elems :: Ord a => m a -> [a] + ordSet :: Ord a => [a] -> m a + limit :: Ord a => (a -> m a) -> m a -> m a + + xs <++> ys = fst (plusMinus xs ys) + xs <\\> ys = snd (plusMinus xs ys) + plusMinus xs ys = (xs <++> ys, xs <\\> ys) + + union [] = emptySet + union [xs] = xs + union xyss = union xss <++> union yss + where (xss, yss) = split xyss + split (x:y:xyss) = let (xs, ys) = split xyss in (x:xs, y:ys) + split xs = (xs, []) + + makeSet xs = union (map unitSet xs) + + limit more start = limit' (start, start) + where limit' (old, new) + | isEmpty new' = old + | otherwise = limit' (plusMinus new' old) + where new' = union (map more (elems new)) + + +-------------------------------------------------- +-- sets as ordered lists, +-- paired with a binary tree + +data Set a = Set [a] (TreeSet a) + +instance Eq a => Eq (Set a) where + Set xs _ == Set ys _ = xs == ys + +instance Ord a => Ord (Set a) where + compare (Set xs _) (Set ys _) = compare xs ys + +instance Show a => Show (Set a) where + show (Set xs _) = "{" ++ concat (intersperse "," (map show xs)) ++ "}" + +instance OrdSet Set where + emptySet = Set [] (makeTree []) + unitSet a = Set [a] (makeTree [a]) + + isEmpty (Set xs _) = null xs + elemSet a (Set _ xt) = elemTree a xt + + plusMinus (Set xs _) (Set ys _) = (Set ps (makeTree ps), Set ms (makeTree ms)) + where (ps, ms) = plm xs ys + plm [] ys = (ys, []) + plm xs [] = (xs, xs) + plm xs@(x:xs') ys@(y:ys') = case compare x y of + LT -> let (ps, ms) = plm xs' ys in (x:ps, x:ms) + GT -> let (ps, ms) = plm xs ys' in (y:ps, ms) + EQ -> let (ps, ms) = plm xs' ys' in (x:ps, ms) + + elems (Set xs _) = xs + ordSet xs = Set xs (makeTree xs) + + +-------------------------------------------------- +-- binary search trees +-- for logarithmic lookup time + +data TreeSet a = Nil | Node (TreeSet a) a (TreeSet a) + +makeTree xs = tree + where (tree,[]) = sl2bst (length xs) xs + sl2bst 0 xs = (Nil, xs) + sl2bst 1 (a:xs) = (Node Nil a Nil, xs) + sl2bst n xs = (Node ltree a rtree, zs) + where llen = (n-1) `div` 2 + rlen = n - 1 - llen + (ltree, a:ys) = sl2bst llen xs + (rtree, zs) = sl2bst rlen ys + +elemTree a Nil = False +elemTree a (Node ltree x rtree) + = case compare a x of + LT -> elemTree a ltree + GT -> elemTree a rtree + EQ -> True + + diff --git a/src/GF/Data/Parsers.hs b/src/GF/Data/Parsers.hs new file mode 100644 index 000000000..165d0f4e7 --- /dev/null +++ b/src/GF/Data/Parsers.hs @@ -0,0 +1,143 @@ +module Parsers where + +import Operations +import Char + + +infixr 2 |||, +|| +infixr 3 *** +infixr 5 .>. +infixr 5 ... +infixr 5 .... +infixr 5 +.. +infixr 5 ..+ +infixr 6 |> +infixr 3 <<< + +-- some parser combinators a` la Wadler and Hutton +-- no longer used in many places in GF + +type Parser a b = [a] -> [(b,[a])] + +parseResults :: Parser a b -> [a] -> [b] +parseResults p s = [x | (x,r) <- p s, null r] + +parseResultErr :: Parser a b -> [a] -> Err b +parseResultErr p s = case parseResults p s of + [x] -> return x + [] -> Bad "no parse" + _ -> Bad "ambiguous" + +(...) :: Parser a b -> Parser a c -> Parser a (b,c) +(p ... q) s = [((x,y),r) | (x,t) <- p s, (y,r) <- q t] + +(.>.) :: Parser a b -> (b -> Parser a c) -> Parser a c +(p .>. f) s = [(c,r) | (x,t) <- p s, (c,r) <- f x t] + +(|||) :: Parser a b -> Parser a b -> Parser a b +(p ||| q) s = p s ++ q s + +(+||) :: Parser a b -> Parser a b -> Parser a b +p1 +|| p2 = take 1 . (p1 ||| p2) + +literal :: (Eq a) => a -> Parser a a +literal x (c:cs) = [(x,cs) | x == c] +literal _ _ = [] + +(***) :: Parser a b -> (b -> c) -> Parser a c +(p *** f) s = [(f x,r) | (x,r) <- p s] + +succeed :: b -> Parser a b +succeed v s = [(v,s)] + +fails :: Parser a b +fails s = [] + +(+..) :: Parser a b -> Parser a c -> Parser a c +p1 +.. p2 = p1 ... p2 *** snd + +(..+) :: Parser a b -> Parser a c -> Parser a b +p1 ..+ p2 = p1 ... p2 *** fst + +(<<<) :: Parser a b -> c -> Parser a c -- return +p <<< v = p *** (\x -> v) + +(|>) :: Parser a b -> (b -> Bool) -> Parser a b +p |> b = p .>. (\x -> if b x then succeed x else fails) + +many :: Parser a b -> Parser a [b] +many p = (p ... many p *** uncurry (:)) +|| succeed [] + +some :: Parser a b -> Parser a [b] +some p = (p ... many p) *** uncurry (:) + +longestOfMany :: Parser a b -> Parser a [b] +longestOfMany p = p .>. (\x -> longestOfMany p *** (x:)) +|| succeed [] + +closure :: (b -> Parser a b) -> (b -> Parser a b) +closure p v = p v .>. closure p ||| succeed v + +pJunk :: Parser Char String +pJunk = longestOfMany (satisfy (\x -> elem x "\n\t ")) + +pJ :: Parser Char a -> Parser Char a +pJ p = pJunk +.. p ..+ pJunk + +pTList :: String -> Parser Char a -> Parser Char [a] +pTList t p = p .... many (jL t +.. p) *** (\ (x,y) -> x:y) -- mod. AR 5/1/1999 + +pTJList :: String -> String -> Parser Char a -> Parser Char [a] +pTJList t1 t2 p = p .... many (literals t1 +.. jL t2 +.. p) *** (uncurry (:)) + +pElem :: [String] -> Parser Char String +pElem l = foldr (+||) fails (map literals l) + +(....) :: Parser Char b -> Parser Char c -> Parser Char (b,c) +p1 .... p2 = p1 ... pJunk +.. p2 + +item :: Parser a a +item (c:cs) = [(c,cs)] +item [] = [] + +satisfy :: (a -> Bool) -> Parser a a +satisfy b = item |> b + +literals :: (Eq a,Show a) => [a] -> Parser a [a] +literals l = case l of + [] -> succeed [] + a:l -> literal a ... literals l *** (\ (x,y) -> x:y) + +lits :: (Eq a,Show a) => [a] -> Parser a [a] +lits ts = literals ts + +jL :: String -> Parser Char String +jL = pJ . lits + +pParenth p = literal '(' +.. pJunk +.. p ..+ pJunk ..+ literal ')' +pCommaList p = pTList "," (pJ p) -- p,...,p +pOptCommaList p = pCommaList p ||| succeed [] -- the same or nothing +pArgList p = pParenth (pCommaList p) ||| succeed [] -- (p,...,p), poss. empty +pArgList2 p = pParenth (p ... jL "," +.. pCommaList p) *** uncurry (:) -- min.2 args + +longestOfSome p = (p ... longestOfMany p) *** (\ (x,y) -> x:y) + +pIdent = pLetter ... longestOfMany pAlphaPlusChar *** uncurry (:) + where alphaPlusChar c = isAlphaNum c || c=='_' || c=='\'' + +pLetter = satisfy (`elem` (['A'..'Z'] ++ ['a'..'z'] ++ + ['À' .. 'Û'] ++ ['à' .. 'û'])) -- no such in Char +pDigit = satisfy isDigit +pLetters = longestOfSome pLetter +pAlphanum = pDigit ||| pLetter +pAlphaPlusChar = pAlphanum ||| satisfy (`elem` "_'") + +pQuotedString = literal '"' +.. pEndQuoted where + pEndQuoted = + literal '"' *** (const []) + +|| (literal '\\' +.. item .>. \ c -> pEndQuoted *** (c:)) + +|| item .>. \ c -> pEndQuoted *** (c:) + +pIntc :: Parser Char Int +pIntc = some (satisfy numb) *** read + where numb x = elem x ['0'..'9'] + diff --git a/src/GF/Data/Str.hs b/src/GF/Data/Str.hs new file mode 100644 index 000000000..743bd71b8 --- /dev/null +++ b/src/GF/Data/Str.hs @@ -0,0 +1,106 @@ +module Str ( + Str (..), Tok (..), --- constructors needed in PrGrammar + str2strings, str2allStrings, str, sstr, sstrV, + isZeroTok, prStr, plusStr, glueStr, + strTok, + allItems +) where + +import Operations +import List (isPrefixOf, isSuffixOf, intersperse) + +-- abstract token list type. AR 2001, revised and simplified 20/4/2003 + +newtype Str = Str [Tok] deriving (Read, Show, Eq, Ord) + +data Tok = + TK String + | TN Ss [(Ss, [String])] -- variants depending on next string + deriving (Eq, Ord, Show, Read) + +-- notice that having both pre and post would leave to inconsistent situations: +-- pre {"x" ; "y" / "a"} ++ post {"b" ; "a" / "x"} +-- always violates a condition expressed by the one or the other + +-- a variant can itself be a token list, but for simplicity only a list of strings +-- i.e. not itself containing variants + +type Ss = [String] + +-- matching functions in both ways + +matchPrefix :: Ss -> [(Ss,[String])] -> [String] -> Ss +matchPrefix s vs t = + head ([u | (u,as) <- vs, any (\c -> isPrefixOf c (concat t)) as] ++ [s]) + +str2strings :: Str -> Ss +str2strings (Str st) = alls st where + alls st = case st of + TK s : ts -> s : alls ts + TN ds vs : ts -> matchPrefix ds vs t ++ t where t = alls ts + [] -> [] + +str2allStrings :: Str -> [Ss] +str2allStrings (Str st) = alls st where + alls st = case st of + TK s : ts -> [s : t | t <- alls ts] + TN ds vs : [] -> [ds ++ v | v <- map fst vs] + TN ds vs : ts -> [matchPrefix ds vs t ++ t | t <- alls ts] + [] -> [[]] + +sstr :: Str -> String +sstr = unwords . str2strings + +-- to handle a list of variants + +sstrV :: [Str] -> String +sstrV ss = case ss of + [] -> "*" + _ -> unwords $ intersperse "/" $ map (unwords . str2strings) ss + +str :: String -> Str +str s = if null s then Str [] else Str [itS s] + +itS :: String -> Tok +itS s = TK s + +isZeroTok :: Str -> Bool +isZeroTok t = case t of + Str [] -> True + Str [TK []] -> True + _ -> False + +strTok :: Ss -> [(Ss,[String])] -> Str +strTok ds vs = Str [TN ds vs] + +prStr = prQuotedString . sstr + +plusStr :: Str -> Str -> Str +plusStr (Str ss) (Str tt) = Str (ss ++ tt) + +glueStr :: Str -> Str -> Str +glueStr (Str ss) (Str tt) = Str $ case (ss,tt) of + ([],_) -> tt + (_,[]) -> ss + _ -> init ss ++ glueIt (last ss) (head tt) ++ tail tt + where + glueIt t u = case (t,u) of + (TK s, TK s') -> return $ TK $ s ++ s' + (TN ds vs, TN es ws) -> return $ TN (glues (matchPrefix ds vs es) es) + [(glues (matchPrefix ds vs w) w,cs) | (w,cs) <- ws] + (TN ds vs, TK s) -> map TK $ glues (matchPrefix ds vs [s]) [s] + (TK s, TN es ws) -> return $ TN (glues [s] es) [(glues [s] w, c) | (w,c) <- ws] + +glues :: [[a]] -> [[a]] -> [[a]] +glues ss tt = case (ss,tt) of + ([],_) -> tt + (_,[]) -> ss + _ -> init ss ++ [last ss ++ head tt] ++ tail tt + +-- to create the list of all lexical items + +allItems :: Str -> [String] +allItems (Str s) = concatMap allOne s where + allOne t = case t of + TK s -> [s] + TN ds vs -> ds ++ concatMap fst vs diff --git a/src/GF/Data/Zipper.hs b/src/GF/Data/Zipper.hs new file mode 100644 index 000000000..d498c5a56 --- /dev/null +++ b/src/GF/Data/Zipper.hs @@ -0,0 +1,172 @@ +module Zipper where + +import Operations + +-- Gérard Huet's zipper (JFP 7 (1997)). AR 10/8/2001 + +newtype Tr a = Tr (a,[Tr a]) deriving (Show,Eq) + +data Path a = + Top + | Node ([Tr a], (Path a, a), [Tr a]) + deriving Show + +leaf a = Tr (a,[]) + +newtype Loc a = Loc (Tr a, Path a) deriving Show + +goLeft, goRight, goUp, goDown :: Loc a -> Err (Loc a) +goLeft (Loc (t,p)) = case p of + Top -> Bad "left of top" + Node (l:left, upv, right) -> return $ Loc (l, Node (left,upv,t:right)) + Node _ -> Bad "left of first" +goRight (Loc (t,p)) = case p of + Top -> Bad "right of top" + Node (left, upv, r:right) -> return $ Loc (r, Node (t:left,upv,right)) + Node _ -> Bad "right of first" +goUp (Loc (t,p)) = case p of + Top -> Bad "up of top" + Node (left, (up,v), right) -> + return $ Loc (Tr (v, reverse left ++ (t:right)), up) +goDown (Loc (t,p)) = case t of + Tr (v,(t1:trees)) -> return $ Loc (t1,Node ([],(p,v),trees)) + _ -> Bad "down of empty" + +changeLoc :: Loc a -> Tr a -> Err (Loc a) +changeLoc (Loc (_,p)) t = return $ Loc (t,p) + +changeNode :: (a -> a) -> Loc a -> Loc a +changeNode f (Loc (Tr (n,ts),p)) = Loc (Tr (f n, ts),p) + +forgetNode :: Loc a -> Err (Loc a) +forgetNode (Loc (Tr (n,[t]),p)) = return $ Loc (t,p) +forgetNode _ = Bad $ "not a one-branch tree" + +-- added sequential representation + +-- a successor function +goAhead :: Loc a -> Err (Loc a) +goAhead s@(Loc (t,p)) = case (t,p) of + (Tr (_,_:_),Node (_,_,_:_)) -> goDown s + (Tr (_,[]), _) -> upsRight s + (_, _) -> goDown s + where + upsRight t = case goRight t of + Ok t' -> return t' + Bad _ -> goUp t >>= upsRight + +-- a predecessor function +goBack :: Loc a -> Err (Loc a) +goBack s@(Loc (t,p)) = case goLeft s of + Ok s' -> downRight s' + _ -> goUp s + where + downRight s = case goDown s of + Ok s' -> case goRight s' of + Ok s'' -> downRight s'' + _ -> downRight s' + _ -> return s + +-- n-ary versions + +goAheadN :: Int -> Loc a -> Err (Loc a) +goAheadN i st + | i < 1 = return st + | otherwise = goAhead st >>= goAheadN (i-1) + +goBackN :: Int -> Loc a -> Err (Loc a) +goBackN i st + | i < 1 = return st + | otherwise = goBack st >>= goBackN (i-1) + +-- added mappings between locations and trees + +loc2tree (Loc (t,p)) = case p of + Top -> t + Node (left,(p',v),right) -> + loc2tree (Loc (Tr (v, reverse left ++ (t : right)),p')) + +loc2treeMarked :: Loc a -> Tr (a, Bool) +loc2treeMarked (Loc (Tr (a,ts),p)) = + loc2tree (Loc (Tr (mark a, map (mapTr nomark) ts), mapPath nomark p)) + where + (mark, nomark) = (\a -> (a,True), \a -> (a, False)) + +tree2loc t = Loc (t,Top) + +goRoot = tree2loc . loc2tree + +goLast :: Loc a -> Err (Loc a) +goLast = rep goAhead where + rep f s = err (const (return s)) (rep f) (f s) + +-- added some utilities + +traverseCollect :: Path a -> [a] +traverseCollect p = reverse $ case p of + Top -> [] + Node (_, (p',v), _) -> v : traverseCollect p' + +scanTree :: Tr a -> [a] +scanTree (Tr (a,ts)) = a : concatMap scanTree ts + +mapTr :: (a -> b) -> Tr a -> Tr b +mapTr f (Tr (x,ts)) = Tr (f x, map (mapTr f) ts) + +mapTrM :: Monad m => (a -> m b) -> Tr a -> m (Tr b) +mapTrM f (Tr (x,ts)) = do + fx <- f x + fts <- mapM (mapTrM f) ts + return $ Tr (fx,fts) + +mapPath :: (a -> b) -> Path a -> Path b +mapPath f p = case p of + Node (ts1, (p,v), ts2) -> + Node (map (mapTr f) ts1, (mapPath f p, f v), map (mapTr f) ts2) + Top -> Top + +mapPathM :: Monad m => (a -> m b) -> Path a -> m (Path b) +mapPathM f p = case p of + Node (ts1, (p,v), ts2) -> do + ts1' <- mapM (mapTrM f) ts1 + p' <- mapPathM f p + v' <- f v + ts2' <- mapM (mapTrM f) ts2 + return $ Node (ts1', (p',v'), ts2') + Top -> return Top + +mapLoc :: (a -> b) -> Loc a -> Loc b +mapLoc f (Loc (t,p)) = Loc (mapTr f t, mapPath f p) + +mapLocM :: Monad m => (a -> m b) -> Loc a -> m (Loc b) +mapLocM f (Loc (t,p)) = do + t' <- mapTrM f t + p' <- mapPathM f p + return $ (Loc (t',p')) + +foldTr :: (a -> [b] -> b) -> Tr a -> b +foldTr f (Tr (x,ts)) = f x (map (foldTr f) ts) + +foldTrM :: Monad m => (a -> [b] -> m b) -> Tr a -> m b +foldTrM f (Tr (x,ts)) = do + fts <- mapM (foldTrM f) ts + f x fts + +mapSubtrees :: (Tr a -> Tr a) -> Tr a -> Tr a +mapSubtrees f t = let Tr (x,ts) = f t in Tr (x, map (mapSubtrees f) ts) + +mapSubtreesM :: Monad m => (Tr a -> m (Tr a)) -> Tr a -> m (Tr a) +mapSubtreesM f t = do + Tr (x,ts) <- f t + ts' <- mapM (mapSubtreesM f) ts + return $ Tr (x, ts') + +-- change the root without moving the pointer +changeRoot :: (a -> a) -> Loc a -> Loc a +changeRoot f loc = case loc of + Loc (Tr (a,ts),Top) -> Loc (Tr (f a,ts),Top) + Loc (t, Node (left,pv,right)) -> Loc (t, Node (left,chPath pv,right)) + where + chPath pv = case pv of + (Top,a) -> (Top, f a) + (Node (left,pv,right),v) -> (Node (left, chPath pv,right),v) diff --git a/src/GF/Fudgets/ArchEdit.hs b/src/GF/Fudgets/ArchEdit.hs new file mode 100644 index 000000000..82653595d --- /dev/null +++ b/src/GF/Fudgets/ArchEdit.hs @@ -0,0 +1,16 @@ +module ArchEdit ( + fudlogueEdit, fudlogueWrite, fudlogueWriteUni + ) where + +import CommandF +import UnicodeF + +-- architecture/compiler dependent definitions for unix/ghc, if Fudgets works. +-- If not, use the modules in for-ghci + +fudlogueEdit font = fudlogueEditF ---- +fudlogueWrite = fudlogueWriteU +fudlogueWriteUni _ _ = do + putStrLn "sorry no unicode available in ghc" + + diff --git a/src/GF/Fudgets/CommandF.hs b/src/GF/Fudgets/CommandF.hs new file mode 100644 index 000000000..8bf791a61 --- /dev/null +++ b/src/GF/Fudgets/CommandF.hs @@ -0,0 +1,120 @@ +module CommandF where + +import Operations + +import Session +import Commands + +import Fudgets +import FudgetOps + +import EventF + +-- a graphical shell for any kind of GF with Zipper editing. AR 20/8/2001 + +fudlogueEditF :: CEnv -> IO () +fudlogueEditF env = + fudlogue $ gfSizeP $ shellF ("GF 1.1 Fudget Editor") (gfF env) + +gfF env = nameLayoutF gfLayout $ (gfOutputF env >==< gfCommandF env) >+< quitButF + +( quitN : menusN : newN : transformN : filterN : displayN : + navigateN : viewN : outputN : saveN : _) = map show [1..] + +gfLayout = placeNL verticalP [generics,output,navigate,menus,transform] + where + generics = placeNL horizontalP (map leafNL + [newN,saveN,viewN,displayN,filterN,quitN]) + output = leafNL outputN + navigate = leafNL navigateN + menus = leafNL menusN + transform = leafNL transformN + +gfSizeP = spacerF (sizeS (Point 720 640)) + +gfOutputF env = + ((nameF outputN $ (writeFileF >+< textWindowF)) + >==< + (absF (saveSP "EMPTY") + >==< + (nameF saveN (popupStringInputF "Save" "foo.tmp" "Save to file:") + >+< + mapF (displayJustStateIn env)))) + >==< + mapF Right + +gfCommandF :: CEnv -> F () SState +gfCommandF env = loopCommandsF env >==< getCommandsF env >==< mapF (\_ -> Click) + +loopCommandsF :: CEnv -> F Command SState +loopCommandsF env = loopThroughRightF (mapGfStateF env) (mkMenusF env) + +mapGfStateF :: CEnv -> F (Either Command Command) (Either SState SState) +mapGfStateF env = mapstateF execFC (initSState) where + execFC e0 (Left c) = (e,[Right e,Left e]) where e = execECommand env c e0 + execFC e0 (Right c) = (e,[Left e,Right e]) where e = execECommand env c e0 + +mkMenusF :: CEnv -> F SState Command +mkMenusF env = + nameF menusN $ + labAboveF "Select Action on Subterm" + (mapF fst >==< smallPickListF snd >==< mapF (mkRefineMenu env)) + +getCommandsF env = + newF env >*< + viewF >*< + menuDisplayF env >*< + filterF >*< + navigateF >*< + transformF + +key2command ((key,_),_) = case key of + "Up" -> CBack 1 + "Down" -> CAhead 1 + "Left" -> CPrevMeta + "Right" -> CNextMeta + "space" -> CTop + + "d" -> CDelete + "u" -> CUndo + "v" -> CView + + _ -> CVoid + +transformF = + nameF transformN $ + mapF (either key2command id) >==< (keyboardF $ + placerF horizontalP $ + cPopupStringInputF CRefineParse "Parse" "" "Parse in concrete syntax" >*< + --- to enable Unicode: ("Refine by parsing" `labLeftOfF` writeInputF) + cPopupStringInputF CRefineWithTree "Term" "" "Parse term" >*< + cMenuF "Modify" termCommandMenu >*< + cPopupStringInputF CAlphaConvert "Alpha" "x_0 x" "Alpha convert" >*< + cButtonF CRefineRandom "Random" >*< + cButtonF CUndo "Undo" + ) + +quitButF = nameF quitN $ quitF >==< buttonF "Quit" + +newF env = nameF newN $ cMenuF "New" (newCatMenu env) +menuDisplayF env = nameF displayN $ cMenuF "Menus" $ displayCommandMenu env +filterF = nameF filterN $ cMenuF "Filter" stringCommandMenu + +viewF = nameF viewN $ cButtonF CView "View" + +navigateF = + nameF navigateN $ + placerF horizontalP $ + cButtonF CPrevMeta "?<" >*< + cButtonF (CBack 1) "<" >*< + cButtonF CTop "Top" >*< + cButtonF CLast "Last" >*< + cButtonF (CAhead 1) ">" >*< + cButtonF CNextMeta ">?" + +cButtonF c s = mapF (const c) >==< buttonF s +cMenuF s css = menuF s css >==< mapF (\_ -> CVoid) + +cPopupStringInputF comm lab def msg = + mapF comm >==< popupStringInputF lab def msg >==< mapF (const []) + diff --git a/src/GF/Fudgets/EventF.hs b/src/GF/Fudgets/EventF.hs new file mode 100644 index 000000000..cfcf3e401 --- /dev/null +++ b/src/GF/Fudgets/EventF.hs @@ -0,0 +1,36 @@ +module EventF where +import AllFudgets + +-- The first string is the name of the key (e.g., "Down" for the down arrow key) +-- The modifiers list shift, control and alt keys that were active while the +-- key was pressed. +-- The last string is the text produced by the key (for keys that produce +-- printable characters, empty for control keys). + +type KeyPress = ((String,[Modifiers]),String) + +keyboardF :: F i o -> F i (Either KeyPress o) +keyboardF fud = idRightSP (concatMapSP post) >^^=< oeventF mask fud + where + post (KeyEvent {type'=Pressed,keySym=sym,state=mods,keyLookup=s}) = + [((sym,mods),s)] + post _ = [] + + mask = [KeyPressMask, + EnterWindowMask, LeaveWindowMask -- because of CTT implementation + ] + +-- Output events: +oeventF em fud = eventF em (idLeftF fud) + +-- Feed events to argument fudget: +eventF eventmask = serCompLeftToRightF . groupF startcmds eventK + where + startcmds = [XCmd $ ChangeWindowAttributes [CWEventMask eventmask], + XCmd $ ConfigureWindow [CWBorderWidth 0]] + eventK = K $ mapFilterSP route + where route = message low high + low (XEvt event) = Just (High (Left event)) + low _ = Nothing + high h = Just (High (Right h)) + diff --git a/src/GF/Fudgets/FudgetOps.hs b/src/GF/Fudgets/FudgetOps.hs new file mode 100644 index 000000000..6c4e1a8b2 --- /dev/null +++ b/src/GF/Fudgets/FudgetOps.hs @@ -0,0 +1,47 @@ +module FudgetOps where + +import Fudgets + +-- auxiliary Fudgets for GF syntax editor + +-- save and display + +showAndSaveF fud = (writeFileF >+< textWindowF) >==< saveF fud + +saveF :: F a String -> F (Either String a) (Either (String,String) String) +saveF fud = + absF (saveSP "EMPTY") + >==< + (popupStringInputF "Save" "foo.tmp" "Save to file:" >+< fud) + +saveSP :: String -> SP (Either String String) (Either (String,String) String) +saveSP contents = getSP $ \msg -> case msg of + Left file -> putSP (Left (file,contents)) (saveSP contents) + Right string -> putSP (Right string) (saveSP string) + +textWindowF = writeOutputF + +-- to replace stringInputF by a pop-up slot behind a button +popupStringInputF :: String -> String -> String -> F String String +popupStringInputF label deflt msg = + mapF snd + >==< + (popupSizeP $ stringPopupF deflt) + >==< + mapF (\_ -> (Just msg,Nothing)) + >==< + decentButtonF label + >==< + mapF (\_ -> Click) + +decentButtonF = spacerF (sizeS (Point 80 20)) . buttonF + +popupSizeP = spacerF (sizeS (Point 240 100)) + +--- the Unicode stuff should be inserted here + +writeOutputF = moreF >==< mapF lines + +writeInputF = stringInputF + + diff --git a/src/GF/Fudgets/UnicodeF.hs b/src/GF/Fudgets/UnicodeF.hs new file mode 100644 index 000000000..22a250658 --- /dev/null +++ b/src/GF/Fudgets/UnicodeF.hs @@ -0,0 +1,23 @@ +module UnicodeF where +import Fudgets + +import Operations +import Unicode + +-- AR 12/4/2000, 18/9/2001 (added font parameter) + +fudlogueWriteU :: String -> (String -> String) -> IO () +fudlogueWriteU fn trans = + fudlogue $ + shellF "GF Unicode Output" (writeF fn trans >+< quitButtonF) + +writeF fn trans = writeOutputF fn >==< mapF trans >==< writeInputF fn + +displaySizeP = placerF (spacerP (sizeS (Point 440 500)) verticalP) + +writeOutputF fn = moreF' (setFont fn) >==< justWriteOutputF + +justWriteOutputF = mapF (map (wrapLines 0) . filter (/=[]) . map mkUnicode . lines) + +writeInputF fn = stringInputF' (setShowString mkUnicode . setFont fn) + diff --git a/src/GF/Grammar/AbsCompute.hs b/src/GF/Grammar/AbsCompute.hs new file mode 100644 index 000000000..52a2ca678 --- /dev/null +++ b/src/GF/Grammar/AbsCompute.hs @@ -0,0 +1,64 @@ +module AbsCompute where + +import Operations + +import Abstract +import PrGrammar +import LookAbs +import PatternMatch +import Compute + +import Monad (liftM, liftM2) + +-- computation in abstract syntax w.r.t. explicit definitions. +--- old GF computation; to be updated + +compute :: GFCGrammar -> Exp -> Err Exp +compute = computeAbsTerm + +computeAbsTerm :: GFCGrammar -> Exp -> Err Exp +computeAbsTerm gr = computeAbsTermIn gr [] + +computeAbsTermIn :: GFCGrammar -> [Ident] -> Exp -> Err Exp +computeAbsTermIn gr = compt where + compt vv t = case t of + Prod x a b -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b) + Abs x b -> liftM (Abs x) (compt (x:vv) b) + _ -> do + let t' = beta vv t + (yy,f,aa) <- termForm t' + let vv' = yy ++ vv + aa' <- mapM (compt vv') aa + case look f of + Just (Eqs eqs) -> case findMatch eqs aa' of + Ok (d,g) -> do + let (xs,ts) = unzip g + ts' <- alphaFreshAll vv' ts --- + let g' = zip xs ts' + d' <- compt vv' $ substTerm vv' g' d + return $ mkAbs yy $ d' + _ -> do + return $ mkAbs yy $ mkApp f aa' + Just d -> do + d' <- compt vv' d + da <- ifNull (return d') (compt vv' . mkApp d') aa' + return $ mkAbs yy $ da + _ -> do + return $ mkAbs yy $ mkApp f aa' + + look (Q m f) = case lookupAbsDef gr m f of + Ok (Just (Eqs [])) -> Nothing -- canonical + Ok md -> md + _ -> Nothing + look _ = Nothing + +beta :: [Ident] -> Exp -> Exp +beta vv c = case c of + App (Abs x b) a -> beta vv $ substTerm vv [xvv] (beta (x:vv) b) + where xvv = (x,beta vv a) + App f a -> let (a',f') = (beta vv a, beta vv f) in + (if a'==a && f'==f then id else beta vv) $ App f' a' + Prod x a b -> Prod x (beta vv a) (beta (x:vv) b) + Abs x b -> Abs x (beta (x:vv) b) + _ -> c + diff --git a/src/GF/Grammar/Abstract.hs b/src/GF/Grammar/Abstract.hs new file mode 100644 index 000000000..538fff90b --- /dev/null +++ b/src/GF/Grammar/Abstract.hs @@ -0,0 +1,24 @@ +module Abstract ( + +module Grammar, +module Values, +module Macros, +module Ident, +module MMacros, +module PrGrammar, + +Grammar + + ) where + +import Grammar +import Values +import Macros +import Ident +import MMacros +import PrGrammar + +type Grammar = SourceGrammar --- + + + diff --git a/src/GF/Grammar/AppPredefined.hs b/src/GF/Grammar/AppPredefined.hs new file mode 100644 index 000000000..f59c910b0 --- /dev/null +++ b/src/GF/Grammar/AppPredefined.hs @@ -0,0 +1,51 @@ +module AppPredefined where + +import Operations +import Grammar +import Ident +import PrGrammar (prt) +---- import PGrammar (pTrm) + +-- predefined function definitions. AR 12/3/2003. +-- Type checker looks at signatures in predefined.gf + +appPredefined :: Term -> Term +appPredefined t = case t of + + App f x -> case f of + + -- one-place functions + Q (IC "Predef") (IC f) -> case (f, appPredefined x) of + ("length", K s) -> EInt $ length s + _ -> t + + -- two-place functions + App (Q (IC "Predef") (IC f)) z -> case (f, appPredefined z, appPredefined x) of + ("drop", EInt i, K s) -> K (drop i s) + ("take", EInt i, K s) -> K (take i s) + ("tk", EInt i, K s) -> K (take (max 0 (length s - i)) s) + ("dp", EInt i, K s) -> K (drop (max 0 (length s - i)) s) + ("eqStr",K s, K t) -> if s == t then predefTrue else predefFalse + ("eqInt",EInt i, EInt j) -> if i==j then predefTrue else predefFalse + ("plus", EInt i, EInt j) -> EInt $ i+j + ("show", _, t) -> K $ prt t + ("read", _, K s) -> str2tag s --- because of K, only works for atomic tags + _ -> t + _ -> t + _ -> t + +-- read makes variables into constants + +str2tag :: String -> Term +str2tag s = case s of +---- '\'' : cs -> mkCn $ pTrm $ init cs + _ -> Cn $ IC s --- + where + mkCn t = case t of + Vr i -> Cn i + App c a -> App (mkCn c) (mkCn a) + _ -> t + + +predefTrue = Q (IC "Predef") (IC "PTrue") +predefFalse = Q (IC "Predef") (IC "PFalse") diff --git a/src/GF/Grammar/Compute.hs b/src/GF/Grammar/Compute.hs new file mode 100644 index 000000000..1f1eba28c --- /dev/null +++ b/src/GF/Grammar/Compute.hs @@ -0,0 +1,238 @@ +module Compute where + +import Operations +import Grammar +import Ident +import Str +import PrGrammar +import Modules +import Macros +import Lookup +import Refresh +import PatternMatch + +import AppPredefined + +import List (nub,intersperse) +import Monad (liftM2, liftM) + +-- computation of concrete syntax terms into normal form +-- used mainly for partial evaluation + +computeConcrete :: SourceGrammar -> Term -> Err Term +computeConcrete g t = {- refreshTerm t >>= -} computeTerm g [] t + +computeTerm :: SourceGrammar -> Substitution -> Term -> Err Term +computeTerm gr = comp where + + comp g t = --- errIn ("subterm" +++ prt t) $ --- for debugging + case t of + + Q (IC "Predef") _ -> return t + Q p c -> look p c + + -- if computed do nothing + Computed t' -> return $ unComputed t' + + Vr x -> do + t' <- maybe (prtBad ("no value given to variable") x) return $ lookup x g + case t' of + _ | t == t' -> return t + _ -> comp g t' + + Abs x b -> do + b' <- comp (ext x (Vr x) g) b + return $ Abs x b' + + Let (x,(_,a)) b -> do + a' <- comp g a + comp (ext x a' g) b + + Prod x a b -> do + a' <- comp g a + b' <- comp (ext x (Vr x) g) b + return $ Prod x a' b' + + -- beta-convert + App f a -> do + f' <- comp g f + a' <- comp g a + case (f',a') of + (Abs x b,_) -> comp (ext x a' g) b + (FV fs, _) -> mapM (\c -> comp g (App c a')) fs >>= return . FV + (_, FV as) -> mapM (\c -> comp g (App f' c)) as >>= return . FV + + (Alias _ _ d, _) -> comp g (App d a') + + (S (T i cs) e,_) -> prawitz g i (flip App a') cs e + + _ -> returnC $ appPredefined $ App f' a' + P t l -> do + t' <- comp g t + case t' of + FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . FV + R r -> maybe (prtBad "no value for label" l) (comp g . snd) $ lookup l r + + ExtR (R a) b -> -- NOT POSSIBLE both a and b records! + case comp g (P (R a) l) of + Ok v -> return v + _ -> comp g (P b l) + ExtR a (R b) -> + case comp g (P (R b) l) of + Ok v -> return v + _ -> comp g (P a l) + + Alias _ _ r -> comp g (P r l) + + S (T i cs) e -> prawitz g i (flip P l) cs e + + _ -> returnC $ P t' l + + S t v -> do + t' <- comp g t + v' <- comp g v + case t' of + T _ [(PV IW,c)] -> comp g c --- an optimization + T _ [(PT _ (PV IW),c)] -> comp g c + + T _ [(PV z,c)] -> comp (ext z v' g) c --- another optimization + T _ [(PT _ (PV z),c)] -> comp (ext z v' g) c + + FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . FV + + T _ cc -> case v' of + FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . FV + _ -> case matchPattern cc v' of + Ok (c,g') -> comp (g' ++ g) c + _ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t + _ -> return $ S t' v' -- if v' is not canonical + + Alias _ _ d -> comp g (S d v') + + S (T i cs) e -> prawitz g i (flip S v') cs e + + _ -> returnC $ S t' v' + + -- glue if you can + Glue x0 y0 -> do + x <- comp g x0 + y <- comp g y0 + case (x,y) of + (Alias _ _ d, y) -> comp g $ Glue d y + (x, Alias _ _ d) -> comp g $ Glue x d + + (S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e + (s, S (T i cs) e) -> prawitz g i (Glue s) cs e + (_,K "") -> return x + (K "",_) -> return y + (K a, K b) -> return $ K (a ++ b) + (K a, Alts (d,vs)) -> do + let glx = Glue x + comp g $ Alts (glx d, [(glx v,c) | (v,c) <- vs]) + (Alts _, K a) -> do + x' <- strsFromTerm x + return $ variants [ + foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x'] + _ -> do + mapM_ checkNoArgVars [x,y] + r <- composOp (comp g) t + returnC r + + Alts _ -> do + r <- composOp (comp g) t + returnC r + + -- remove empty + C a b -> do + a' <- comp g a + b' <- comp g b + returnC $ case (a',b') of + (Empty,_) -> b' + (_,Empty) -> a' + _ -> C a' b' + + -- reduce free variation as much as you can + FV [t] -> comp g t + + -- merge record extensions if you can + ExtR r s -> do + r' <- comp g r + s' <- comp g s + case (r',s') of + (Alias _ _ d, _) -> comp g $ ExtR d s' + (_, Alias _ _ d) -> comp g $ Glue r' d + + (R rs, R ss) -> return $ R (rs ++ ss) + (RecType rs, RecType ss) -> return $ RecType (rs ++ ss) + _ -> return $ ExtR r' s' + + -- case-expand tables + T i cs -> do + pty0 <- getTableType i + ptyp <- comp g pty0 + case allParamValues gr ptyp of + Ok vs -> do + + cs' <- mapM (compBranchOpt g) cs + sts <- mapM (matchPattern cs') vs + ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts + ps <- mapM term2patt vs + let ps' = ps --- PT ptyp (head ps) : tail ps + return $ T (TComp ptyp) (zip ps' ts) + _ -> do + cs' <- mapM (compBranch g) cs + return $ T i cs' -- happens with variable types + + Alias c a d -> do + d' <- comp g d + return $ Alias c a d' -- alias only disappears in certain redexes + + -- otherwise go ahead + _ -> composOp (comp g) t >>= returnC + + where + + look = lookupResDef gr + + ext x a g = (x,a):g + + returnC = return --- . computed + + variants [t] = t + variants ts = FV ts + + isCan v = case v of + Con _ -> True + QC _ _ -> True + App f a -> isCan f && isCan a + R rs -> all (isCan . snd . snd) rs + _ -> False + + compBranch g (p,v) = do + let g' = contP p ++ g + v' <- comp g' v + return (p,v') + + compBranchOpt g c@(p,v) = case contP p of + [] -> return c + _ -> err (const (return c)) return $ compBranch g c + + contP p = case p of + PV x -> [(x,Vr x)] + PC _ ps -> concatMap contP ps + PP _ _ ps -> concatMap contP ps + PT _ p -> contP p + PR rs -> concatMap (contP . snd) rs + _ -> [] + + prawitz g i f cs e = do + cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs] + return $ S (T i cs') e + +-- argument variables cannot be glued + +checkNoArgVars :: Term -> Err Term +checkNoArgVars t = case t of + Vr (IA _) -> prtBad "cannot glue (+) term with run-time variable" t + Vr (IAV _) -> prtBad "cannot glue (+) term with run-time variable" t + _ -> composOp checkNoArgVars t diff --git a/src/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs new file mode 100644 index 000000000..1ee5425c4 --- /dev/null +++ b/src/GF/Grammar/Grammar.hs @@ -0,0 +1,154 @@ +module Grammar where + +import Str +import Ident +import Option --- +import Modules + +import Operations + +-- AR 23/1/2000 -- 30/5/2001 -- 4/5/2003 + +-- grammar as presented to the compiler + +type SourceGrammar = MGrammar Ident Option Info + +type SourceModInfo = ModInfo Ident Option Info + +type SourceModule = (Ident, SourceModInfo) + +type SourceAbs = Module Ident Option Info +type SourceRes = Module Ident Option Info +type SourceCnc = Module Ident Option Info + +-- judgements in abstract syntax + +data Info = + AbsCat (Perh Context) (Perh [Fun]) -- constructors + | AbsFun (Perh Type) (Perh Term) -- Yes f = canonical + | AbsTrans Ident + +-- judgements in resource + | ResParam (Perh [Param]) + | ResValue (Perh Type) -- to mark parameter constructors for lookup + | ResOper (Perh Type) (Perh Term) + +-- judgements in concrete syntax + | CncCat (Perh Type) (Perh Term) MPr -- lindef ini'zed, + | CncFun (Maybe (Ident,(Context,Type))) (Perh Term) MPr -- type info added at TC + +-- indirection to module Ident; the Bool says if canonical + | AnyInd Bool Ident + deriving (Read, Show) + +type Perh a = Perhaps a Ident -- to express indirection to other module + +type MPr = Perhaps Term Ident -- printname + +type Type = Term +type Cat = QIdent +type Fun = QIdent + +type QIdent = (Ident,Ident) + +data Term = + Vr Ident -- variable + | Cn Ident -- constant + | Con Ident -- constructor + | Sort String -- basic type + | EInt Int -- integer 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 + + | ECase Term [Branch] -- case expression in abstract syntax à la Alfa + +-- below this only for concrete syntax + | RecType [Labelling] -- record type: { p : A ; ...} + | R [Assign] -- record: { p = a ; ...} + | P Term Label -- projection: r.p + | 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 ; ...} + | S Term Term -- selection: t ! p + + | Let LocalDef Term -- local definition: let {t : T = a} in b + + | Alias Ident Type Term -- constant and its definition, used in inlining + + | Q Ident Ident -- qualified constant from a package + | QC Ident Ident -- qualified constructor from a package + + | C Term Term -- concatenation: s ++ t + | Glue Term Term -- agglutination: s + t + + | FV [Term] -- alternatives in free variation: variants { s ; ... } + + | Alts (Term, [(Term, Term)]) -- alternatives by prefix: pre {t ; s/c ; ...} + | Strs [Term] -- conditioning prefix strings: strs {s ; ...} + + --- these three are obsolete + | LiT Ident -- linearization type + | Ready Str -- result of compiling; not to be parsed ... + | Computed Term -- result of computing: not to be reopened nor parsed + + deriving (Read, Show, Eq, Ord) + +data Patt = + PC Ident [Patt] -- constructor pattern: C p1 ... pn C + | PP Ident Ident [Patt] -- package constructor pattern: P.C p1 ... pn P.C + | PV Ident -- variable pattern: x + | PW -- wild card pattern: _ + | PR [(Label,Patt)] -- record pattern: {r = p ; ...} -- only concrete + | PString String -- string literal pattern: "foo" -- only abstract + | PInt Int -- integer literal pattern: 12 -- only abstract + | PT Type Patt -- type-annotated pattern + 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 annontated, but can be anything + | TComp Type -- expanded + | TWild Type -- just one wild card pattern, no need to expand + deriving (Read, Show, Eq, Ord) + +data Label = + LIdent String + | LVar Int + deriving (Read, Show, Eq, Ord) -- record label + +newtype MetaSymb = MetaSymb Int deriving (Read, Show, Eq, Ord) + +type Decl = (Ident,Term) -- (x:A) (_:A) A +type Context = [Decl] -- (x:A)(y:B) (x,y:A) (_,_:A) +type Equation = ([Patt],Term) + +type Labelling = (Label, Term) +type Assign = (Label, (Maybe Type, Term)) +type Case = (Patt, Term) +type LocalDef = (Ident, (Maybe Type, Term)) + +type Param = (Ident, Context) +type Altern = (Term, [(Term, Term)]) + +type Substitution = [(Ident, Term)] + +-- branches à la Alfa +newtype Branch = Branch (Con,([Ident],Term)) deriving (Eq, Ord,Show,Read) +type Con = Ident --- + +varLabel = LVar + +wildPatt :: Patt +wildPatt = PV wildIdent + +type Trm = Term diff --git a/src/GF/Grammar/LookAbs.hs b/src/GF/Grammar/LookAbs.hs new file mode 100644 index 000000000..5e0994d46 --- /dev/null +++ b/src/GF/Grammar/LookAbs.hs @@ -0,0 +1,125 @@ +module LookAbs where + +import Operations +import qualified GFC as C +import Abstract +import Ident + +import Modules + +import List (nub) +import Monad + +type GFCGrammar = C.CanonGrammar + +lookupAbsDef :: GFCGrammar -> Ident -> Ident -> Err (Maybe Term) +lookupAbsDef gr m c = do + mi <- lookupModule gr m + case mi of + ModMod mo -> do + info <- lookupInfo mo c + case info of + C.AbsFun _ t -> return $ return t + C.AnyInd _ n -> lookupAbsDef gr n c + _ -> return Nothing + _ -> Bad $ prt m +++ "is not an abstract module" + +lookupFunType :: GFCGrammar -> Ident -> Ident -> Err Type +lookupFunType gr m c = do + mi <- lookupModule gr m + case mi of + ModMod mo -> do + info <- lookupInfo mo c + case info of + C.AbsFun t _ -> return t + C.AnyInd _ n -> lookupFunType gr n c + _ -> prtBad "cannot find type of" c + _ -> Bad $ prt m +++ "is not an abstract module" + +lookupCatContext :: GFCGrammar -> Ident -> Ident -> Err Context +lookupCatContext gr m c = do + mi <- lookupModule gr m + case mi of + ModMod mo -> do + info <- lookupInfo mo c + case info of + C.AbsCat co _ -> return co + C.AnyInd _ n -> lookupCatContext gr n c + _ -> prtBad "unknown category" c + _ -> Bad $ prt m +++ "is not an abstract module" + +---- should be revised (20/9/2003) +isPrimitiveFun :: GFCGrammar -> Fun -> Bool +isPrimitiveFun gr (m,c) = case lookupAbsDef gr m c of + Ok (Just (Eqs [])) -> True -- is canonical + Ok (Just _) -> False -- has defining clauses + _ -> True -- has no definition + + +-- looking up refinement terms + +lookupRef :: GFCGrammar -> Binds -> Term -> Err Val +lookupRef gr binds at = case at of + Q m f -> lookupFunType gr m f >>= return . vClos + Vr i -> maybeErr ("unknown variable" +++ prt at) $ lookup i binds + _ -> prtBad "cannot refine with complex term" at --- + +refsForType :: (Val -> Type -> Bool) -> GFCGrammar -> Binds -> Val -> [(Term,Val)] +refsForType compat gr binds val = + [(vr i, t) | (i,t) <- binds, Ok ty <- [val2exp t], compat val ty] ++ + [(qq f, vClos t) | (f,t) <- funsForType compat gr val] + + +funRulesOf :: GFCGrammar -> [(Fun,Type)] +funRulesOf gr = +---- funRulesForLiterals ++ + [((i,f),typ) | (i, ModMod m) <- modules gr, + mtype m == MTAbstract, + (f, C.AbsFun typ _) <- tree2list (jments m)] + +allCatsOf :: GFCGrammar -> [(Cat,Context)] +allCatsOf gr = + [((i,c),cont) | (i, ModMod m) <- modules gr, + isModAbs m, + (c, C.AbsCat cont _) <- tree2list (jments m)] + +funsForType :: (Val -> Type -> Bool) -> GFCGrammar -> Val -> [(Fun,Type)] +funsForType compat gr val = [(fun,typ) | (fun,typ) <- funRulesOf gr, + compat val typ] + +funsOnType :: (Val -> Type -> Bool) -> GFCGrammar -> Val -> [((Fun,Int),Type)] +funsOnType compat gr = funsOnTypeFs compat (funRulesOf gr) + +funsOnTypeFs :: (Val -> Type -> Bool) -> [(Fun,Type)] -> Val -> [((Fun,Int),Type)] +funsOnTypeFs compat fs val = [((fun,i),typ) | + (fun,typ) <- fs, + Ok (args,_,_) <- [typeForm typ], + (i,arg) <- zip [0..] (map snd args), + compat val arg] + + +-- this is needed at compile time + +lookupFunTypeSrc :: Grammar -> Ident -> Ident -> Err Type +lookupFunTypeSrc gr m c = do + mi <- lookupModule gr m + case mi of + ModMod mo -> do + info <- lookupInfo mo c + case info of + AbsFun (Yes t) _ -> return t + AnyInd _ n -> lookupFunTypeSrc gr n c + _ -> prtBad "cannot find type of" c + _ -> Bad $ prt m +++ "is not an abstract module" + +lookupCatContextSrc :: Grammar -> Ident -> Ident -> Err Context +lookupCatContextSrc gr m c = do + mi <- lookupModule gr m + case mi of + ModMod mo -> do + info <- lookupInfo mo c + case info of + AbsCat (Yes co) _ -> return co + AnyInd _ n -> lookupCatContextSrc gr n c + _ -> prtBad "unknown category" c + _ -> Bad $ prt m +++ "is not an abstract module" diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs new file mode 100644 index 000000000..b8afbc21e --- /dev/null +++ b/src/GF/Grammar/Lookup.hs @@ -0,0 +1,393 @@ +module Lookup where + +import Operations +import Abstract +import Modules + +import List (nub) +import Monad + +-- lookup in resource and concrete in compiling; for abstract, use Look + +lookupResDef :: SourceGrammar -> Ident -> Ident -> Err Term +lookupResDef gr m c = do + mi <- lookupModule gr m + case mi of + ModMod mo -> do + info <- lookupInfo mo c + case info of + ResOper _ (Yes t) -> return $ qualifAnnot m t + AnyInd _ n -> lookupResDef gr n c + ResParam _ -> return $ QC m c + ResValue _ -> return $ QC m c + _ -> Bad $ prt c +++ "is not defined in resource" +++ prt m + _ -> Bad $ prt m +++ "is not a resource" + +lookupResType :: SourceGrammar -> Ident -> Ident -> Err Type +lookupResType gr m c = do + mi <- lookupModule gr m + case mi of + ModMod mo -> do + info <- lookupInfo mo c + case info of + ResOper (Yes t) _ -> return $ qualifAnnot m t + AnyInd _ n -> lookupResType gr n c + ResParam _ -> return $ typePType + ResValue (Yes t) -> return $ qualifAnnotPar m t + _ -> Bad $ prt c +++ "has no type defined in resource" +++ prt m + _ -> Bad $ prt m +++ "is not a resource" + +lookupParams :: SourceGrammar -> Ident -> Ident -> Err [Param] +lookupParams gr m c = do + mi <- lookupModule gr m + case mi of + ModMod mo -> do + info <- lookupInfo mo c + case info of + ResParam (Yes ps) -> return ps + AnyInd _ n -> lookupParams gr n c + _ -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m + _ -> Bad $ prt m +++ "is not a resource" + +lookupParamValues :: SourceGrammar -> Ident -> Ident -> Err [Term] +lookupParamValues gr m c = do + ps <- lookupParams gr m c + liftM concat $ mapM mkPar ps + where + mkPar (f,co) = do + vs <- liftM combinations $ mapM (\ (_,ty) -> allParamValues gr ty) co + return $ map (mkApp (QC m f)) vs + +lookupFirstTag :: SourceGrammar -> Ident -> Ident -> Err Term +lookupFirstTag gr m c = do + vs <- lookupParamValues gr m c + case vs of + v:_ -> return v + _ -> prtBad "no parameter values given to type" c + +allParamValues :: SourceGrammar -> Type -> Err [Term] +allParamValues cnc ptyp = case ptyp of + QC p c -> lookupParamValues cnc p c + RecType r -> do + let (ls,tys) = unzip r + tss <- mapM allPV tys + return [R (zipAssign ls ts) | ts <- combinations tss] + _ -> prtBad "cannot find parameter values for" ptyp + where + allPV = allParamValues cnc + +qualifAnnot :: Ident -> Term -> Term +qualifAnnot _ = id +-- Using this we wouldn't have to annotate constants defined in a module itself. +-- But things are simpler if we do (cf. Zinc). +-- Change Rename.self2status to change this behaviour. + +-- we need this for lookup in ResVal +qualifAnnotPar m t = case t of + Cn c -> Q m c + Con c -> QC m c + _ -> composSafeOp (qualifAnnotPar m) t + + +lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type +lookupLincat gr m c = do + mi <- lookupModule gr m + case mi of + ModMod mo -> do + info <- lookupInfo mo c + case info of + CncCat (Yes t) _ _ -> return t + AnyInd _ n -> lookupLincat gr n c + _ -> Bad $ prt c +++ "has no linearization type in" +++ prt m + _ -> Bad $ prt m +++ "is not concrete" + + + +{- +-- the type of oper may have to be inferred at TC, so it may be junk before it + +lookupResIdent :: Ident -> [(Ident, SourceRes)] -> Err (Term,Type) +lookupResIdent c ms = case lookupWhich ms c of + Ok (i,info) -> case info of + ResOper (Yes t) _ -> return (Q i c, t) + ResOper _ _ -> return (Q i c, undefined) ---- + ResParam _ -> return (Q i c, typePType) + ResValue (Yes t) -> return (QC i c, t) + _ -> Bad $ "not found in resource" +++ prt c + +-- NB we only have to look up cnc in canonical! + +-- you may want to strip the qualification if the module is the current one + +stripMod :: Ident -> Term -> Term +stripMod m t = case t of + Q n c | n==m -> Cn c + QC n c | n==m -> Con c + _ -> t + +-- what you want may be a pattern and not a term. Then use Macros.term2patt + + + + +-- an auxiliary for making ordered search through a list of modules + +lookups :: Ord i => (i -> m -> Err (Perhaps a m)) -> i -> [m] -> Err (Perhaps a m) +lookups look c [] = Bad "not found in any module" +lookups look c (m:ms) = case look c m of + Ok (Yes v) -> return $ Yes v + Ok (May m') -> look c m' + _ -> lookups look c ms + + +lookupAbstract :: AbstractST -> Ident -> Err AbsInfo +lookupAbstract g i = errIn ("not found in abstract" +++ prt i) $ lookupTree prt i g + +lookupFunsToCat :: AbstractST -> Ident -> Err [Fun] +lookupFunsToCat g c = errIn ("looking up functions to category" +++ prt c) $ do + info <- lookupAbstract g c + case info of + AbsCat _ _ fs _ -> return fs + _ -> prtBad "not category" c + +allFunsWithValCat ab = [(f,c) | (c, AbsCat _ _ fs _) <- abstr2list ab, f <- fs] + +allDefs ab = [(f,d) | (f,AbsFun _ (Just d)) <- abstr2list ab] + +lookupCatContext :: AbstractST -> Ident -> Err Context +lookupCatContext g c = errIn "context of category" $ do + info <- lookupAbstract g c + case info of + AbsCat c _ _ _ -> return c + _ -> prtBad "not category" c + +lookupFunType :: AbstractST -> Ident -> Err Term +lookupFunType g c = errIn "looking up type of function" $ case c of + IL s -> lookupLiteral s >>= return . fst + _ -> do + info <- lookupAbstract g c + case info of + AbsFun t _ -> return t + AbsType t -> return typeType + _ -> prtBad "not function" c + +lookupFunArity :: AbstractST -> Ident -> Err Int +lookupFunArity g c = do + typ <- lookupFunType g c + ctx <- contextOfType typ + return $ length ctx + +lookupAbsDef :: AbstractST -> Ident -> Err (Maybe Term) +lookupAbsDef g c = errIn "looking up definition in abstract syntax" $ do + info <- lookupAbstract g c + case info of + AbsFun _ t -> return t + AbsType t -> return $ Just t + _ -> return $ Nothing -- constant found and accepted as primitive + + +allCats :: AbstractST -> [Ident] +allCats abstr = [c | (c, AbsCat _ _ _ _) <- abstr2list abstr] + +allIndepCats :: AbstractST -> [Ident] +allIndepCats abstr = [c | (c, AbsCat [] _ _ _) <- abstr2list abstr] + +lookupConcrete :: ConcreteST -> Ident -> Err CncInfo +lookupConcrete g i = errIn ("not found in concrete" +++ prt i) $ lookupTree prt i g + +lookupPackage :: ConcreteST -> Ident -> Err ([Ident], ConcreteST) +lookupPackage g p = do + info <- lookupConcrete g p + case info of + CncPackage ps ins -> return (ps,ins) + _ -> prtBad "not package" p + +lookupInPackage :: ConcreteST -> (Ident,Ident) -> Err CncInfo +lookupInPackage = lookupLift (flip (lookupTree prt)) + +lookupInAll :: [BinTree (Ident,b)] -> Ident -> Err b +lookupInAll = lookInAll (flip (lookupTree prt)) + +lookInAll :: (BinTree (Ident,c) -> Ident -> Err b) -> + [BinTree (Ident,c)] -> Ident -> Err b +lookInAll look ts c = case ts of + t : ts' -> err (const $ lookInAll look ts' c) return $ look t c + [] -> prtBad "not found in any package" c + +lookupLift :: (ConcreteST -> Ident -> Err b) -> + ConcreteST -> (Ident,Ident) -> Err b +lookupLift look g (p,f) = do + (ps,ins) <- lookupPackage g p + ps' <- mapM (lookupPackage g) ps + lookInAll look (ins : reverse (map snd ps')) f + +termFromPackage :: ConcreteST -> Ident -> Term -> Err Term +termFromPackage g p = termFP where + termFP t = case t of + Cn c -> return $ if isInPack c + then Q p c + else Cn c + T (TTyped t) cs -> do + t' <- termFP t + liftM (T (TTyped t')) $ mapM branchInPack cs + T i cs -> liftM (T i) $ mapM branchInPack cs + _ -> composOp termFP t + isInPack c = case lookupInPackage g (p,c) of + Ok _ -> True + _ -> False + branchInPack (q,t) = do + p' <- pattInPack q + t' <- termFP t + return (p',t') + pattInPack q = case q of + PC c ps -> do + let pc = if isInPack c + then PP p c + else PC c + ps' <- mapM pattInPack ps + return $ pc ps' + _ -> return q + +lookupCncDef :: ConcreteST -> Ident -> Err Term +lookupCncDef g t@(IL _) = return $ cn t +lookupCncDef g c = errIn "looking up defining term" $ do + info <- lookupConcrete g c + case info of + CncOper _ t _ -> return t -- the definition + CncCat t _ _ _ -> return t -- the linearization type + _ -> return $ Cn c -- constant found and accepted + +lookupOperDef :: ConcreteST -> Ident -> Err Term +lookupOperDef g c = errIn "looking up defining term of oper" $ do + info <- lookupConcrete g c + case info of + CncOper _ t _ -> return t + _ -> prtBad "not oper" c + +lookupLincat :: ConcreteST -> Ident -> Err Term +lookupLincat g c = return $ errVal defaultLinType $ do + info <- lookupConcrete g c + case info of + CncCat t _ _ _ -> return t + _ -> prtBad "not category" c + +lookupLindef :: ConcreteST -> Ident -> Err Term +lookupLindef g c = return $ errVal linDefStr $ do + info <- lookupConcrete g c + case info of + CncCat _ (Just t) _ _ -> return t + CncCat _ _ _ _ -> return $ linDefStr --- wrong: this is only sof {s:Str} + _ -> prtBad "not category" c + +lookupLinType :: ConcreteST -> Ident -> Err Type +lookupLinType g c = errIn "looking up type in concrete syntax" $ do + info <- lookupConcrete g c + case info of + CncParType _ _ _ -> return typeType + CncParam ty _ -> return ty + CncOper (Just ty) _ _ -> return ty + _ -> prtBad "no type found for" c + +lookupLin :: ConcreteST -> Ident -> Err Term +lookupLin g c = errIn "looking up linearization rule" $ do + info <- lookupConcrete g c + case info of + CncFun t _ -> return t + _ -> prtBad "not category" c + +lookupFirstTag :: ConcreteST -> Ident -> Err Term +lookupFirstTag g c = do + vs <- lookupParamValues g c + case vs of + v:_ -> return v + _ -> prtBad "empty parameter type" c + +lookupPrintname :: ConcreteST -> Ident -> Err String +lookupPrintname g c = case lookupConcrete g c of + Ok info -> case info of + CncCat _ _ _ m -> mpr m + CncFun _ m -> mpr m + CncParType _ _ m -> mpr m + CncOper _ _ m -> mpr m + _ -> Bad "no possible printname" + Bad s -> Bad s + where + mpr = maybe (Bad "no printname") (return . stringFromTerm) + +-- this variant succeeds even if there's only abstr syntax +lookupPrintname' g c = case lookupConcrete g c of + Bad _ -> return $ prt c + Ok info -> case info of + CncCat _ _ _ m -> mpr m + CncFun _ m -> mpr m + CncParType _ _ m -> mpr m + CncOper _ _ m -> mpr m + _ -> return $ prt c + where + mpr = return . maybe (prt c) stringFromTerm + +allOperDefs :: ConcreteST -> [(Ident,CncInfo)] +allOperDefs cnc = [d | d@(_, CncOper _ _ _) <- concr2list cnc] + +allPackageDefs :: ConcreteST -> [(Ident,CncInfo)] +allPackageDefs cnc = [d | d@(_, CncPackage _ _) <- concr2list cnc] + +allOperDependencies :: ConcreteST -> [(Ident,[Ident])] +allOperDependencies cnc = + [(f, filter (/= f) $ -- package name may occur in the package itself + nub (concatMap (opersInCncInfo cnc f . snd) (tree2list ds))) | + (f, CncPackage _ ds) <- allPackageDefs cnc] ++ + [(f, nub (opersInTerm cnc t)) | + (f, CncOper _ t _) <- allOperDefs cnc] + +opersInTerm :: ConcreteST -> Term -> [Ident] +opersInTerm cnc t = case t of + Cn c -> [c | isOper c] + Q p c -> [p] + _ -> collectOp ops t + where + isOper (IL _) = False + isOper c = errVal False $ lookupOperDef cnc c >>= return . const True + ops = opersInTerm cnc + +-- this is used inside packages, to find references to outside the package +opersInCncInfo :: ConcreteST -> Ident -> CncInfo -> [Ident] +opersInCncInfo cnc p i = case i of + CncOper _ t _-> filter (not . internal) $ opersInTerm cnc t + _ -> [] + where + internal c = case lookupInPackage cnc (p,c) of + Ok _ -> True + _ -> False + +opersUsedInLins :: ConcreteST -> [(Ident,[Ident])] -> [Ident] +opersUsedInLins cnc deps = do + let ops0 = concat [opersInTerm cnc t | (_, CncFun t _) <- concr2list cnc] + nub $ closure ops0 + where + closure ops = case [g | (f,fs) <- deps, elem f ops, g <- fs, notElem g ops] of + [] -> ops + ops' -> ops ++ closure ops' + -- presupposes deps are not circular: check this first! + + + + +-- create refinement and wrapping lists + + +varOrConst :: AbstractST -> Ident -> Err Term +varOrConst abstr c = case lookupFunType abstr c of + Ok _ -> return $ Cn c --- bindings cannot overshadow constants + _ -> case c of + IL _ -> return $ Cn c + _ -> return $ Vr c + +-- a rename operation for parsing term input; for abstract syntax and parameters +renameTrm :: (Ident -> Err a) -> Term -> Term +renameTrm look = ren [] where + ren vars t = case t of + Vr x | notElem x vars && isNotError (look x) -> Cn x + Abs x b -> Abs x $ ren (x:vars) b + _ -> composSafeOp (ren vars) t +-} diff --git a/src/GF/Grammar/MMacros.hs b/src/GF/Grammar/MMacros.hs new file mode 100644 index 000000000..4078221dc --- /dev/null +++ b/src/GF/Grammar/MMacros.hs @@ -0,0 +1,261 @@ +module MMacros where + +import Operations +import Zipper + +import Grammar +import PrGrammar +import Ident +import Refresh +import Values +----import GrammarST +import Macros + +import Monad + +-- some more abstractions on grammars, esp. for Edit + +nodeTree (Tr (n,_)) = n +argsTree (Tr (_,ts)) = ts + +isFocusNode (N (_,_,_,_,b)) = b +bindsNode (N (b,_,_,_,_)) = b +atomNode (N (_,a,_,_,_)) = a +valNode (N (_,_,v,_,_)) = v +constrsNode (N (_,_,_,(c,_),_)) = c +metaSubstsNode (N (_,_,_,(_,m),_)) = m + +atomTree = atomNode . nodeTree +valTree = valNode . nodeTree + +mkNode binds atom vtyp cs = N (binds,atom,vtyp,cs,False) + +type Var = Ident +type Meta = MetaSymb + +metasTree :: Tree -> [Meta] +metasTree = concatMap metasNode . scanTree where + metasNode n = [m | AtM m <- [atomNode n]] ++ map fst (metaSubstsNode n) + +varsTree :: Tree -> [(Var,Val)] +varsTree t = [(x,v) | N (_,AtV x,v,_,_) <- scanTree t] + +constrsTree :: Tree -> Constraints +constrsTree = constrsNode . nodeTree + +allConstrsTree :: Tree -> Constraints +allConstrsTree = concatMap constrsNode . scanTree + +changeConstrs :: (Constraints -> Constraints) -> TrNode -> TrNode +changeConstrs f (N (b,a,v,(c,m),x)) = N (b,a,v,(f c, m),x) + +changeMetaSubst :: (MetaSubst -> MetaSubst) -> TrNode -> TrNode +changeMetaSubst f (N (b,a,v,(c,m),x)) = N (b,a,v,(c, f m),x) + +changeAtom :: (Atom -> Atom) -> TrNode -> TrNode +changeAtom f (N (b,a,v,(c,m),x)) = N (b,f a,v,(c, m),x) + +------ on the way to Edit + +uTree :: Tree +uTree = Tr (uNode, []) -- unknown tree + +uNode :: TrNode +uNode = mkNode [] uAtom uVal ([],[]) + + +uAtom :: Atom +uAtom = AtM meta0 + +mAtom :: Atom +mAtom = AtM meta0 + +uVal :: Val +uVal = vClos uExp + +vClos :: Exp -> Val +vClos = VClos [] + +uExp :: Exp +uExp = Meta meta0 + +mExp :: Exp +mExp = Meta meta0 + +mExp0 = mExp + +meta2exp :: MetaSymb -> Exp +meta2exp = Meta + +atomC = AtC + +funAtom :: Atom -> Err Fun +funAtom a = case a of + AtC f -> return f + _ -> prtBad "not function head" a + +uBoundVar :: Ident +uBoundVar = zIdent "#h" -- used for suppressed bindings + +atomIsMeta :: Atom -> Bool +atomIsMeta atom = case atom of + AtM _ -> True + _ -> False + +getMetaAtom a = case a of + AtM m -> return m + _ -> Bad "the active node is not meta" + +cat2val :: Context -> Cat -> Val +cat2val cont cat = vClos $ mkApp (qq cat) [mkMeta i | i <- [1..length cont]] + +val2cat :: Val -> Err Cat +val2cat v = val2exp v >>= valCat + +substTerm :: [Ident] -> Substitution -> Term -> Term +substTerm ss g c = case c of + Vr x -> maybe c id $ lookup x g + App f a -> App (substTerm ss g f) (substTerm ss g a) + Abs x b -> let y = mkFreshVarX ss x in + Abs y (substTerm (y:ss) ((x, Vr y):g) b) + Prod x a b -> let y = mkFreshVarX ss x in + Prod y (substTerm ss g a) (substTerm (y:ss) ((x,Vr y):g) b) + _ -> c + +metaSubstExp :: MetaSubst -> [(Meta,Exp)] +metaSubstExp msubst = [(m, errVal (meta2exp m) (val2expSafe v)) | (m,v) <- msubst] + +-- belong here rather than to computation + +substitute :: [Var] -> Substitution -> Exp -> Err Exp +substitute v s = return . substTerm v s + +alphaConv :: [Var] -> (Var,Var) -> Exp -> Err Exp --- +alphaConv oldvars (x,x') = substitute (x:x':oldvars) [(x,Vr x')] + +alphaFresh :: [Var] -> Exp -> Err Exp +alphaFresh vs = refreshTermN $ maxVarIndex vs + +alphaFreshAll :: [Var] -> [Exp] -> Err [Exp] +alphaFreshAll vs = mapM $ alphaFresh vs -- done in a state monad + + +val2exp = val2expP False -- for display +val2expSafe = val2expP True -- for type checking + +val2expP :: Bool -> Val -> Err Exp +val2expP safe v = case v of + + VClos g@(_:_) e@(Meta _) -> if safe + then prtBad "unsafe value substitution" v + else substVal g e + VClos g e -> substVal g e + VApp f c -> liftM2 App (val2expP safe f) (val2expP safe c) + VCn c -> return $ qq c + VGen i x -> if safe + then prtBad "unsafe val2exp" v + else return $ vr $ x --- in editing, no alpha conversions presentv + where + substVal g e = mapPairsM (val2expP safe) g >>= return . (\s -> substTerm [] s e) + +isConstVal :: Val -> Bool +isConstVal v = case v of + VApp f c -> isConstVal f && isConstVal c + VCn _ -> True + VClos [] e -> null $ freeVarsExp e + _ -> False --- could be more liberal + +mkProdVal :: Binds -> Val -> Err Val --- +mkProdVal bs v = do + bs' <- mapPairsM val2exp bs + v' <- val2exp v + return $ vClos $ foldr (uncurry Prod) v' bs' + +freeVarsExp :: Exp -> [Ident] +freeVarsExp e = case e of + Vr x -> [x] + App f c -> freeVarsExp f ++ freeVarsExp c + Abs x b -> filter (/=x) (freeVarsExp b) + Prod x a b -> freeVarsExp a ++ filter (/=x) (freeVarsExp b) + _ -> [] --- thus applies to abstract syntax only + +ident2string = prIdent + +tree :: (TrNode,[Tree]) -> Tree +tree = Tr + +eqCat :: Cat -> Cat -> Bool +eqCat = (==) + +addBinds :: Binds -> Tree -> Tree +addBinds b (Tr (N (b0,at,t,c,x),ts)) = Tr (N (b ++ b0,at,t,c,x),ts) + +bodyTree :: Tree -> Tree +bodyTree (Tr (N (_,a,t,c,x),ts)) = Tr (N ([],a,t,c,x),ts) + +refreshMetas :: [Meta] -> Exp -> Exp +refreshMetas metas = fst . rms minMeta where + rms meta trm = case trm of + Meta m -> (Meta meta, nextMeta meta) + App f a -> let (f',msf) = rms meta f + (a',msa) = rms msf a + in (App f' a', msa) + Prod x a b -> + let (a',msa) = rms meta a + (b',msb) = rms msa b + in (Prod x a' b', msb) + Abs x b -> let (b',msb) = rms meta b in (Abs x b', msb) + _ -> (trm,meta) + minMeta = int2meta $ + if null metas then 0 else (maximum (map metaSymbInt metas) + 1) + +ref2exp :: [Var] -> Type -> Ref -> Err Exp +ref2exp bounds typ ref = do + cont <- contextOfType typ + xx0 <- mapM (typeSkeleton . snd) cont + let (xxs,cs) = unzip [(length hs, c) | (hs,c) <- xx0] + args = [mkAbs xs mExp | i <- xxs, let xs = mkFreshVars i bounds] + return $ mkApp ref args + -- no refreshment of metas + +type Ref = Exp -- invariant: only Con or Var + +fun2wrap :: [Var] -> ((Fun,Int),Type) -> Exp -> Err Exp +fun2wrap oldvars ((fun,i),typ) exp = do + cont <- contextOfType typ + args <- mapM mkArg (zip [0..] (map snd cont)) + return $ mkApp (qq fun) args + where + mkArg (n,c) = do + cont <- contextOfType c + let vars = mkFreshVars (length cont) oldvars + return $ mkAbs vars $ if n==i then exp else mExp + +--- + +mkJustProd cont typ = mkProd (cont,typ,[]) + +int2var :: Int -> Ident +int2var = zIdent . ('$':) . show + +meta0 :: Meta +meta0 = int2meta 0 + +termMeta0 :: Term +termMeta0 = Meta meta0 + +identVar (Vr x) = return x +identVar _ = Bad "not a variable" + + +-- light-weight rename for user interaction + +qualifTerm :: Ident -> Term -> Term +qualifTerm m = qualif [] where + qualif xs t = case t of + Abs x b -> Abs x $ qualif (x:xs) b + Prod x a b -> Prod x (qualif xs a) $ qualif (x:xs) b + Vr x | notElem x xs -> Q m x + Cn c -> Q m c + Con c -> QC m c + _ -> composSafeOp (qualif xs) t diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs new file mode 100644 index 000000000..e6906f985 --- /dev/null +++ b/src/GF/Grammar/Macros.hs @@ -0,0 +1,634 @@ +module Macros where + +import Operations +import Str +import Grammar +import Ident +import PrGrammar + +import Monad (liftM) +import Char (isDigit) + +-- AR 7/12/1999 - 9/5/2000 -- 4/6/2001 + +-- operations on terms and types not involving lookup in or reference to grammars + +firstTypeForm :: Type -> Err (Context, Type) +firstTypeForm t = case t of + Prod x a b -> do + (x', val) <- firstTypeForm b + return ((x,a):x',val) + _ -> return ([],t) + +qTypeForm :: Type -> Err (Context, Cat, [Term]) +qTypeForm t = case t of + Prod x a b -> do + (x', cat, args) <- qTypeForm b + return ((x,a):x', cat, args) + App c a -> do + (_,cat, args) <- qTypeForm c + return ([],cat,args ++ [a]) + Q m c -> + return ([],(m,c),[]) + QC m c -> + return ([],(m,c),[]) + _ -> + prtBad "no normal form of type" t + +qq :: QIdent -> Term +qq (m,c) = Q m c + +typeForm = qTypeForm ---- no need to dist any more + +typeFormCnc :: Type -> Err (Context, Type) +typeFormCnc t = case t of + Prod x a b -> do + (x', v) <- typeFormCnc b + return ((x,a):x',v) + _ -> return ([],t) + +valCat :: Type -> Err Cat +valCat typ = + do (_,cat,_) <- typeForm typ + return cat + +valType :: Type -> Err Type +valType typ = + do (_,cat,xx) <- typeForm typ --- not optimal to do in this way + return $ mkApp (qq cat) xx + +valTypeCnc :: Type -> Err Type +valTypeCnc typ = + do (_,ty) <- typeFormCnc typ + return ty + +typeRawSkeleton :: Type -> Err ([(Int,Type)],Type) +typeRawSkeleton typ = + do (cont,typ) <- typeFormCnc typ + args <- mapM (typeRawSkeleton . snd) cont + return ([(length c, v) | (c,v) <- args], typ) + +type MCat = (Ident,Ident) + +sortMCat :: String -> MCat +sortMCat s = (zIdent "_", zIdent s) + +getMCat :: Term -> Err MCat +getMCat t = case t of + Q m c -> return (m,c) + QC m c -> return (m,c) + Sort s -> return $ sortMCat s + App f _ -> getMCat f + _ -> prtBad "no qualified constant" t + +typeSkeleton :: Type -> Err ([(Int,MCat)],MCat) +typeSkeleton typ = do + (cont,val) <- typeRawSkeleton typ + cont' <- mapPairsM getMCat cont + val' <- getMCat val + return (cont',val') + +catSkeleton :: Type -> Err ([MCat],MCat) +catSkeleton typ = + do (args,val) <- typeSkeleton typ + return (map snd args, val) + +funsToAndFrom :: Type -> (MCat, [(MCat,[Int])]) +funsToAndFrom t = errVal undefined $ do --- + (cs,v) <- catSkeleton t + let cis = zip cs [0..] + return $ (v, [(c,[i | (c',i) <- cis, c' == c]) | c <- cs]) + +typeFormConcrete :: Type -> Err (Context, Type) +typeFormConcrete t = case t of + Prod x a b -> do + (x', typ) <- typeFormConcrete b + return ((x,a):x', typ) + _ -> return ([],t) + +isRecursiveType :: Type -> Bool +isRecursiveType t = errVal False $ do + (cc,c) <- catSkeleton t -- thus recursivity on Cat level + return $ any (== c) cc + + +contextOfType :: Type -> Err Context +contextOfType typ = case typ of + Prod x a b -> liftM ((x,a):) $ contextOfType b + _ -> return [] + +unComputed :: Term -> Term +unComputed t = case t of + Computed v -> unComputed v + _ -> t --- composSafeOp unComputed t + +computed = Computed + +termForm :: Term -> Err ([(Ident)], Term, [Term]) +termForm t = case t of + Abs x b -> + do (x', fun, args) <- termForm b + return (x:x', fun, args) + App c a -> + do (_,fun, args) <- termForm c + return ([],fun,args ++ [a]) + _ -> + return ([],t,[]) + +appForm :: Term -> (Term, [Term]) +appForm t = case t of + App c a -> (fun, args ++ [a]) where (fun, args) = appForm c + _ -> (t,[]) + +varsOfType :: Type -> [Ident] +varsOfType t = case t of + Prod x _ b -> x : varsOfType b + _ -> [] + +mkProdSimple :: Context -> Term -> Term +mkProdSimple c t = mkProd (c,t,[]) + +mkProd :: (Context, Term, [Term]) -> Term +mkProd ([],typ,args) = mkApp typ args +mkProd ((x,a):dd, typ, args) = Prod x a (mkProd (dd, typ, args)) + +mkTerm :: ([(Ident)], Term, [Term]) -> Term +mkTerm (xx,t,aa) = mkAbs xx (mkApp t aa) + +mkApp :: Term -> [Term] -> Term +mkApp = foldl App + +mkAbs :: [Ident] -> Term -> Term +mkAbs xx t = foldr Abs t xx + +appCons :: Ident -> [Term] -> Term +appCons = mkApp . Cn + +appc :: String -> [Term] -> Term +appc = appCons . zIdent + +mkLet :: [LocalDef] -> Term -> Term +mkLet defs t = foldr Let t defs + +isVariable (Vr _ ) = True +isVariable _ = False + +eqIdent :: Ident -> Ident -> Bool +eqIdent = (==) + +zIdent :: String -> Ident +zIdent s = identC s + +uType :: Type +uType = Cn (zIdent "UndefinedType") + +assign :: Label -> Term -> Assign +assign l t = (l,(Nothing,t)) + +assignT :: Label -> Type -> Term -> Assign +assignT l a t = (l,(Just a,t)) + +unzipR :: [Assign] -> ([Label],[Term]) +unzipR r = (ls, map snd ts) where (ls,ts) = unzip r + +mkAssign :: [(Label,Term)] -> [Assign] +mkAssign lts = [assign l t | (l,t) <- lts] + +zipAssign :: [Label] -> [Term] -> [Assign] +zipAssign ls ts = [assign l t | (l,t) <- zip ls ts] + +ident2label :: Ident -> Label +ident2label c = LIdent (prIdent c) + +label2ident :: Label -> Ident +label2ident = identC . prLabel + +prLabel :: Label -> String +prLabel = prt + +mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))] +mapAssignM f ltvs = do + let (ls,tvs) = unzip ltvs + (ts, vs) = unzip tvs + ts' <- mapM (\t -> case t of + Nothing -> return Nothing + Just y -> f y >>= return . Just) ts + vs' <- mapM f vs + return (zip ls (zip ts' vs')) + +mkRecordN :: Int -> (Int -> Label) -> [Term] -> Term +mkRecordN int lab typs = R [ assign (lab i) t | (i,t) <- zip [int..] typs] + +mkRecord :: (Int -> Label) -> [Term] -> Term +mkRecord = mkRecordN 0 + +mkRecTypeN :: Int -> (Int -> Label) -> [Type] -> Type +mkRecTypeN int lab typs = RecType [ (lab i, t) | (i,t) <- zip [int..] typs] + +mkRecType :: (Int -> Label) -> [Type] -> Type +mkRecType = mkRecTypeN 0 + +typeType = srt "Type" +typePType = srt "PType" +typeStr = srt "Str" +typeTok = srt "Tok" +typeStrs = srt "Strs" + +typeString = constPredefRes "String" +typeInt = constPredefRes "Int" + +constPredefRes s = Q (IC "Predef") (zIdent s) + +isPredefConstant t = case t of + Q (IC "Predef") _ -> True + _ -> False + +mkSelects :: Term -> [Term] -> Term +mkSelects t tt = foldl S t tt + +mkTable :: [Term] -> Term -> Term +mkTable tt t = foldr Table t tt + +mkCTable :: [Ident] -> Term -> Term +mkCTable ids v = foldr ccase v ids where + ccase x t = T TRaw [(PV x,t)] + +mkDecl :: Term -> Decl +mkDecl typ = (wildIdent, typ) + +eqStrIdent :: Ident -> Ident -> Bool +eqStrIdent = (==) + +tupleLabel i = LIdent $ "p" ++ show i +linLabel i = LIdent $ "s" ++ show i + +tuple2record :: [Term] -> [Assign] +tuple2record ts = [assign (tupleLabel i) t | (i,t) <- zip [1..] ts] + +tuple2recordType :: [Term] -> [Labelling] +tuple2recordType ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts] + +tuple2recordPatt :: [Patt] -> [(Label,Patt)] +tuple2recordPatt ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts] + +mkCases :: Ident -> Term -> Term +mkCases x t = T TRaw [(PV x, t)] + +mkWildCases :: Term -> Term +mkWildCases = mkCases wildIdent + +mkFunType :: [Type] -> Type -> Type +mkFunType tt t = mkProd ([(wildIdent, ty) | ty <- tt], t, []) -- nondep prod + +plusRecType :: Type -> Type -> Err Type +plusRecType t1 t2 = case (unComputed t1, unComputed t2) of + (RecType r1, RecType r2) -> return (RecType (r1 ++ r2)) + _ -> Bad ("cannot add record types" +++ prt t1 +++ "and" +++ prt t2) + +plusRecord :: Term -> Term -> Err Term +plusRecord t1 t2 = + case (t1,t2) of + (R r1, R r2 ) -> return (R (r1 ++ r2)) + (_, FV rs) -> mapM (plusRecord t1) rs >>= return . FV + (FV rs,_ ) -> mapM (`plusRecord` t2) rs >>= return . FV + _ -> Bad ("cannot add records" +++ prt t1 +++ "and" +++ prt t2) + +-- default linearization type + +defLinType = RecType [(LIdent "s", typeStr)] + +-- refreshing variables + +varX :: Int -> Ident +varX i = identV (i,"x") + +mkFreshVar :: [Ident] -> Ident +mkFreshVar olds = varX (maxVarIndex olds + 1) + +-- trying to preserve a given symbol +mkFreshVarX :: [Ident] -> Ident -> Ident +mkFreshVarX olds x = if (elem x olds) then (varX (maxVarIndex olds + 1)) else x + +maxVarIndex :: [Ident] -> Int +maxVarIndex = maximum . ((-1):) . map varIndex + +mkFreshVars :: Int -> [Ident] -> [Ident] +mkFreshVars n olds = [varX (maxVarIndex olds + i) | i <- [1..n]] + +--- quick hack for refining with var in editor +freshAsTerm :: String -> Term +freshAsTerm s = Vr (varX (readIntArg s)) + +-- create a terminal for concrete syntax +string2term :: String -> Term +string2term = ccK + +ccK = K +ccC = C + +-- create a terminal from identifier +ident2terminal :: Ident -> Term +ident2terminal = ccK . prIdent + +-- create a constant +string2CnTrm :: String -> Term +string2CnTrm = Cn . zIdent + +symbolOfIdent :: Ident -> String +symbolOfIdent = prIdent + +symid = symbolOfIdent + +vr = Vr +cn = Cn +srt = Sort +meta = Meta +cnIC = cn . IC + +justIdentOf (Vr x) = Just x +justIdentOf (Cn x) = Just x +justIdentOf _ = Nothing + +isMeta (Meta _) = True +isMeta _ = False +mkMeta = Meta . MetaSymb + +nextMeta :: MetaSymb -> MetaSymb +nextMeta = int2meta . succ . metaSymbInt + +int2meta = MetaSymb + +metaSymbInt :: MetaSymb -> Int +metaSymbInt (MetaSymb k) = k + +freshMeta :: [MetaSymb] -> MetaSymb +freshMeta ms = MetaSymb (minimum [n | n <- [0..length ms], + notElem n (map metaSymbInt ms)]) + +mkFreshMetasInTrm :: [MetaSymb] -> Trm -> Trm +mkFreshMetasInTrm metas = fst . rms minMeta where + rms meta trm = case trm of + Meta m -> (Meta (MetaSymb meta), meta + 1) + App f a -> let (f',msf) = rms meta f + (a',msa) = rms msf a + in (App f' a', msa) + Prod x a b -> + let (a',msa) = rms meta a + (b',msb) = rms msa b + in (Prod x a' b', msb) + Abs x b -> let (b',msb) = rms meta b in (Abs x b', msb) + _ -> (trm,meta) + minMeta = if null metas then 0 else (maximum (map metaSymbInt metas) + 1) + +-- decides that a term has no metavariables +isCompleteTerm :: Term -> Bool +isCompleteTerm t = case t of + Meta _ -> False + Abs _ b -> isCompleteTerm b + App f a -> isCompleteTerm f && isCompleteTerm a + _ -> True + +linTypeStr :: Type +linTypeStr = mkRecType linLabel [typeStr] -- default lintype {s :: Str} + +linAsStr :: String -> Term +linAsStr s = mkRecord linLabel [K s] -- default linearization {s = s} + +linDefStr :: Term +linDefStr = Abs s (R [assign (linLabel 0) (Vr s)]) where s = zIdent "s" + +term2patt :: Term -> Err Patt +term2patt trm = case termForm trm of + Ok ([], Vr x, []) -> return (PV x) + Ok ([], Con c, aa) -> do + aa' <- mapM term2patt aa + return (PC c aa') + Ok ([], QC p c, aa) -> do + aa' <- mapM term2patt aa + return (PP p c aa') + Ok ([], R r, []) -> do + let (ll,aa) = unzipR r + aa' <- mapM term2patt aa + return (PR (zip ll aa')) + Ok ([],EInt i,[]) -> return $ PInt i + Ok ([],K s, []) -> return $ PString s + _ -> prtBad "no pattern corresponds to term" trm + +patt2term :: Patt -> Term +patt2term pt = case pt of + PV x -> Vr x + PW -> Vr wildIdent --- not parsable, should not occur + PC c pp -> mkApp (Con c) (map patt2term pp) + PP p c pp -> mkApp (QC p c) (map patt2term pp) + PR r -> R [assign l (patt2term p) | (l,p) <- r] + PT _ p -> patt2term p + PInt i -> EInt i + PString s -> K s + +-- to gather s-fields; assumes term in normal form, preserves label +allLinFields :: Term -> Err [[(Label,Term)]] +allLinFields trm = case unComputed trm of +---- R rs -> return [[(l,t) | (l,(Just ty,t)) <- rs, isStrType ty]] -- good + R rs -> return [[(l,t) | (l,(_,t)) <- rs, isLinLabel l]] ---- bad + FV ts -> do + lts <- mapM allLinFields ts + return $ concat lts + _ -> prtBad "fields can only be sought in a record not in" trm + +---- deprecated +isLinLabel l = case l of + LIdent ('s':cs) | all isDigit cs -> True + _ -> False + +-- to gather ultimate cases in a table; preserves pattern list +allCaseValues :: Term -> [([Patt],Term)] +allCaseValues trm = case unComputed trm of + T _ cs -> [(p:ps, t) | (p,t0) <- cs, (ps,t) <- allCaseValues t0] + _ -> [([],trm)] + +-- to gather all linearizations; assumes normal form, preserves label and args +allLinValues :: Term -> Err [[(Label,[([Patt],Term)])]] +allLinValues trm = do + lts <- allLinFields trm + mapM (mapPairsM (return . allCaseValues)) lts + +-- to mark str parts of fields in a record f by a function f +markLinFields :: (Term -> Term) -> Term -> Term +markLinFields f t = case t of + R r -> R $ map mkField r + _ -> t + where + mkField (l,(_,t)) = if (isLinLabel l) then (assign l (mkTbl t)) else (assign l t) + mkTbl t = case t of + T i cs -> T i [(p, mkTbl v) | (p,v) <- cs] + _ -> f t + +-- to get a string from a term that represents a sequence of terminals +strsFromTerm :: Term -> Err [Str] +strsFromTerm t = case unComputed t of + K s -> return [str s] + C s t -> do + s' <- strsFromTerm s + t' <- strsFromTerm t + return [plusStr x y | x <- s', y <- t'] + Glue s t -> do + s' <- strsFromTerm s + t' <- strsFromTerm t + return [glueStr x y | x <- s', y <- t'] + Alts (d,vs) -> do + d0 <- strsFromTerm d + v0 <- mapM (strsFromTerm . fst) vs + c0 <- mapM (strsFromTerm . snd) vs + let vs' = zip v0 c0 + return [strTok (str2strings def) vars | + def <- d0, + vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | + vv <- combinations v0] + ] + FV ts -> mapM strsFromTerm ts >>= return . concat + Strs ts -> mapM strsFromTerm ts >>= return . concat + Ready ss -> return [ss] + Alias _ _ d -> strsFromTerm d --- should not be needed... + _ -> prtBad "cannot get Str from term" t + +-- to print an Str-denoting term as a string; if the term is of wrong type, the error msg +stringFromTerm :: Term -> String +stringFromTerm = err id (ifNull "" (sstr . head)) . strsFromTerm + + +-- 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 + +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) + 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') + 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') + Alias c ty d -> + do v <- co d + ty' <- co ty + return $ Alias c ty' v + 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 + Strs tt -> mapM co tt >>= return . Strs + _ -> return trm -- covers K, Vr, Cn, Sort + +getTableType :: TInfo -> Err Type +getTableType i = case i of + TTyped ty -> return ty + TComp ty -> return ty + TWild ty -> return ty + _ -> Bad "the table is untyped" + +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 + +collectOp :: (Term -> [a]) -> Term -> [a] +collectOp co trm = case trm of + App c a -> co c ++ co a + Abs _ b -> co b + Prod _ a b -> co a ++ co b + S c a -> co c ++ co a + Table a c -> co a ++ co c + ExtR a c -> co a ++ co c + R r -> concatMap (\ (_,(mt,a)) -> maybe [] co mt ++ co a) r + RecType r -> concatMap (co . snd) r + P t i -> co t + T _ cc -> concatMap (co . snd) cc -- not from patterns --- nor from type annot + Let (x,(mt,a)) b -> maybe [] co mt ++ co a ++ co b + C s1 s2 -> co s1 ++ co s2 + Glue s1 s2 -> co s1 ++ co s2 + Alts (t,aa) -> let (x,y) = unzip aa in co t ++ concatMap co (x ++ y) + FV ts -> concatMap co ts + Strs tt -> concatMap co tt + _ -> [] -- covers K, Vr, Cn, Sort, Ready + +-- to find the word items in a term + +wordsInTerm :: Term -> [String] +wordsInTerm trm = filter (not . null) $ case trm of + K s -> [s] + S c _ -> wo c + Alts (t,aa) -> wo t ++ concatMap (wo . fst) aa + Ready s -> allItems s + _ -> collectOp wo trm + where wo = wordsInTerm + +noExist = FV [] + +defaultLinType :: Type +defaultLinType = mkRecType linLabel [typeStr] + +metaTerms :: [Term] +metaTerms = map (Meta . MetaSymb) [0..] + +-- from GF1, 20/9/2003 + +isInOneType :: Type -> Bool +isInOneType t = case t of + Prod _ a b -> a == b + _ -> False + diff --git a/src/GF/Grammar/PatternMatch.hs b/src/GF/Grammar/PatternMatch.hs new file mode 100644 index 000000000..2ca8b21de --- /dev/null +++ b/src/GF/Grammar/PatternMatch.hs @@ -0,0 +1,98 @@ +module PatternMatch where + +import Operations +import Grammar +import Ident +import Macros +import PrGrammar + +import List +import Monad + +-- pattern matching for both concrete and abstract syntax. AR -- 16/6/2003 + + +matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution) +matchPattern pts term = + errIn ("trying patterns" +++ unwords (intersperse "," (map (prt . fst) pts))) $ + findMatch [([p],t) | (p,t) <- pts] [term] + +testOvershadow :: [Patt] -> [Term] -> Err [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 :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution) +findMatch cases terms = case cases of + [] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms)) + (patts,_):_ | length patts /= length terms -> + Bad ("wrong number of args for patterns :" +++ + unwords (map prt patts) +++ "cannot take" +++ unwords (map prt 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 + (PV IW, _) | isInConstantForm t -> return [] -- optimization with wildcard + (PV x, _) | isInConstantForm t -> return [(x,t)] + (PString s, ([],K i,[])) | s==i -> return [] + (PInt s, ([],EInt i,[])) | s==i -> return [] + (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 && 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' + (_, ([],Alias _ _ d,[])) -> tryMatch (p,d) + _ -> prtBad "no match in case expr for" t + +isInConstantForm :: Term -> Bool +isInConstantForm trm = case trm of + Cn _ -> True + Con _ -> True + Q _ _ -> True + QC _ _ -> True + Abs _ _ -> True + App c a -> isInConstantForm c && isInConstantForm a + R r -> all (isInConstantForm . snd . snd) r + Alias _ _ t -> isInConstantForm t + _ -> False ---- isInArgVarForm trm + +varsOfPatt :: Patt -> [Ident] +varsOfPatt p = case p of + PV x -> [x | not (isWildIdent 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/GF/Grammar/PrGrammar.hs b/src/GF/Grammar/PrGrammar.hs new file mode 100644 index 000000000..03197ea02 --- /dev/null +++ b/src/GF/Grammar/PrGrammar.hs @@ -0,0 +1,189 @@ +module PrGrammar where + +import Operations +import Zipper +import Grammar +import Modules +import qualified PrintGF as P +import qualified PrintGFC as C +import qualified AbsGFC as A +import Values +import GrammarToSource +import Ident +import Str + +import List (intersperse) + +-- AR 7/12/1999 - 1/4/2000 - 10/5/2003 + +-- printing and prettyprinting class + +class Print a where + prt :: a -> String + prt2 :: a -> String -- printing with parentheses, if needed + prpr :: a -> [String] -- pretty printing + prt_ :: a -> String -- printing without ident qualifications + prt2 = prt + prt_ = prt + prpr = return . prt + +-- to show terms etc in error messages +prtBad :: Print a => String -> a -> Err b +prtBad s a = Bad (s +++ prt a) + +prGrammar = P.printTree . trGrammar +prModule = P.printTree . trModule + +instance Print Term where + prt = P.printTree . trt + prt_ = prExp + +instance Print Ident where + prt = P.printTree . tri + +instance Print Patt where + prt = P.printTree . trp + +instance Print Label where + prt = P.printTree . trLabel + +instance Print MetaSymb where + prt (MetaSymb i) = "?" ++ show i + +prParam :: Param -> String +prParam (c,co) = prt c +++ prContext co + +prContext :: Context -> String +prContext co = unwords $ map prParenth [prt x +++ ":" +++ prt t | (x,t) <- co] + +-- some GFC notions + +instance Print A.Exp where prt = C.printTree +instance Print A.Term where prt = C.printTree +instance Print A.Patt where prt = C.printTree +instance Print A.Case where prt = C.printTree +instance Print A.Atom where prt = C.printTree +instance Print A.CIdent where prt = C.printTree +instance Print A.CType where prt = C.printTree +instance Print A.Label where prt = C.printTree +instance Print A.Module where prt = C.printTree +instance Print A.Sort where prt = C.printTree + + +-- printing values and trees in editing + +instance Print a => Print (Tr a) where + prt (Tr (n, trees)) = prt n +++ unwords (map prt2 trees) + prt2 t@(Tr (_,args)) = if null args then prt t else prParenth (prt t) + +-- we cannot define the method prt_ in this way +prt_Tree :: Tree -> String +prt_Tree = prt_ . tree2exp + +instance Print TrNode where + prt (N (bi,at,vt,(cs,ms),_)) = + prBinds bi ++ + prt at +++ ":" +++ prt vt + +++ prConstraints cs +++ prMetaSubst ms + +prMarkedTree :: Tr (TrNode,Bool) -> [String] +prMarkedTree = prf 1 where + prf ind t@(Tr (node, trees)) = + prNode ind node : concatMap (prf (ind + 2)) trees + prNode ind node = case node of + (n, False) -> indent ind (prt n) + (n, _) -> '*' : indent (ind - 1) (prt n) + +prTree :: Tree -> [String] +prTree = prMarkedTree . mapTr (\n -> (n,False)) + +--- to get rig of brackets +prRefinement :: Term -> String +prRefinement t = case t of + Q m c -> prQIdent (m,c) + QC m c -> prQIdent (m,c) + _ -> prt t + +-- a pretty-printer for parsable output +tree2string = unlines . prprTree + +prprTree :: Tree -> [String] +prprTree = prf False where + prf par t@(Tr (node, trees)) = + parIf par (prn node : concat [prf (ifPar t) t | t <- trees]) + prn (N (bi,at,_,_,_)) = prb bi ++ prt at + prb [] = "" + prb bi = "\\" ++ concat (intersperse "," (map (prt . fst) bi)) ++ " -> " + parIf par (s:ss) = map (indent 2) $ + if par + then ('(':s) : ss ++ [")"] + else s:ss + ifPar (Tr (N ([],_,_,_,_), [])) = False + ifPar _ = True + + +-- auxiliaries + +prConstraints :: Constraints -> String +prConstraints = concat . prConstrs + +prMetaSubst :: MetaSubst -> String +prMetaSubst = concat . prMSubst + +prEnv :: Env -> String +---- prEnv [] = prCurly "" ---- for debugging +prEnv e = concatMap (\ (x,t) -> prCurly (prt x ++ ":=" ++ prt t)) e + +prConstrs :: Constraints -> [String] +prConstrs = map (\ (v,w) -> prCurly (prt v ++ "<>" ++ prt w)) + +prMSubst :: MetaSubst -> [String] +prMSubst = map (\ (m,e) -> prCurly ("?" ++ show m ++ "=" ++ prt e)) + +prBinds bi = if null bi + then [] + else "\\" ++ concat (intersperse "," (map prValDecl bi)) +++ "-> " + where + prValDecl (x,t) = prParenth (prt x +++ ":" +++ prt t) + +instance Print Val where + prt (VGen i x) = prt x ---- ++ "-$" ++ show i ---- latter part for debugging + prt (VApp u v) = prt u +++ prv1 v + prt (VCn mc) = prQIdent mc + prt (VClos env e) = case e of + Meta _ -> prt e ++ prEnv env + _ -> prt e ---- ++ prEnv env ---- for debugging + +prv1 v = case v of + VApp _ _ -> prParenth $ prt v + VClos _ _ -> prParenth $ prt v + _ -> prt v + +instance Print Atom where + prt (AtC f) = prQIdent f + prt (AtM i) = prt i + prt (AtV i) = prt i + prt (AtL s) = s + prt (AtI i) = show i + +prQIdent :: QIdent -> String +prQIdent (m,f) = prt m ++ "." ++ prt f + +-- print terms without qualifications + +prExp :: Term -> String +prExp e = case e of + App f a -> pr1 f +++ pr2 a + Abs x b -> "\\" ++ prt x +++ "->" +++ prExp b + Prod x a b -> "(\\" ++ prt x +++ ":" +++ prExp a ++ ")" +++ "->" +++ prExp b + Q _ c -> prt c + QC _ c -> prt c + _ -> prt e + where + pr1 e = case e of + Abs _ _ -> prParenth $ prExp e + Prod _ _ _ -> prParenth $ prExp e + _ -> prExp e + pr2 e = case e of + App _ _ -> prParenth $ prExp e + _ -> pr1 e diff --git a/src/GF/Grammar/Refresh.hs b/src/GF/Grammar/Refresh.hs new file mode 100644 index 000000000..8b33444d0 --- /dev/null +++ b/src/GF/Grammar/Refresh.hs @@ -0,0 +1,105 @@ +module Refresh where + +import Operations +import Grammar +import Ident +import Modules +import Macros +import Monad + +refreshTerm :: Term -> Err Term +refreshTerm = refreshTermN 0 + +refreshTermN :: Int -> Term -> Err Term +refreshTermN i e = liftM snd $ refreshTermKN i e + +refreshTermKN :: Int -> Term -> Err (Int,Term) +refreshTermKN i e = liftM (\ (t,(_,i)) -> (i,t)) $ + appSTM (refresh e) (initIdStateN i) + +refresh :: Term -> STM IdState Term +refresh e = case e of + + Vr x -> liftM Vr (lookVar x) + Abs x b -> liftM2 Abs (refVarPlus x) (refresh b) + + Prod x a b -> do + a' <- refresh a + x' <- refVar x + b' <- refresh b + return $ Prod x' a' b' + + Let (x,(mt,a)) b -> do + a' <- refresh a + mt' <- case mt of + Just t -> refresh t >>= (return . Just) + _ -> return mt + x' <- refVar x + b' <- refresh b + return (Let (x',(mt',a')) b') + + R r -> liftM R $ refreshRecord r + + ExtR r s -> liftM2 ExtR (refresh r) (refresh s) + + T i cc -> liftM2 T (refreshTInfo i) (mapM refreshCase cc) + + _ -> composOp refresh e + +refreshCase :: (Patt,Term) -> STM IdState (Patt,Term) +refreshCase (p,t) = liftM2 (,) (refreshPatt p) (refresh t) + +refreshPatt p = case p of + PV x -> liftM PV (refVar x) + PC c ps -> liftM (PC c) (mapM refreshPatt ps) + PP q c ps -> liftM (PP q c) (mapM refreshPatt ps) + PR r -> liftM PR (mapPairsM refreshPatt r) + PT t p' -> liftM2 PT (refresh t) (refreshPatt p') + _ -> return p + +refreshRecord r = case r of + [] -> return r + (x,(mt,a)):b -> do + a' <- refresh a + mt' <- case mt of + Just t -> refresh t >>= (return . Just) + _ -> return mt + b' <- refreshRecord b + return $ (x,(mt',a')) : b' + +refreshTInfo i = case i of + TTyped t -> liftM TTyped $ refresh t + TComp t -> liftM TComp $ refresh t + TWild t -> liftM TWild $ refresh t + _ -> return i + +-- for abstract syntax + +refreshEquation :: Equation -> Err ([Patt],Term) +refreshEquation pst = err Bad (return . fst) (appSTM (refr pst) initIdState) where + refr (ps,t) = liftM2 (,) (mapM refreshPatt ps) (refresh t) + +-- for concrete and resource in grammar, before optimizing + +refreshGrammar :: SourceGrammar -> Err SourceGrammar +refreshGrammar = liftM (MGrammar . snd) . foldM refreshModule (0,[]) . modules + +refreshModule :: (Int,[SourceModule]) -> SourceModule -> Err (Int,[SourceModule]) +refreshModule (k,ms) mi@(i,m) = case m of + ModMod mo@(Module mt fs me ops js) | (isModCnc mo || mt == MTResource) -> do + (k',js') <- foldM refreshRes (k,[]) $ tree2list js + return (k', (i, ModMod(Module mt fs me ops (buildTree js'))) : ms) + _ -> return (k, mi:ms) + where + refreshRes (k,cs) ci@(c,info) = case info of + ResOper ptyp (Yes trm) -> do ---- refresh ptyp + (k',trm') <- refreshTermKN k trm + return $ (k', (c, ResOper ptyp (Yes trm')):cs) + CncCat mt (Yes trm) pn -> do ---- refresh mt, pn + (k',trm') <- refreshTermKN k trm + return $ (k', (c, CncCat mt (Yes trm') pn):cs) + CncFun mt (Yes trm) pn -> do ---- refresh pn + (k',trm') <- refreshTermKN k trm + return $ (k', (c, CncFun mt (Yes trm') pn):cs) + _ -> return (k, ci:cs) + diff --git a/src/GF/Grammar/ReservedWords.hs b/src/GF/Grammar/ReservedWords.hs new file mode 100644 index 000000000..43738989f --- /dev/null +++ b/src/GF/Grammar/ReservedWords.hs @@ -0,0 +1,32 @@ +module ReservedWords (isResWord, isResWordGFC) where + +import List + +-- reserved words of GF. (c) Aarne Ranta 19/3/2002 under Gnu GPL +-- modified by Markus Forsberg 9/4. +-- modified by AR 12/6/2003 for GF2 and GFC + + +isResWord :: String -> Bool +isResWord s = isInTree s resWordTree + +resWordTree :: BTree +resWordTree = +-- mapTree fst $ sorted2tree $ flip zip (repeat ()) $ sort allReservedWords + B "let" (B "concrete" (B "Tok" (B "Str" (B "PType" (B "Lin" N N) N) (B "Strs" N N)) (B "case" (B "abstract" (B "Type" N N) N) (B "cat" N N))) (B "fun" (B "flags" (B "def" (B "data" N N) N) (B "fn" N N)) (B "in" (B "grammar" N N) (B "include" N N)))) (B "pattern" (B "of" (B "lindef" (B "lincat" (B "lin" N N) N) (B "lintype" N N)) (B "out" (B "oper" (B "open" N N) N) (B "param" N N))) (B "strs" (B "resource" (B "printname" (B "pre" N N) N) (B "reuse" N N)) (B "transfer" (B "table" N N) (B "variants" N N)))) + + +isResWordGFC :: String -> Bool +isResWordGFC s = isInTree s $ + B "of" (B "fun" (B "concrete" (B "cat" (B "abstract" N N) N) (B "flags" N N)) (B "lin" (B "in" N N) (B "lincat" N N))) (B "resource" (B "param" (B "oper" (B "open" N N) N) (B "pre" N N)) (B "table" (B "strs" N N) (B "variants" N N))) + +data BTree = N | B String BTree BTree deriving (Show) + +isInTree :: String -> BTree -> Bool +isInTree x tree = case tree of + N -> False + B a left right + | x < a -> isInTree x left + | x > a -> isInTree x right + | x == a -> True + diff --git a/src/GF/Grammar/TC.hs b/src/GF/Grammar/TC.hs new file mode 100644 index 000000000..ce9da979d --- /dev/null +++ b/src/GF/Grammar/TC.hs @@ -0,0 +1,210 @@ +module TC where + +import Operations +import Abstract +import AbsCompute + +import Monad + +-- Thierry Coquand's type checking algorithm that creates a trace + +data AExp = + AVr Ident Val + | ACn QIdent Val + | AType + | AInt Int + | AStr String + | AMeta MetaSymb Val + | AApp AExp AExp Val + | AAbs Ident Val AExp + | AProd Ident AExp AExp + | AEqs [([Exp],AExp)] --- + deriving (Eq,Show) + +type Theory = QIdent -> Err Val + +lookupConst :: Theory -> QIdent -> Err Val +lookupConst th f = th f + +lookupVar :: Env -> Ident -> Err Val +lookupVar g x = maybe (prtBad "unknown variable" x) return $ lookup x ((IW,uVal):g) +-- wild card IW: no error produced, ?0 instead. + +type TCEnv = (Int,Env,Env) + +emptyTCEnv :: TCEnv +emptyTCEnv = (0,[],[]) + +whnf :: Val -> Err Val +whnf v = ---- errIn ("whnf" +++ prt v) $ ---- debug + case v of + VApp u w -> do + u' <- whnf u + w' <- whnf w + app u' w' + VClos env e -> eval env e + _ -> return v + +app :: Val -> Val -> Err Val +app u v = case u of + VClos env (Abs x e) -> eval ((x,v):env) e + _ -> return $ VApp u v + +eval :: Env -> Exp -> Err Val +eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $ + case e of + Vr x -> lookupVar env x + Q m c -> return $ VCn (m,c) + Sort c -> return $ VType --- the only sort is Type + App f a -> join $ liftM2 app (eval env f) (eval env a) + _ -> return $ VClos env e + +eqVal :: Int -> Val -> Val -> Err [(Val,Val)] +eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $ + do + w1 <- whnf u1 + w2 <- whnf u2 + let v = VGen k + case (w1,w2) of + (VApp f1 a1, VApp f2 a2) -> liftM2 (++) (eqVal k f1 f2) (eqVal k a1 a2) + (VClos env1 (Abs x1 e1), VClos env2 (Abs x2 e2)) -> + eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2) + (VClos env1 (Prod x1 a1 e1), VClos env2 (Prod x2 a2 e2)) -> + liftM2 (++) + (eqVal k (VClos env1 a1) (VClos env2 a2)) + (eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2)) + (VGen i _, VGen j _) -> return [(w1,w2) | i /= j] + _ -> return [(w1,w2) | w1 /= w2] +-- invariant: constraints are in whnf + +checkType :: Theory -> TCEnv -> Exp -> Err (AExp,[(Val,Val)]) +checkType th tenv e = checkExp th tenv e vType + +checkExp :: Theory -> TCEnv -> Exp -> Val -> Err (AExp, [(Val,Val)]) +checkExp th tenv@(k,rho,gamma) e ty = do + typ <- whnf ty + let v = VGen k + case e of + Meta m -> return $ (AMeta m typ,[]) + + Abs x t -> case typ of + VClos env (Prod y a b) -> do + a' <- whnf $ VClos env a --- + (t',cs) <- checkExp th + (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b) + return (AAbs x a' t', cs) + _ -> prtBad ("function type expected for" +++ prt e +++ "instead of") typ + + Eqs es -> do + bcs <- mapM (\b -> checkBranch th tenv b typ) es + let (bs,css) = unzip bcs + return (AEqs bs, concat css) + + Prod x a b -> do + testErr (typ == vType) "expected Type" + (a',csa) <- checkType th tenv a + (b',csb) <- checkType th (k+1, (x,v x):rho, (x,VClos rho a):gamma) b + return (AProd x a' b', csa ++ csb) + + _ -> checkInferExp th tenv e typ + +checkInferExp :: Theory -> TCEnv -> Exp -> Val -> Err (AExp, [(Val,Val)]) +checkInferExp th tenv@(k,_,_) e typ = do + (e',w,cs1) <- inferExp th tenv e + cs2 <- eqVal k w typ + return (e',cs1 ++ cs2) + +inferExp :: Theory -> TCEnv -> Exp -> Err (AExp, Val, [(Val,Val)]) +inferExp th tenv@(k,rho,gamma) e = case e of + Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x + Q m c -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c) + Sort _ -> return (AType, vType, []) + App f t -> do + (f',w,csf) <- inferExp th tenv f + typ <- whnf w + case typ of + VClos env (Prod x a b) -> do + (a',csa) <- checkExp th tenv t (VClos env a) + b' <- whnf $ VClos ((x,VClos rho t):env) b + return $ (AApp f' a' b', b', csf ++ csa) + _ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ + _ -> prtBad "cannot infer type of expression" e + +checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Exp],AExp),[(Val,Val)]) +checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ + chB tenv' ps' ty + where + + (ps',_,rho2,_) = ps2ts k ps + tenv' = (k,rho2++rho, gamma) + (k,rho,gamma) = tenv + + chB tenv@(k,rho,gamma) ps ty = case ps of + p:ps2 -> do + typ <- whnf ty + case typ of + VClos env (Prod y a b) -> do + a' <- whnf $ VClos env a + (p', sigma, binds, cs1) <- checkP tenv p y a' + let tenv' = (length binds, sigma ++ rho, binds ++ gamma) + ((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b) + return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt + _ -> prtBad ("Product expected for definiens" +++prt t +++ "instead of") typ + [] -> do + (e,cs) <- checkExp th tenv t ty + return (([],e),cs) + checkP env@(k,rho,gamma) t x a = do + (delta,cs) <- checkPatt th env t a + let sigma = [(x, VGen i x) | ((x,_),i) <- zip delta [k..]] + return (VClos sigma t, sigma, delta, cs) + + ps2ts k = foldr p2t ([],0,[],k) + p2t p (ps,i,g,k) = case p of + PV IW -> (meta (MetaSymb i) : ps, i+1,g,k) + PV x -> (vr x : ps, i, upd x k g,k+1) +---- PL s -> (cn s : ps, i, g, k) + PP m c xs -> (mkApp (qq (m,c)) xss : ps, j, g',k') + where (xss,j,g',k') = foldr p2t ([],i,g,k) xs + _ -> error $ "undefined p2t case" +++ prt p +++ "in checkBranch" + + upd x k g = (x, VGen k x) : g --- hack to recognize pattern variables + +checkPatt :: Theory -> TCEnv -> Exp -> Val -> Err (Binds,[(Val,Val)]) +checkPatt th tenv exp val = do + (aexp,_,cs) <- checkExpP tenv exp val + let binds = extrBinds aexp + return (binds,cs) + where + extrBinds aexp = case aexp of + AVr i v -> [(i,v)] + AApp f a _ -> extrBinds f ++ extrBinds a + _ -> [] -- no other cases are possible + +--- ad hoc, to find types of variables + checkExpP tenv@(k,rho,gamma) exp val = case exp of + Meta m -> return $ (AMeta m val, val, []) + Vr x -> return $ (AVr x val, val, []) + Q m c -> do + typ <- lookupConst th (m,c) + return $ (ACn (m,c) typ, typ, []) + App f t -> do + (f',w,csf) <- checkExpP tenv f val + typ <- whnf w + case typ of + VClos env (Prod x a b) -> do + (a',_,csa) <- checkExpP tenv t (VClos env a) + b' <- whnf $ VClos ((x,VClos rho t):env) b + return $ (AApp f' a' b', b', csf ++ csa) + _ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ + _ -> prtBad "cannot typecheck pattern" exp + +-- auxiliaries + +noConstr :: Err Val -> Err (Val,[(Val,Val)]) +noConstr er = er >>= (\v -> return (v,[])) + +mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)]) +mkAnnot a ti = do + (v,cs) <- ti + return (a v, v, cs) + diff --git a/src/GF/Grammar/TypeCheck.hs b/src/GF/Grammar/TypeCheck.hs new file mode 100644 index 000000000..c97bdd362 --- /dev/null +++ b/src/GF/Grammar/TypeCheck.hs @@ -0,0 +1,231 @@ +module TypeCheck where + +import Operations +import Zipper + +import Abstract +import AbsCompute +import Refresh +import LookAbs + +import TC + +import Unify --- + +import Monad (foldM, liftM, liftM2) + +-- top-level type checking functions; TC should not be called directly. + +annotate :: GFCGrammar -> Exp -> Err Tree +annotate gr exp = annotateIn gr [] exp Nothing + +-- type check in empty context, return a list of constraints +justTypeCheck :: GFCGrammar -> Exp -> Val -> Err Constraints +justTypeCheck gr e v = do + (_,constrs0) <- checkExp (grammar2theory gr) (initTCEnv []) e v + constrs1 <- reduceConstraints gr 0 constrs0 + return $ fst $ splitConstraints constrs1 + +-- type check in empty context, return the expression itself if valid +checkIfValidExp :: GFCGrammar -> Exp -> Err Exp +checkIfValidExp gr e = do + (_,_,constrs0) <- inferExp (grammar2theory gr) (initTCEnv []) e + constrs1 <- reduceConstraints gr 0 constrs0 + ifNull (return e) (Bad . unwords . prConstrs) constrs1 + +annotateIn :: GFCGrammar -> Binds -> Exp -> Maybe Val -> Err Tree +annotateIn gr gamma exp = maybe (infer exp) (check exp) where + infer e = do + (a,_,cs) <- inferExp theory env e + aexp2treeC (a,cs) + check e v = do + (a,cs) <- checkExp theory env e v + aexp2treeC (a,cs) + env = initTCEnv gamma + theory = grammar2theory gr + aexp2treeC (a,c) = do + c' <- reduceConstraints gr (length gamma) c + aexp2tree (a,c') + +-- invariant way of creating TCEnv from context +initTCEnv gamma = + (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma) + +-- process constraints after eqVal by computing by defs +reduceConstraints :: GFCGrammar -> Int -> Constraints -> Err Constraints +reduceConstraints gr i = liftM concat . mapM redOne where + redOne (u,v) = do + u' <- computeVal gr u + v' <- computeVal gr v + eqVal i u' v' + +computeVal :: GFCGrammar -> Val -> Err Val +computeVal gr v = case v of + VClos g@(_:_) e -> do + e' <- compt (map fst g) e --- bindings of g in e? + whnf $ VClos g e' + VApp f c -> liftM2 VApp (compv f) (compv c) >>= whnf + _ -> whnf v + where + compt = computeAbsTermIn gr + compv = computeVal gr + +-- take apart constraints that have the form (? <> t), usable as solutions +splitConstraints :: Constraints -> (Constraints,MetaSubst) +splitConstraints cs = csmsu where + + csmsu = unif (csf,msf) -- alternative: filter first + (csf,msf) = foldr mkOne ([],[]) cs + + csmsf = foldr mkOne ([],msu) csu + (csu,msu) = unif (cs,[]) -- alternative: unify first + + mkOne (u,v) = case (u,v) of + (VClos g (Meta m), v) | null g -> sub m v + (v, VClos g (Meta m)) | null g -> sub m v + -- do nothing if meta has nonempty closure; null g || isConstVal v WAS WRONG + c -> con c + con c (cs,ms) = (c:cs,ms) + sub m v (cs,ms) = (cs,(m,v):ms) + + unifo = id -- alternative: don't use unification + + unif cm@(cs,ms) = errVal cm $ do --- alternative: use unification + (cs',ms') <- unifyVal cs + return (cs', ms' ++ ms) + +performMetaSubstNode :: MetaSubst -> TrNode -> TrNode +performMetaSubstNode subst n@(N (b,a,v,(c,m),s)) = let + v' = metaSubstVal v + b' = [(x,metaSubstVal v) | (x,v) <- b] + c' = [(u',v') | (u,v) <- c, + let (u',v') = (metaSubstVal u, metaSubstVal v), u' /= v'] + in N (b',a,v',(c',m),s) + where + metaSubstVal u = errVal u $ whnf $ case u of + VApp f a -> VApp (metaSubstVal f) (metaSubstVal a) + VClos g e -> VClos [(x,metaSubstVal v) | (x,v) <- g] (metaSubstExp e) + _ -> u + metaSubstExp e = case e of + Meta m -> errVal e $ maybe (return e) val2expSafe $ lookup m subst + _ -> composSafeOp metaSubstExp e + +-- weak heuristic to narrow down menus; not used for TC. 15/11/2001 +-- the age-old method from GF 0.9 +possibleConstraints :: GFCGrammar -> Constraints -> Bool +possibleConstraints gr = and . map (possibleConstraint gr) + +possibleConstraint :: GFCGrammar -> (Val,Val) -> Bool +possibleConstraint gr (u,v) = errVal True $ do + u' <- val2exp u >>= compute gr + v' <- val2exp v >>= compute gr + return $ cts u' v' + where + cts t u = case (t,u) of + (Q m c, Q n d) -> c == d || notCan (m,c) || notCan (n,d) + (App f a, App g b) -> cts f g && cts a b + (Abs x b, Abs y c) -> cts b c + (Prod x a f, Prod y b g) -> cts a b && cts f g + (_ , _) -> isUnknown t || isUnknown u + + isUnknown t = case t of + Vr _ -> True + Meta _ -> True + _ -> False + + notCan = not . isPrimitiveFun gr + +-- interface to TC type checker + +type2val :: Type -> Val +type2val = VClos [] + +aexp2tree :: (AExp,[(Val,Val)]) -> Err Tree +aexp2tree (aexp,cs) = do + (bi,at,vt,ts) <- treeForm aexp + ts' <- mapM aexp2tree [(t,[]) | t <- ts] + return $ Tr (N (bi,at,vt,(cs,[]),False),ts') + where + treeForm a = case a of + AAbs x v b -> do + (bi, at, vt, args) <- treeForm b + v' <- whnf v ---- should not be needed... + return ((x,v') : bi, at, vt, args) + AApp c a v -> do + (_,at,_,args) <- treeForm c + v' <- whnf v ---- + return ([],at,v',args ++ [a]) + AVr x v -> do + v' <- whnf v ---- + return ([],AtV x,v',[]) + ACn c v -> do + v' <- whnf v ---- + return ([],AtC c,v',[]) + AMeta m v -> do + v' <- whnf v ---- + return ([],AtM m,v',[]) + _ -> Bad "illegal tree" -- AProd + +grammar2theory :: GFCGrammar -> Theory +grammar2theory gr (m,f) = case lookupFunType gr m f of + Ok t -> return $ type2val t + Bad s -> case lookupCatContext gr m f of + Ok cont -> return $ cont2val cont + _ -> Bad s + +cont2exp :: Context -> Exp +cont2exp c = mkProd (c, eType, []) -- to check a context + +cont2val :: Context -> Val +cont2val = type2val . cont2exp + +-- some top-level batch-mode checkers for the compiler + +justTypeCheckSrc :: Grammar -> Exp -> Val -> Err Constraints +justTypeCheckSrc gr e v = do + (_,constrs0) <- checkExp (grammar2theorySrc gr) (initTCEnv []) e v +----- constrs1 <- reduceConstraints gr 0 constrs0 + return $ fst $ splitConstraints constrs0 + +grammar2theorySrc :: Grammar -> Theory +grammar2theorySrc gr (m,f) = case lookupFunTypeSrc gr m f of + Ok t -> return $ type2val t + Bad s -> case lookupCatContextSrc gr m f of + Ok cont -> return $ cont2val cont + _ -> Bad s + +checkContext :: Grammar -> Context -> [String] +checkContext st = checkTyp st . cont2exp + +checkTyp :: Grammar -> Type -> [String] +checkTyp gr typ = err singleton prConstrs $ justTypeCheckSrc gr typ vType + +checkEquation :: Grammar -> Fun -> Trm -> [String] +checkEquation gr (m,fun) def = err singleton id $ do + typ <- lookupFunTypeSrc gr m fun + cs <- justTypeCheckSrc gr def (vClos typ) + let cs1 = cs ----- filter (not . possibleConstraint gr) cs ---- + return $ ifNull [] (singleton . prConstraints) cs1 + +checkConstrs :: Grammar -> Cat -> [Ident] -> [String] +checkConstrs gr cat _ = [] ---- check constructors! + + + + + + +{- ---- +err singleton concat . mapM checkOne where + checkOne con = do + typ <- lookupFunType gr con + typ' <- computeAbsTerm gr typ + vcat <- valCat typ' + return $ if (cat == vcat) then [] else ["wrong type in constructor" +++ prt con] +-} + +editAsTermCommand :: GFCGrammar -> (Loc TrNode -> Err (Loc TrNode)) -> Exp -> [Exp] +editAsTermCommand gr c e = err (const []) singleton $ do + t <- annotate gr $ refreshMetas [] e + t' <- c $ tree2loc t + return $ tree2exp $ loc2tree t' diff --git a/src/GF/Grammar/Unify.hs b/src/GF/Grammar/Unify.hs new file mode 100644 index 000000000..a39087c62 --- /dev/null +++ b/src/GF/Grammar/Unify.hs @@ -0,0 +1,84 @@ +module Unify where + +import Abstract + +import Operations + +import List (partition) + +-- (c) Petri Mäenpää & Aarne Ranta, 1998--2001 + +-- brute-force adaptation of the old-GF program AR 21/12/2001 --- +-- the only use is in TypeCheck.splitConstraints + +unifyVal :: Constraints -> Err (Constraints,MetaSubst) +unifyVal cs0 = do + let (cs1,cs2) = partition notSolvable cs0 + let (us,vs) = unzip cs1 + us' <- mapM val2exp us + vs' <- mapM val2exp vs + let (ms,cs) = unifyAll (zip us' vs') [] + return (cs1 ++ [(VClos [] t, VClos [] u) | (t,u) <- cs], + [(m, VClos [] t) | (m,t) <- ms]) + where + notSolvable (v,w) = case (v,w) of -- don't consider nonempty closures + (VClos (_:_) _,_) -> True + (_,VClos (_:_) _) -> True + _ -> False + +type Unifier = [(MetaSymb, Trm)] +type Constrs = [(Trm, Trm)] + +unifyAll :: Constrs -> Unifier -> (Unifier,Constrs) +unifyAll [] g = (g, []) +unifyAll ((a@(s, t)) : l) g = + let (g1, c) = unifyAll l g + in case unify s t g1 of + Ok g2 -> (g2, c) + _ -> (g1, a : c) + +unify :: Trm -> Trm -> Unifier -> Err Unifier +unify e1 e2 g = + case (e1, e2) of + (Meta s, t) -> do + tg <- subst_all g t + let sg = maybe e1 id (lookup s g) + if (sg == Meta s) then extend g s tg else unify sg tg g + (t, Meta s) -> unify e2 e1 g + (Q _ a, Q _ b) | (a == b) -> return g ---- qualif? + (QC _ a, QC _ b) | (a == b) -> return g ---- + (Vr x, Vr y) | (x == y) -> return g + (Abs x b, Abs y c) -> do let c' = substTerm [x] [(y,Vr x)] c + unify b c' g + (App c a, App d b) -> case unify c d g of + Ok g1 -> unify a b g1 + _ -> prtBad "fail unify" e1 + _ -> prtBad "fail unify" e1 + +extend :: Unifier -> MetaSymb -> Trm -> Err Unifier +extend g s t | (t == Meta s) = return g + | occCheck s t = prtBad "occurs check" t + | True = return ((s, t) : g) + +subst_all :: Unifier -> Trm -> Err Trm +subst_all s u = + case (s,u) of + ([], t) -> return t + (a : l, t) -> do + t' <- (subst_all l t) --- successive substs - why ? + return $ substMetas [a] t' + +substMetas :: [(MetaSymb,Trm)] -> Trm -> Trm +substMetas subst trm = case trm of + Meta x -> case lookup x subst of + Just t -> t + _ -> trm + _ -> composSafeOp (substMetas subst) trm + +occCheck :: MetaSymb -> Trm -> Bool +occCheck s u = case u of + Meta v -> s == v + App c a -> occCheck s c || occCheck s a + Abs x b -> occCheck s b + _ -> False + diff --git a/src/GF/Grammar/Values.hs b/src/GF/Grammar/Values.hs new file mode 100644 index 000000000..7b02d187a --- /dev/null +++ b/src/GF/Grammar/Values.hs @@ -0,0 +1,52 @@ +module Values where + +import Operations +import Zipper + +import Grammar +import Ident + +-- values used in TC type checking + +type Exp = Term + +data Val = VGen Int Ident | VApp Val Val | VCn QIdent | VType | VClos Env Exp + deriving (Eq,Show) + +type Env = [(Ident,Val)] + +-- annotated tree used in editing + +type Tree = Tr TrNode + +newtype TrNode = N (Binds,Atom,Val,(Constraints,MetaSubst),Bool) + deriving (Eq,Show) + +data Atom = AtC Fun | AtM MetaSymb | AtV Ident | AtL String | AtI Int + deriving (Eq,Show) + +type Binds = [(Ident,Val)] +type Constraints = [(Val,Val)] +type MetaSubst = [(MetaSymb,Val)] + +-- for TC + +vType :: Val +vType = VType + +cType :: Ident +cType = identC "Type" --- #0 + +eType :: Exp +eType = Sort "Type" + +tree2exp :: Tree -> Exp +tree2exp (Tr (N (bi,at,_,_,_),ts)) = foldr Abs (foldl App at' ts') bi' where + at' = case at of + AtC (m,c) -> Q m c + AtV i -> Vr i + AtM m -> Meta m + AtL s -> K s + AtI s -> EInt s + bi' = map fst bi + ts' = map tree2exp ts diff --git a/src/GF/Infra/CheckM.hs b/src/GF/Infra/CheckM.hs new file mode 100644 index 000000000..2ce1a4e95 --- /dev/null +++ b/src/GF/Infra/CheckM.hs @@ -0,0 +1,70 @@ +module CheckM where + +import Operations +import Grammar +import Ident +import PrGrammar + +-- the strings are non-fatal warnings +type Check a = STM (Context,[String]) a + +checkError :: String -> Check a +checkError = raise + +checkCond :: String -> Bool -> Check () +checkCond s b = if b then return () else checkError s + +-- warnings should be reversed in the end +checkWarn :: String -> Check () +checkWarn s = updateSTM (\ (cont,msg) -> (cont, s:msg)) + +checkUpdate :: Decl -> Check () +checkUpdate d = updateSTM (\ (cont,msg) -> (d:cont, msg)) + +checkInContext :: [Decl] -> Check r -> Check r +checkInContext g ch = do + i <- checkUpdates g + r <- ch + checkResets i + return r + +checkUpdates :: [Decl] -> Check Int +checkUpdates ds = mapM checkUpdate ds >> return (length ds) + +checkReset :: Check () +checkReset = checkResets 1 + +checkResets :: Int -> Check () +checkResets i = updateSTM (\ (cont,msg) -> (drop i cont, msg)) + +checkGetContext :: Check Context +checkGetContext = do + (co,_) <- readSTM + return co + +checkLookup :: Ident -> Check Type +checkLookup x = do + co <- checkGetContext + checkErr $ maybe (prtBad "unknown variable" x) return $ lookup x co + +checkStart :: Check a -> Err (a,(Context,[String])) +checkStart c = appSTM c ([],[]) + +checkErr :: Err a -> Check a +checkErr e = stm (\s -> do + v <- e + return (v,s) + ) + +checkVal :: a -> Check a +checkVal v = return v + +prtFail :: Print a => String -> a -> Check b +prtFail s t = checkErr $ prtBad s t + +checkIn :: String -> Check a -> Check a +checkIn msg c = stm $ \s@(g,ws) -> case appSTM c s of + Bad e -> Bad $ msg ++++ e + Ok (v,(g',ws')) -> Ok (v,(g',ws2)) where + new = take (length ws' - length ws) ws' + ws2 = [msg ++++ w | w <- new] ++ ws diff --git a/src/GF/Infra/Ident.hs b/src/GF/Infra/Ident.hs new file mode 100644 index 000000000..3e564460c --- /dev/null +++ b/src/GF/Infra/Ident.hs @@ -0,0 +1,117 @@ +module Ident where + +import Operations +-- import Monad + +data Ident = + IC String -- raw identifier after parsing, resolved in Rename + | IW -- wildcard + +-- below this line: internal representation never returned by the parser + | IV (Int,String) -- variable + | IA (String,Int) -- argument of cat at position + | IAV (String,Int,Int) -- argument of cat with bindings at position + + deriving (Eq, Ord, Show, Read) + +prIdent :: Ident -> String +prIdent i = case i of + IC s -> s + IV (n,s) -> s ++ "_" ++ show n + IA (s,j) -> s ++ "_" ++ show j + IAV (s,b,j) -> s ++ "_" ++ show b ++ "_" ++ show j + IW -> "_" + +(identC, identV, identA, identAV, identW) = + (IC, IV, IA, IAV, IW) + +-- normal identifier +-- ident s = IC s + +-- to mark argument variables +argIdent 0 (IC c) i = identA (c,i) +argIdent b (IC c) i = identAV (c,b,i) + +-- used in lin defaults +strVar = identA ("str",0) + +-- wild card +wildIdent = identW + +isWildIdent :: Ident -> Bool +isWildIdent = (== wildIdent) + +newIdent = identC "#h" + +mkIdent :: String -> Int -> Ident +mkIdent s i = identV (i,s) + +varIndex :: Ident -> Int +varIndex (IV (n,_)) = n +varIndex _ = -1 --- other than IV should not count + +-- refreshing identifiers + +type IdState = ([(Ident,Ident)],Int) + +initIdStateN :: Int -> IdState +initIdStateN i = ([],i) + +initIdState :: IdState +initIdState = initIdStateN 0 + +lookVar :: Ident -> STM IdState Ident +lookVar a@(IA _) = return a +lookVar x = do + (sys,_) <- readSTM + stm (\s -> maybe (Bad ("cannot find" +++ show x +++ prParenth (show sys))) + return $ + lookup x sys >>= (\y -> return (y,s))) + +refVar :: Ident -> STM IdState Ident +----refVar IW = return IW --- no update of wildcard +refVar x = do + (_,m) <- readSTM + let x' = IV (m, prIdent x) + updateSTM (\ (sys,mx) -> ((x, x'):sys, mx + 1)) + return x' + +refVarPlus :: Ident -> STM IdState Ident +----refVarPlus IW = refVar (identC "h") +refVarPlus x = refVar x + + +{- +------------------------------ +-- to test + +refreshExp :: Exp -> Err Exp +refreshExp e = err Bad (return . fst) (appSTM (refresh e) initState) + +refresh :: Exp -> STM State Exp +refresh e = case e of + Atom x -> lookVar x >>= return . Atom + App f a -> liftM2 App (refresh f) (refresh a) + Abs x b -> liftM2 Abs (refVar x) (refresh b) + Fun xs a b -> do + a' <- refresh a + xs' <- mapM refVar xs + b' <- refresh b + return $ Fun xs' a' b' + +data Exp = + Atom Ident + | App Exp Exp + | Abs Ident Exp + | Fun [Ident] Exp Exp + deriving Show + +exp1 = Abs (IC "y") (Atom (IC "y")) +exp2 = Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "y"))) +exp3 = Abs (IC "y") (Abs (IC "z") (App (Atom (IC "y")) (Atom (IC "z")))) +exp4 = Abs (IC "y") (Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "z")))) +exp5 = Abs (IC "y") (Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "y")))) +exp6 = Abs (IC "y") (Fun [IC "x", IC "y"] (Atom (IC "y")) (Atom (IC "y"))) +exp7 = Abs (IL "8") (Atom (IC "y")) + +-} diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs new file mode 100644 index 000000000..01b789f8f --- /dev/null +++ b/src/GF/Infra/Modules.hs @@ -0,0 +1,181 @@ +module Modules where + +import Ident +import Option +import Operations + +import List + + +-- AR 29/4/2003 + +-- The same structure will be used in both source code and canonical. +-- The parameters tell what kind of data is involved. +-- Invariant: modules are stored in dependency order + +data MGrammar i f a = MGrammar {modules :: [(i,ModInfo i f a)]} + deriving Show + +data ModInfo i f a = + ModMainGrammar (MainGrammar i) + | ModMod (Module i f a) + deriving Show + +data Module i f a = Module { + mtype :: ModuleType i , + flags :: [f] , + extends :: Maybe i , + opens :: [OpenSpec i] , + jments :: BinTree (i,a) + } + deriving Show + +-- destructive update + +--- dep order preserved since old cannot depend on new +updateMGrammar :: Ord i => MGrammar i f a -> MGrammar i f a -> MGrammar i f a +updateMGrammar old new = MGrammar $ + [(i,m) | (i,m) <- os, notElem i (map fst ns)] ++ ns + where + os = modules old + ns = modules new + +updateModule :: Ord i => Module i f t -> i -> t -> Module i f t +updateModule (Module mt fs me ops js) i t = + Module mt fs me ops (updateTree (i,t) js) + +data MainGrammar i = MainGrammar { + mainAbstract :: i , + mainConcretes :: [MainConcreteSpec i] + } + deriving Show + +data MainConcreteSpec i = MainConcreteSpec { + concretePrintname :: i , + concreteName :: i , + transferIn :: Maybe (OpenSpec i) , -- if there is an in-transfer + transferOut :: Maybe (OpenSpec i) -- if there is an out-transfer + } + deriving Show + +data OpenSpec i = OSimple i | OQualif i i + deriving (Eq,Show) + +openedModule :: OpenSpec i -> i +openedModule o = case o of + OSimple m -> m + OQualif _ m -> m + +-- initial dependency list +depPathModule :: Ord i => Module i f a -> [OpenSpec i] +depPathModule m = fors m ++ exts m ++ opens m where + fors m = case mtype m of + MTTransfer i j -> [i,j] + MTConcrete i -> [OSimple i] + _ -> [] + exts m = map OSimple $ maybe [] return $ extends m + +-- all modules that a module extends, directly or indirectly +allExtends :: (Show i,Ord i) => MGrammar i f a -> i -> [i] +allExtends gr i = case lookupModule gr i of + Ok (ModMod m) -> case extends m of + Just i1 -> i : allExtends gr i1 + _ -> [i] + _ -> [] + +-- initial search path: the nonqualified dependencies +searchPathModule :: Ord i => Module i f a -> [i] +searchPathModule m = [i | OSimple i <- depPathModule m] + +-- a new module can safely be added to the end, since nothing old can depend on it +addModule :: Ord i => + MGrammar i f a -> i -> ModInfo i f a -> MGrammar i f a +addModule gr name mi = MGrammar $ (modules gr ++ [(name,mi)]) + +emptyMGrammar :: MGrammar i f a +emptyMGrammar = MGrammar [] + + +-- we store the module type with the identifier + +data IdentM i = IdentM { + identM :: i , + typeM :: ModuleType i + } + deriving (Eq,Show) + +-- encoding the type of the module +data ModuleType i = + MTAbstract + | MTTransfer (OpenSpec i) (OpenSpec i) + | MTResource + | MTResourceInt + | MTResourceImpl i + | MTConcrete i + | MTConcreteInt i i + | MTConcreteImpl i i i + | MTReuse i + deriving (Eq,Show) + +typeOfModule mi = case mi of + ModMod m -> mtype m + +isResourceModule mi = case typeOfModule mi of + MTResource -> True + MTReuse _ -> True + MTResourceInt -> True + MTResourceImpl _ -> True + _ -> False + +abstractOfConcrete :: (Show i, Eq i) => MGrammar i f a -> i -> Err i +abstractOfConcrete gr c = do + m <- lookupModule gr c + case m of + ModMod n -> case mtype n of + MTConcrete a -> return a + _ -> Bad $ "expected concrete" +++ show c + _ -> Bad $ "expected concrete" +++ show c + +abstractModOfConcrete :: (Show i, Eq i) => + MGrammar i f a -> i -> Err (Module i f a) +abstractModOfConcrete gr c = do + a <- abstractOfConcrete gr c + m <- lookupModule gr a + case m of + ModMod n -> return n + _ -> Bad $ "expected abstract" +++ show c + + +-- the canonical file name + +--- canonFileName s = prt s ++ ".gfc" + +lookupModule :: (Show i,Eq i) => MGrammar i f a -> i -> Err (ModInfo i f a) +lookupModule gr m = case lookup m (modules gr) of + Just i -> return i + _ -> Bad $ "unknown module" +++ show m + +++ "among" +++ unwords (map (show . fst) (modules gr)) ---- debug + +lookupModuleType :: (Show i,Eq i) => MGrammar i f a -> i -> Err (ModuleType i) +lookupModuleType gr m = do + mi <- lookupModule gr m + return $ typeOfModule mi + +lookupInfo :: (Show i, Ord i) => Module i f a -> i -> Err a +lookupInfo mo i = lookupTree show i (jments mo) + +isModAbs m = case mtype m of + MTAbstract -> True + _ -> False + +isModRes m = case mtype m of + MTResource -> True + _ -> False + +isModCnc m = case mtype m of + MTConcrete _ -> True + _ -> False + +sameMType m n = case (m,n) of + (MTConcrete _, MTConcrete _) -> True + _ -> m == n diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs new file mode 100644 index 000000000..e81c9cd82 --- /dev/null +++ b/src/GF/Infra/Option.hs @@ -0,0 +1,204 @@ +module Option where + +import List (partition) +import Char (isDigit) + +-- all kinds of options, to be kept abstract + +newtype Option = Opt (String,[String]) deriving (Eq,Show,Read) +newtype Options = Opts [Option] deriving (Eq,Show,Read) + +noOptions :: Options +noOptions = Opts [] + +iOpt o = Opt (o,[]) -- simple option -o +aOpt o a = Opt (o,[a]) -- option with argument -o=a +iOpts = Opts + +oArg s = s -- value of option argument + +oElem :: Option -> Options -> Bool +oElem o (Opts os) = elem o os + +type OptFun = String -> Option + +getOptVal :: Options -> OptFun -> Maybe String +getOptVal (Opts os) fopt = + case [a | opt@(Opt (o,[a])) <- os, opt == fopt a] of + a:_ -> Just a + _ -> Nothing + +getOptInt :: Options -> OptFun -> Maybe Int +getOptInt opts f = do + s <- getOptVal opts f + if (not (null s) && all isDigit s) then return (read s) else Nothing + +optIntOrAll :: Options -> OptFun -> [a] -> [a] +optIntOrAll opts f = case getOptInt opts f of + Just i -> take i + _ -> id + +optIntOrN :: Options -> OptFun -> Int -> Int +optIntOrN opts f n = case getOptInt opts f of + Just i -> i + _ -> n + +optIntOrOne :: Options -> OptFun -> Int +optIntOrOne opts f = optIntOrN opts f 1 + +changeOptVal :: Options -> OptFun -> String -> Options +changeOptVal os f x = + addOption (f x) $ maybe os (\y -> removeOption (f y) os) $ getOptVal os f + +addOption :: Option -> Options -> Options +addOption o (Opts os) = iOpts (o:os) + +addOptions (Opts os) os0 = foldr addOption os0 os + +removeOption :: Option -> Options -> Options +removeOption o (Opts os) = iOpts (filter (/=o) os) + +removeOptions (Opts os) os0 = foldr removeOption os0 os + +options = foldr addOption noOptions + +unionOptions :: Options -> Options -> Options +unionOptions (Opts os) (Opts os') = Opts (os ++ os') + +-- parsing options, with prefix pre (e.g. "-") + +getOptions :: String -> [String] -> (Options, [String]) +getOptions pre inp = let + (os,rest) = span (isOption pre) inp -- options before args + in + (Opts (map (pOption pre) os), rest) + +pOption :: String -> String -> Option +pOption pre s = case span (/= '=') (drop (length pre) s) of + (f,_:a) -> aOpt f a + (o,[]) -> iOpt o + +isOption :: String -> String -> Bool +isOption pre = (==pre) . take (length pre) + +-- printing options, without prefix + +prOpt (Opt (s,[])) = s +prOpt (Opt (s,xs)) = s ++ "=" ++ concat xs +prOpts (Opts os) = unwords $ map prOpt os + +-- a suggestion for option names + +-- parsing +strictParse = iOpt "strict" +forgiveParse = iOpt "n" +ignoreParse = iOpt "ign" +literalParse = iOpt "lit" +rawParse = iOpt "raw" +firstParse = iOpt "1" +dontParse = iOpt "read" -- parse as term instead of string + +-- grammar formats +showAbstr = iOpt "abs" +showXML = iOpt "xml" +showOld = iOpt "old" +showLatex = iOpt "latex" +showFullForm = iOpt "fullform" +showEBNF = iOpt "ebnf" +showCF = iOpt "cf" +showWords = iOpt "ws" +showOpts = iOpt "opts" +-- showOptim = iOpt "opt" +isCompiled = iOpt "gfc" +isHaskell = iOpt "gfhs" +noCompOpers = iOpt "nocomp" +retainOpers = iOpt "retain" +defaultGrOpts = [] +newParser = iOpt "new" +noCF = iOpt "nocf" +checkCirc = iOpt "nocirc" +noCheckCirc = iOpt "nocheckcirc" + +-- linearization +allLin = iOpt "all" +firstLin = iOpt "one" +distinctLin = iOpt "nub" +dontLin = iOpt "show" +showRecord = iOpt "record" +showStruct = iOpt "structured" +xmlLin = showXML +latexLin = showLatex +tableLin = iOpt "table" +defaultLinOpts = [firstLin] +useUTF8 = iOpt "utf8" + +-- other +beVerbose = iOpt "v" +showInfo = iOpt "i" +beSilent = iOpt "s" +emitCode = iOpt "o" +makeMulti = iOpt "multi" +beShort = iOpt "short" +wholeGrammar = iOpt "w" +makeFudget = iOpt "f" +byLines = iOpt "lines" +byWords = iOpt "words" +analMorpho = iOpt "morpho" +doTrace = iOpt "tr" +noCPU = iOpt "nocpu" +doCompute = iOpt "c" +optimizeCanon = iOpt "opt" + +-- mainly for stand-alone +useUnicode = iOpt "unicode" +optCompute = iOpt "compute" +optCheck = iOpt "typecheck" +optParaphrase = iOpt "paraphrase" +forJava = iOpt "java" + +-- for edit session +allLangs = iOpt "All" +absView = iOpt "Abs" + +-- options that take arguments +useTokenizer = aOpt "lexer" +useUntokenizer = aOpt "unlexer" +useParser = aOpt "parser" +firstCat = aOpt "cat" -- used on command line +gStartCat = aOpt "startcat" -- used in grammar, to avoid clash w res word +useLanguage = aOpt "lang" +speechLanguage = aOpt "language" +useFont = aOpt "font" +grammarFormat = aOpt "format" +grammarPrinter = aOpt "printer" +filterString = aOpt "filter" +termCommand = aOpt "transform" +transferFun = aOpt "transfer" +forForms = aOpt "forms" +menuDisplay = aOpt "menu" +sizeDisplay = aOpt "size" +typeDisplay = aOpt "types" +noDepTypes = aOpt "nodeptypes" +extractGr = aOpt "extract" +pathList = aOpt "path" + +-- refinement order +nextRefine = aOpt "nextrefine" +firstRefine = oArg "first" +lastRefine = oArg "last" + +-- Boolean flags +flagYes = oArg "yes" +flagNo = oArg "no" + +-- integer flags +flagDepth = aOpt "depth" +flagLength = aOpt "length" +flagNumber = aOpt "number" + +caseYesNo :: Options -> OptFun -> Maybe Bool +caseYesNo opts f = do + v <- getOptVal opts f + if v == flagYes then return True + else if v == flagNo then return False + else Nothing diff --git a/src/GF/Infra/ReadFiles.hs b/src/GF/Infra/ReadFiles.hs new file mode 100644 index 000000000..f755397f2 --- /dev/null +++ b/src/GF/Infra/ReadFiles.hs @@ -0,0 +1,135 @@ +module ReadFiles where + +import Arch (selectLater, modifiedFiles, ModTime) + +import Operations +import UseIO +import System +import Char +import Monad + +-- make analysis for GF grammar modules. AR 11/6/2003 + +-- to find all files that have to be read, put them in dependency order, and +-- decide which files need recompilation. Name file.gf is returned for them, +-- and file.gfc or file.gfr otherwise. + +type ModName = String +type FileName = String +type InitPath = String +type FullPath = String + +getAllFiles :: [InitPath] -> [(FullPath,ModTime)] -> FileName -> + IOE [FullPath] +getAllFiles ps env file = do + ds <- getImports ps file + -- print ds ---- debug + ds1 <- ioeErr $ either + return + (\ms -> Bad $ "circular modules" +++ unwords (map show (head ms))) $ + topoTest $ map fst ds + let paths = [(f,p) | ((f,_),p) <- ds] + let pds1 = [(p,f) | f <- ds1, Just p <- [lookup f paths]] + ds2 <- ioeIO $ mapM selectFormat pds1 + -- print ds2 ---- debug + let ds3 = needCompile ds ds2 + ds4 <- ioeIO $ modifiedFiles env ds3 + return ds4 + +getImports :: [InitPath] -> FileName -> IOE [((ModName,[ModName]),InitPath)] +getImports ps = get [] where + get ds file = do + let name = fileBody file + (p,s) <- readFileIfPath ps $ file + let imps = importsOfFile s + case imps of + _ | elem name (map (fst . fst) ds) -> return ds --- file already read + [] -> return $ ((name,[]),p):ds + _ -> do + let files = map gfFile imps + foldM get (((name,imps),p):ds) files + +-- to decide whether to read gf or gfc; returns full file path + +selectFormat :: (InitPath,ModName) -> IO (ModName,(FullPath,Bool)) +selectFormat (p,f) = do + let pf = prefixPathName p f + f0 <- selectLater (gfFile pf) (gfcFile pf) + f1 <- selectLater (gfrFile pf) f0 + return $ (f, (f1, f1 == gfFile pf)) -- True if needs compile + +needCompile :: [((ModName,[ModName]),InitPath)] -> [(ModName,(FullPath,Bool))] -> + [FullPath] +needCompile deps sfiles = filt $ mark $ iter changed where + + -- start with the changed files themselves; returns [ModName] + changed = [f | (f,(_,True)) <- sfiles] + + -- add other files that depend on some changed file; returns [ModName] + iter np = let new = [f | ((f,fs),_) <- deps, + not (elem f np), any (flip elem np) fs] + in if null new then np else (iter (new ++ np)) + + -- for each module in the full list, choose source file if change is needed + -- returns [FullPath] + mark cs = [f' | (f,(file,_)) <- sfiles, + let f' = if (elem f cs) then gfFile (fileBody file) else file] + + -- if the top file is gfc, only gfc files need be read (could be even better)--- + filt ds = if isGFC (last ds) + then [gfcFile name | f <- ds, + let (name,suff) = nameAndSuffix f, elem suff ["gfc","gfr"]] + else ds + +isGFC = (== "gfc") . fileSuffix + +gfcFile = suffixFile "gfc" +gfrFile = suffixFile "gfr" +gfFile = suffixFile "gf" + +-- to get imports without parsing the file + +importsOfFile :: String -> [FilePath] +importsOfFile = + filter (not . spec) . -- ignore keywords and special symbols + unqual . -- take away qualifiers + takeWhile (not . term) . -- read until curly or semic + drop 2 . -- ignore keyword and module name + lexs . -- analyse into lexical tokens + unComm -- ignore comments before the headed line + where + term = flip elem ["{",";"] + spec = flip elem ["of", "open","in", "reuse", "=", "(", ")",",","**"] + unqual ws = case ws of + "(":q:ws' -> unqual ws' + w:ws' -> w:unqual ws' + _ -> ws + +unComm s = case s of + '-':'-':cs -> unComm $ dropWhile (/='\n') cs + '{':'-':cs -> dpComm cs + c:cs -> c : unComm cs + _ -> s + +dpComm s = case s of + '-':'}':cs -> unComm cs + c:cs -> dpComm cs + _ -> s + +lexs s = x:xs where + (x,y) = head $ lex s + xs = if null y then [] else lexs y + +-- old GF tolerated newlines in quotes. No more supported! +fixNewlines s = case s of + '"':cs -> '"':mk cs + c :cs -> c:fixNewlines cs + _ -> s + where + mk s = case s of + '\\':'"':cs -> '\\':'"': mk cs + '"' :cs -> '"' :fixNewlines cs + '\n' :cs -> '\\':'n': mk cs + c :cs -> c : mk cs + _ -> s + diff --git a/src/GF/Infra/UseIO.hs b/src/GF/Infra/UseIO.hs new file mode 100644 index 000000000..bd9d9e22a --- /dev/null +++ b/src/GF/Infra/UseIO.hs @@ -0,0 +1,245 @@ +module UseIO where + +import Operations +import Arch (prCPU) +import Option + +import IO +import System +import Monad + +putShow' :: Show a => (c -> a) -> c -> IO () +putShow' f = putStrLn . show . length . show . f + +putIfVerb opts msg = + if oElem beVerbose opts + then putStrLn msg + else return () + +putIfVerbW opts msg = + if oElem beVerbose opts + then putStr (' ' : msg) + else return () + +-- obsolete with IOE monad +errIO :: a -> Err a -> IO a +errIO = errOptIO noOptions + +errOptIO :: Options -> a -> Err a -> IO a +errOptIO os e m = case m of + Ok x -> return x + Bad k -> do + putIfVerb os k + return e + +prOptCPU opts = if (oElem noCPU opts) then (const (return 0)) else prCPU + +putCPU = do + prCPU 0 + return () + +putPoint :: Show a => Options -> String -> IO a -> IO a +putPoint = putPoint' id + +putPoint' :: Show a => (c -> a) -> Options -> String -> IO c -> IO c +putPoint' f opts msg act = do + let sil x = if oElem beSilent opts then return () else x + ve x = if oElem beVerbose opts then x else return () + ve $ putStrLn msg + a <- act + ve $ putShow' f a + ve $ putCPU + return a + +readFileIf :: String -> IO String +readFileIf f = catch (readFile f) (\_ -> reportOn f) where + reportOn f = do + putStrLnFlush ("File " ++ f ++ " does not exist. Returned empty string") + return "" + +getFilePath :: [FilePath] -> String -> IO (Maybe FilePath) +getFilePath paths file = get paths where + get [] = putStrLnFlush ("file" +++ file +++ "not found") >> return Nothing + get (p:ps) = let pfile = prefixPathName p file in + catch (readFile pfile >> return (Just pfile)) (\_ -> get ps) + +readFileIfPath :: [FilePath] -> String -> IOE (FilePath,String) +readFileIfPath paths file = do + mpfile <- ioeIO $ getFilePath paths file + case mpfile of + Just pfile -> do + s <- ioeIO $ readFile pfile + return (justInitPath pfile,s) + _ -> ioeErr $ Bad ("File " ++ file ++ " does not exist.") + +pFilePaths :: String -> [FilePath] +pFilePaths s = case span (/=':') s of + (f,_:cs) -> f : pFilePaths cs + (f,_) -> [f] + +prefixPathName :: String -> FilePath -> FilePath +prefixPathName "" f = f +prefixPathName p f = p ++ "/" ++ f + +justInitPath :: FilePath -> FilePath +justInitPath = reverse . drop 1 . dropWhile (/='/') . reverse + +nameAndSuffix :: FilePath -> (String,String) +nameAndSuffix file = case span (/='.') (reverse file) of + (_,[]) -> (file,[]) + (xet,deman) -> if elem '/' xet + then (file,[]) + else (reverse $ drop 1 deman,reverse xet) + +unsuffixFile, fileBody :: FilePath -> String +unsuffixFile = fst . nameAndSuffix +fileBody = unsuffixFile + +fileSuffix :: FilePath -> String +fileSuffix = snd . nameAndSuffix + +justFileName :: FilePath -> String +justFileName = reverse . takeWhile (/='/') . reverse + +suffixFile :: String -> FilePath -> FilePath +suffixFile suff file = file ++ "." ++ suff + +-- + +getLineWell :: IO String -> IO String +getLineWell ios = + catch getLine (\e -> if (isEOFError e) then ios else ioError e) + +putStrFlush :: String -> IO () +putStrFlush s = putStr s >> hFlush stdout + +putStrLnFlush :: String -> IO () +putStrLnFlush s = putStrLn s >> hFlush stdout + +-- a generic quiz session + +type QuestionsAndAnswers = [(String, String -> (Integer,String))] + +teachDialogue :: QuestionsAndAnswers -> String -> IO () +teachDialogue qas welc = do + putStrLn $ welc ++++ genericTeachWelcome + teach (0,0) qas + where + teach _ [] = do putStrLn "Sorry, ran out of problems" + teach (score,total) ((question,grade):quas) = do + putStr ("\n" ++ question ++ "\n> ") + answer <- getLine + if (answer == ".") then return () else do + let (result, feedback) = grade answer + score' = score + result + total' = total + 1 + putStr (feedback ++++ "Score" +++ show score' ++ "/" ++ show total') + if (total' > 9 && fromInteger score' / fromInteger total' >= 0.75) + then do putStrLn "\nCongratulations - you passed!" + else teach (score',total') quas + + genericTeachWelcome = + "The quiz is over when you have done at least 10 examples" ++++ + "with at least 75 % success." +++++ + "You can interrupt the quiz by entering a line consisting of a dot ('.').\n" + + +-- IO monad with error; adapted from state monad + +newtype IOE a = IOE (IO (Err a)) + +appIOE :: IOE a -> IO (Err a) +appIOE (IOE iea) = iea + +ioe :: IO (Err a) -> IOE a +ioe = IOE + +ioeIO :: IO a -> IOE a +ioeIO io = ioe (io >>= return . return) + +ioeErr :: Err a -> IOE a +ioeErr = ioe . return + +instance Monad IOE where + return a = ioe (return (return a)) + IOE c >>= f = IOE $ do + x <- c -- Err a + appIOE $ err ioeBad f x -- f :: a -> IOE a + +ioeBad :: String -> IOE a +ioeBad = ioe . return . Bad + +useIOE :: a -> IOE a -> IO a +useIOE a ioe = appIOE ioe >>= err (\s -> putStrLn s >> return a) return + +putStrLnE :: String -> IOE () +putStrLnE = ioeIO . putStrLnFlush + +putStrE :: String -> IOE () +putStrE = ioeIO . putStrFlush + +putPointE :: Options -> String -> IOE a -> IOE a +putPointE opts msg act = do + let ve x = if oElem beVerbose opts then x else return () + ve $ ioeIO $ putStrFlush msg + a <- act +--- ve $ ioeIO $ putShow' id a --- replace by a statistics command + ve $ ioeIO $ putStrFlush " " + ve $ ioeIO $ putCPU + return a +{- +putPointE :: Options -> String -> IOE a -> IOE a +putPointE opts msg act = do + let ve x = if oElem beVerbose opts then x else return () + ve $ putStrE msg + a <- act +--- ve $ ioeIO $ putShow' id a --- replace by a statistics command + ve $ ioeIO $ putCPU + return a +-} + +-- forces verbosity +putPointEVerb :: Options -> String -> IOE a -> IOE a +putPointEVerb opts = putPointE (addOption beVerbose opts) + +-- ((do {s <- readFile f; return (return s)}) ) +readFileIOE :: FilePath -> IOE (String) +readFileIOE f = ioe $ catch (readFile f >>= return . return) + (\_ -> return (Bad (reportOn f))) where + reportOn f = "File " ++ f ++ " not found." + +-- like readFileIOE but look also in the GF library if file not found +-- intended semantics: if file is not found, try $GF_LIB_PATH/file +-- (even if file is an absolute path, but this should always fail) +-- it returns not only contents of the file, but also the path used +readFileLibraryIOE :: String -> FilePath -> IOE (FilePath, String) +readFileLibraryIOE ini f = + ioe $ catch ((do {s <- readFile initPath; return (return (initPath,s))})) + (\_ -> tryLibrary ini f) where + tryLibrary :: String -> FilePath -> IO (Err (FilePath, String)) + tryLibrary ini f = + catch (do { + lp <- getLibPath; + s <- readFile (lp ++ f); + return (return (lp ++ f, s)) + }) (\_ -> return (Bad (reportOn f))) + initPath = addInitFilePath ini f + getLibPath :: IO String + getLibPath = do { + lp <- getEnv "GF_LIB_PATH"; + return (if last lp == '/' then lp else lp ++ ['/']); + } + reportOn f = "File " ++ f ++ " not found." + libPath ini f = f + addInitFilePath ini file = case file of + '/':_ -> file -- absolute path name + _ -> ini ++ file -- relative path name + + +-- example +koeIOE :: IO () +koeIOE = useIOE () $ do + s <- ioeIO $ getLine + s2 <- ioeErr $ mapM (!? 2) $ words s + ioeIO $ putStrLn s2 + diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs new file mode 100644 index 000000000..6e4afe88f --- /dev/null +++ b/src/GF/Shell.hs @@ -0,0 +1,292 @@ +module Shell where + +--- abstract away from these? +import Str +import qualified Grammar as G +import qualified Ident as I +import qualified Compute as Co +import qualified GFC +import Values +import GetTree + +import API +import IOGrammar +import Compile +---- import GFTex +-----import TeachYourself -- also a subshell + +import ShellState +import Option +import Information +import HelpFile +import PrOld +import PrGrammar + +import Monad (foldM) +import System (system) + +import Operations +import UseIO +import UTF8 (encodeUTF8) + + +---- import qualified GrammarToGramlet as Gr +---- import qualified GrammarToCanonXML2 as Canon + +-- AR 18/4/2000 - 7/11/2001 + +type SrcTerm = G.Term -- term as returned by the command parser + +data Command = + CImport FilePath + | CRemoveLanguage Language + | CEmptyState + | CTransformGrammar FilePath + | CConvertLatex FilePath + + | CLinearize [()] ---- parameters + | CParse + | CTranslate Language Language + | CGenerateRandom Int + | CPutTerm + | CWrapTerm Ident + | CMorphoAnalyse + | CTestTokenizer + | CComputeConcrete I.Ident String + + | CTranslationQuiz Language Language + | CTranslationList Language Language Int + | CMorphoQuiz + | CMorphoList Int + + | CReadFile FilePath + | CWriteFile FilePath + | CAppendFile FilePath + | CSpeakAloud + | CPutString + | CShowTerm + | CSystemCommand String + + | CSetFlag + | CSetLocalFlag Language + + | CPrintGrammar + | CPrintGlobalOptions + | CPrintLanguages + | CPrintInformation I.Ident + | CPrintMultiGrammar + | CPrintGramlet + | CPrintCanonXML + | CPrintCanonXMLStruct + | CPrintHistory + | CHelp + + | CImpure ImpureCommand + + | CVoid + +-- to isolate the commands that are executed on top level +data ImpureCommand = + ICQuit | ICExecuteHistory FilePath | ICEarlierCommand Int + | ICEditSession | ICTranslateSession + +type CommandLine = (CommandOpt, CommandArg, [CommandOpt]) + +type CommandOpt = (Command, Options) + +type HState = (ShellState,([String],Integer)) -- history & CPU + +type ShellIO = (HState, CommandArg) -> IO (HState, CommandArg) + +initHState :: ShellState -> HState +initHState st = (st,([],0)) + +cpuHState (_,(_,i)) = i +optsHState (st,_) = globalOptions st +putHStateCPU cpu (st,(h,_)) = (st,(h,cpu)) +updateHistory s (st,(h,cpu)) = (st,(s:h,cpu)) +earlierCommandH (_,(h,_)) = ((h ++ repeat "") !!) -- empty command if index over + +execLinesH :: String -> [CommandLine] -> HState -> IO HState +execLinesH s cs hst@(st, (h, _)) = do + (_,st') <- execLines True cs hst + cpu <- prOptCPU (optsHState st') (cpuHState hst) + return $ putHStateCPU cpu $ updateHistory s st' + +ifImpure :: [CommandLine] -> Maybe (ImpureCommand,Options) +ifImpure cls = foldr (const . Just) Nothing [(c,os) | ((CImpure c,os),_,_) <- cls] + +-- the main function: execution of commands. put :: Bool forces immediate output + +-- command line with consecutive (;) commands: no value transmitted +execLines :: Bool -> [CommandLine] -> HState -> IO ([String],HState) +execLines put cs st = foldM (flip (execLine put)) ([],st) cs + +-- command line with piped (|) commands: no value returned +execLine :: Bool -> CommandLine -> ([String],HState) -> IO ([String],HState) +execLine put (c@(co, os), arg, cs) (outps,st) = do + (st',val) <- execC c (st, arg) + let tr = oElem doTrace os || null cs -- option -tr leaves trace in pipe + utf = if (oElem useUTF8 os) then encodeUTF8 else id + outp = if tr then [utf (prCommandArg val)] else [] + if put then mapM_ putStrLnFlush outp else return () + execs cs val (if put then [] else outps ++ outp, st') + where + execs [] arg st = return st + execs (c:cs) arg st = execLine put (c, arg, cs) st + +-- individual commands possibly piped: value returned; this is not a state monad +execC :: CommandOpt -> ShellIO +execC co@(comm, opts0) sa@((st,(h,_)),a) = case comm of + + --- read old GF and write into files; no update of st yet + CImport file | oElem showOld opts -> useIOE sa $ batchCompileOld file >> return sa + + CImport file -> useIOE sa $ do + st <- shellStateFromFiles opts st file + ioeIO $ changeState (const st) sa --- \ ((_,h),a) -> ((st,h), a)) + CEmptyState -> changeState reinitShellState sa + +{- + CRemoveLanguage lan -> changeState (removeLanguage lan) sa + CTransformGrammar file -> do + s <- transformGrammarFile opts file + returnArg (AString s) sa + CConvertLatex file -> do + s <- readFileIf file + returnArg (AString (convertGFTex s)) sa +-} + CPrintHistory -> (returnArg $ AString $ unlines $ reverse h) sa + -- good to have here for piping; eh and ec must be done on outer level + + CLinearize [] -> changeArg (opTS2CommandArg (optLinearizeTreeVal opts gro) . s2t) sa +---- CLinearize m -> changeArg (opTS2CommandArg (optLinearizeArgForm opts gro m)) sa + + CParse -> case optParseArgErrMsg opts gro (prCommandArg a) of + Ok (ts,msg) -> putStrLnFlush msg >> changeArg (const $ ATrms ts) sa + Bad msg -> changeArg (const $ AError msg) sa + + CTranslate il ol -> do + let a' = opST2CommandArg (optParseArgErr opts (sgr il)) a + returnArg (opTS2CommandArg (optLinearizeTreeVal opts (sgr ol)) a') sa + CGenerateRandom n -> do + ts <- randomTreesIO opts gro (optIntOrN opts flagNumber n) + returnArg (ATrms ts) sa +----- CPutTerm -> changeArg (opTT2CommandArg (optTermCommand opts gro) . s2t) sa +----- CWrapTerm f -> changeArg (opTT2CommandArg (return . wrapByFun opts gro f)) sa + CMorphoAnalyse -> changeArg (AString . morphoAnalyse opts gro . prCommandArg) sa + CTestTokenizer -> changeArg (AString . optTokenizer opts gro . prCommandArg) sa + + CComputeConcrete m t -> + justOutput (putStrLn (err id prt ( + string2srcTerm src m t >>= Co.computeConcrete src))) sa + +{- ---- + CTranslationQuiz il ol -> justOutput (teachTranslation opts (sgr il) (sgr ol)) sa + CTranslationList il ol n -> do + qs <- transTrainList opts (sgr il) (sgr ol) (toInteger n) + returnArg (AString $ foldr (+++++) [] [unlines (s:ss) | (s,ss) <- qs]) sa + + CMorphoQuiz -> justOutput (teachMorpho opts gro) sa + CMorphoList n -> do + qs <- useIOE [] $ morphoTrainList opts gro (toInteger n) + returnArg (AString $ foldr (+++++) [] [unlines (s:ss) | (s,ss) <- qs]) sa +-} + CReadFile file -> returnArgIO (readFileIf file >>= return . AString) sa + CWriteFile file -> justOutputArg (writeFile file) sa + CAppendFile file -> justOutputArg (appendFile file) sa + CSpeakAloud -> justOutputArg (speechGenerate opts) sa + CSystemCommand s -> justOutput (system s >> return ()) sa +----- CPutString -> changeArg (opSS2CommandArg (optStringCommand opts gro)) sa +----- CShowTerm -> changeArg (opTS2CommandArg (optPrintTerm opts gro) . s2t) sa + + CSetFlag -> changeState (addGlobalOptions opts0) sa +---- deprec! CSetLocalFlag lang -> changeState (addLocalOptions lang opts0) sa + + CHelp -> returnArg (AString txtHelpFile) sa + + CPrintGrammar + | oElem showOld opts -> returnArg (AString $ printGrammarOld (canModules st)) sa + | otherwise -> returnArg (AString (optPrintGrammar opts gro)) sa + CPrintGlobalOptions -> justOutput (putStrLn $ prShellStateInfo st) sa + CPrintInformation c -> justOutput (useIOE () $ showInformation opts st c) sa + CPrintLanguages -> justOutput + (putStrLn $ unwords $ map prLanguage $ allLanguages st) sa +---- CPrintMultiGrammar -> returnArg (AString (prMultiGrammar opts st)) sa +---- CPrintGramlet -> returnArg (AString (Gr.prGramlet st)) sa +---- CPrintCanonXML -> returnArg (AString (Canon.prCanonXML st False)) sa +---- CPrintCanonXMLStruct -> returnArg (AString (Canon.prCanonXML st True)) sa + _ -> justOutput (putStrLn "command not understood") sa + + where + sgr = stateGrammarOfLang st + gro = grammarOfOptState opts st + opts = addOptions opts0 (globalOptions st) + src = srcModules st + + s2t a = case a of + ASTrm s -> err AError (ATrms . return) $ string2treeErr gro s + _ -> a + + +-- commands either change the state or process the argument, but not both +-- some commands just do output + +changeState :: ShellStateOper -> ShellIO +changeState f ((st,h),a) = return ((f st,h), a) + +changeArg :: (CommandArg -> CommandArg) -> ShellIO +changeArg f (st,a) = return (st, f a) + +changeArgMsg :: (CommandArg -> (CommandArg,String)) -> ShellIO +changeArgMsg f (st,a) = do + let (b,msg) = f a + putStrLnFlush msg + return (st, b) + +returnArg :: CommandArg -> ShellIO +returnArg = changeArg . const + +returnArgIO :: IO CommandArg -> ShellIO +returnArgIO io (st,_) = io >>= (\a -> return (st,a)) + +justOutputArg :: (String -> IO ()) -> ShellIO +justOutputArg f sa@(st,a) = f (prCommandArg a) >> return (st, AUnit) + +justOutput :: IO () -> ShellIO +justOutput = justOutputArg . const + +-- type system for command arguments; instead of plain strings... + +data CommandArg = + AError String + | ATrms [Tree] + | ASTrm String -- to receive from parser + | AStrs [Str] + | AString String + | AUnit + deriving (Eq, Show) + +prCommandArg :: CommandArg -> String +prCommandArg arg = case arg of + AError s -> s + AStrs ss -> sstrV ss + AString s -> s + ATrms [] -> "no tree found" + ATrms tt -> unlines $ map prt_Tree tt + ASTrm s -> s + AUnit -> "" + +opSS2CommandArg :: (String -> String) -> CommandArg -> CommandArg +opSS2CommandArg f = AString . f . prCommandArg + +opST2CommandArg :: (String -> Err [Tree]) -> CommandArg -> CommandArg +opST2CommandArg f = err AError ATrms . f . prCommandArg + +opTS2CommandArg :: (Tree -> String) -> CommandArg -> CommandArg +opTS2CommandArg f (ATrms ts) = AString $ unlines $ map f ts +opTS2CommandArg _ _ = AError ("expected term") + +opTT2CommandArg :: (Tree -> [Tree]) -> CommandArg -> CommandArg +opTT2CommandArg f (ATrms ts) = ATrms $ concat $ map f ts +opTT2CommandArg _ _ = AError ("expected term") diff --git a/src/GF/Shell/CommandL.hs b/src/GF/Shell/CommandL.hs new file mode 100644 index 000000000..463b3d4e4 --- /dev/null +++ b/src/GF/Shell/CommandL.hs @@ -0,0 +1,135 @@ +module CommandL where + +import Operations +import UseIO + +import CMacros + +import GetTree +import ShellState +import Option +import Session +import Commands + +import Char +import List (intersperse) + +import UTF8 + +-- a line-based shell + +initEditLoop :: CEnv -> IO () -> IO () +initEditLoop env resume = do + let env' = addGlobalOptions (options [sizeDisplay "short"]) env + putStrLnFlush $ initEditMsg env' + let state = initSStateEnv env' + putStrLnFlush $ showCurrentState env' state + editLoop env' state resume + +editLoop :: CEnv -> SState -> IO () -> IO () +editLoop env state resume = do + putStrFlush "edit> " + c <- getCommand + if (isQuit c) then resume else do + (env',state') <- execCommand env c state + let package = case c of + CCEnvEmptyAndImport _ -> initEditMsgEmpty env' + _ -> showCurrentState env' state' + putStrLnFlush package + + editLoop env' state' resume + +getCommand :: IO Command +getCommand = do + s <- getLine + return $ pCommand s + +getCommandUTF :: IO Command +getCommandUTF = do + s <- getLine + return $ pCommand s -- the GUI is doing this: $ decodeUTF8 s + +pCommand = pCommandWords . words where + pCommandWords s = case s of + "n" : cat : _ -> CNewCat (strings2Cat cat) + "t" : ws -> CNewTree $ unwords ws + "g" : ws -> CRefineWithTree $ unwords ws -- *g*ive + "p" : ws -> CRefineParse $ unwords ws + ">" : i : _ -> CAhead $ readIntArg i + ">" : [] -> CAhead 1 + "<" : i : _ -> CBack $ readIntArg i + "<" : [] -> CBack 1 + ">>" : _ -> CNextMeta + "<<" : _ -> CPrevMeta + "'" : _ -> CTop + "+" : _ -> CLast + "r" : f : _ -> CRefineWithAtom f + "w" : f:i : _ -> CWrapWithFun (strings2Fun f, readIntArg i) + "ch": f : _ -> CChangeHead (strings2Fun f) + "ph": _ -> CPeelHead + "x" : ws -> CAlphaConvert $ unwords ws + "s" : i : _ -> CSelectCand (readIntArg i) + "f" : "unstructured" : _ -> CRemoveOption showStruct --- hmmm + "f" : "structured" : _ -> CAddOption showStruct --- hmmm + "f" : s : _ -> CAddOption (filterString s) + "u" : _ -> CUndo + "d" : _ -> CDelete + "c" : s : _ -> CTermCommand s + "a" : _ -> CRefineRandom --- *a*leatoire + "m" : _ -> CMenu +---- "ml" : s : _ -> changeMenuLanguage s +---- "ms" : s : _ -> changeMenuSize s +---- "mt" : s : _ -> changeMenuTyped s + "v" : _ -> CView + "q" : _ -> CQuit + "h" : _ -> CHelp initEditMsg + + "i" : file: _ -> CCEnvImport file + "e" : [] -> CCEnvEmpty + "e" : file: _ -> CCEnvEmptyAndImport file + + "open" : f: _ -> CCEnvOpenTerm f + "openstring": f: _ -> CCEnvOpenString f + + "on" :lang: _ -> CCEnvOn lang + "off":lang: _ -> CCEnvOff lang + "pfile" :f:_ -> CCEnvRefineParse f + "tfile" :f:_ -> CCEnvRefineWithTree f + +-- openstring file +-- pfile file +-- tfile file +-- on lang +-- off lang + + "gf": comm -> CCEnvGFShell (unwords comm) + + [] -> CVoid + _ -> CError + +-- well, this lists the commands of the line-based editor +initEditMsg env = unlines $ + "State-dependent editing commands are given in the menu:" : + " n = new, r = refine, w = wrap, d = delete, s = select." : + "Commands changing the environment:" : + " i [file] = import, e = empty." : + "Other commands:" : + " a = random, v = change view, u = undo, h = help, q = quit," : + " ml [Lang] = change menu language," : + " ms (short | long) = change menu command size," : + " mt (typed | untyped) = change menu item typing," : + " p [string] = refine by parsing, g [term] = refine by term," : + " > = down, < = up, ' = top, >> = next meta, << = previous meta." : +---- (" c [" ++ unwords (intersperse "|" allTermCommands) ++ "] = modify term") : +---- (" f [" ++ unwords (intersperse "|" allStringCommands) ++ "] = modify output") : + [] + +initEditMsgEmpty env = initEditMsg env +++++ unlines ( + "Start editing by n Cat selecting category\n\n" : + "-------------\n" : + ["n" +++ cat | (_,cat) <- newCatMenu env] + ) + +showCurrentState env' state' = + unlines (tr ++ ["",""] ++ msg ++ ["",""] ++ map fst menu) + where (tr,msg,menu) = displaySStateIn env' state' diff --git a/src/GF/Shell/Commands.hs b/src/GF/Shell/Commands.hs new file mode 100644 index 000000000..5c92c7bd6 --- /dev/null +++ b/src/GF/Shell/Commands.hs @@ -0,0 +1,443 @@ +module Commands where + +import Operations +import Zipper + +----import AccessGrammar (Term (Vr)) ---- +import qualified Grammar as G ---- Cat +import GFC +import qualified AbsGFC ---- Atom +import CMacros +import LookAbs + +import GetTree +import API +import ShellState + +import qualified Shell +import qualified Ident as I +import qualified PShell +import qualified Macros as M +import PrGrammar +import TypeCheck ---- tree2exp +import PGrammar +import IOGrammar +import UseIO +import Unicode + +import Option +import CF +----- import CFIdent (cat2CFCat, cfCat2Cat) +import Linear +import Randomized +import Editing +import Session +import Custom + +import Random (mkStdGen) +import Monad (liftM2) +import List (intersperse) +import Random (newStdGen) + +--- temporary hacks for GF 2.0 + +-- abstract command language for syntax editing. AR 22/8/2001 + +data Command = + CNewCat G.Cat + | CNewTree String + | CAhead Int + | CBack Int + | CNextMeta + | CPrevMeta + | CTop + | CLast + | CRefineWithTree String + | CRefineWithAtom String + | CRefineParse String + | CWrapWithFun (G.Fun,Int) + | CChangeHead G.Fun + | CPeelHead + | CAlphaConvert String + | CRefineRandom + | CSelectCand Int + | CTermCommand String + | CAddOption Option + | CRemoveOption Option + | CDelete + | CUndo + | CView + | CMenu + | CQuit + | CHelp (CEnv -> String) -- help message depends on grammar and interface + | CError -- syntax error in command + | CVoid -- empty command, e.g. just <enter> + +-- commands affecting CEnv + | CCEnvImport String + | CCEnvEmptyAndImport String + | CCEnvOpenTerm String + | CCEnvOpenString String + | CCEnvEmpty + + | CCEnvOn String + | CCEnvOff String + + | CCEnvGFShell String + +-- other commands using IO + | CCEnvRefineWithTree String + | CCEnvRefineParse String + +isQuit CQuit = True +isQuit _ = False + +-- an abstract environment type + +type CEnv = ShellState + +grammarCEnv = firstStateGrammar +canCEnv = canModules +concreteCEnv = cncId +abstractCEnv = absId + +stdGenCEnv env s = mkStdGen (length (displayJustStateIn env s) * 31 +11) --- + +initSStateEnv env = case getOptVal (stateOptions sgr) gStartCat of +---- Just cat -> action2commandNext (newCat gr (identC cat)) initSState + _ -> initSState + where + sgr = firstStateGrammar env + gr = stateGrammarST sgr + +-- the main function + +execCommand :: CEnv -> Command -> SState -> IO (CEnv,SState) +execCommand env c s = case c of +{- ---- +-- these commands do need IO + CCEnvImport file -> do + + gr <- optFile2grammar noOptions (maybeStateAbstract env) file + let lan = getLangNameOpt noOptions file + return (updateLanguage file (lan, getStateConcrete gr) + (initWithAbstract (stateAbstract gr) env), s) + + CCEnvEmptyAndImport file -> do + gr <- optFile2grammar noOptions Nothing file + let lan = getLangNameOpt noOptions file + return (updateLanguage file (lan, getStateConcrete gr) + (initWithAbstract (stateAbstract gr) emptyShellState), initSState) + + CCEnvEmpty -> do + return (emptyShellState, initSState) + + CCEnvGFShell command -> do + let cs = PShell.pCommandLines command + (msg,(env',_)) <- Shell.execLines False cs (Shell.initHState env) + return (env', changeMsg msg s) ---- + + CCEnvOpenTerm file -> do + c <- readFileIf file + let (fs,t) = envAndTerm file c + + env' <- shellStateFromFiles noOptions fs + return (env', (action2commandNext $ \x -> + (string2treeErr (grammarCEnv env') t x >>= + \t -> newTree t x)) s) + + CCEnvOpenString file -> do + c <- readFileIf file + let (fs,t) = envAndTerm file c + env' <- shellStateFromFiles noOptions fs + let gr = grammarCEnv env' + sgr = firstStateGrammar env' + agrs = allActiveGrammars env' + cat = firstCatOpts (stateOptions sgr) sgr + state0 <- err (const $ return (stateSState s)) return $ + newCat gr (cfCat2Cat cat) $ stateSState s + state1 <- return $ + refineByExps True gr (parseAny agrs cat t) $ changeState state0 s + return (env', state1) + + CCEnvOn name -> return (languageOn (language name) env,s) + CCEnvOff name -> return (languageOff (language name) env,s) +-} +-- this command is improved by the use of IO + CRefineRandom -> do + g <- newStdGen + return (env, action2commandNext (refineRandom g 41 cgr) s) + +-- these commands use IO + CCEnvRefineWithTree file -> do + str <- readFileIf file + execCommand env (CRefineWithTree str) s + CCEnvRefineParse file -> do + str <- readFileIf file + execCommand env (CRefineParse str) s + +-- other commands don't need IO; they are available in the fudget + c -> return (env, execECommand env c s) + + where + gr = grammarCEnv env + cgr = canCEnv env + opts = globalOptions env + + -- format for documents: import lines of form "-- file", then term + envAndTerm f s = + (map ((initFilePath f ++) . filter (/=' ') . drop 2) fs, unlines ss) where + (fs,ss) = span isImport (lines s) + isImport l = take 2 l == "--" + + +execECommand :: CEnv -> Command -> ECommand +execECommand env c = case c of + CNewCat cat -> action2commandNext $ \x -> do + s' <- newCat cgr cat x + uniqueRefinements cgr s' +{- ---- + CNewTree s -> action2commandNext $ \x -> do + t <- string2treeErr gr s + s' <- newTree t x + uniqueRefinements cgr s' +-} + CAhead n -> action2command (goAheadN n) + CBack n -> action2command (goBackN n) + CTop -> action2command $ return . goRoot + CLast -> action2command $ goLast + CNextMeta -> action2command goNextNewMeta + CPrevMeta -> action2command goPrevNewMeta + CRefineWithAtom s -> action2commandNext $ \x -> do + t <- string2ref gr s + s' <- refineWithAtom der cgr t x + uniqueRefinements cgr s' + CWrapWithFun fi -> action2commandNext $ wrapWithFun cgr fi + CChangeHead f -> action2commandNext $ changeFunHead cgr f + CPeelHead -> action2commandNext $ peelFunHead cgr +{- ---- + CAlphaConvert s -> action2commandNext $ \x -> + string2varPair s >>= \xy -> alphaConvert gr xy x + + CRefineWithTree s -> action2commandNext $ \x -> + (string2treeErr gr s x >>= \t -> refineWithTree der gr t x) + + CRefineParse str -> \s -> refineByExps der gr + (parseAny agrs (cat2CFCat (actCat (stateSState s))) str) s +-} + + CRefineRandom -> \s -> action2commandNext + (refineRandom (stdGenCEnv env s) 41 cgr) s + + CSelectCand i -> selectCand cgr i +{- ---- + CTermCommand c -> case c of + "paraphrase" -> \s -> + replaceByTermCommand gr c (actExp (stateSState s)) s + "transfer" -> action2commandNext $ + transferSubTree (stateTransferFun sgr) gr + _ -> replaceByEditCommand gr c +-} +---- CAddOption o -> changeStOptions (addOption o) +---- CRemoveOption o -> changeStOptions (removeOption o) + CDelete -> action2commandNext $ deleteSubTree cgr + CUndo -> undoCommand +---- CMenu -> \s -> changeMsg (menuState env s) s + CView -> changeView + CHelp h -> changeMsg [h env] + CVoid -> id + _ -> changeMsg ["command not yet implemented"] + where + sgr = firstStateGrammar env + agrs = [sgr] ---- allActiveGrammars env + cgr = canCEnv env + gr = grammarCEnv env + der = maybe True not $ caseYesNo (globalOptions env) noDepTypes + -- if there are dep types, then derived refs; deptypes is the default + +-- + + +{- ---- +string2varPair :: String -> Err (I.Ident,I.Ident) +string2varPair s = case words s of + x : y : [] -> liftM2 (,) (string2ident x) (string2ident y) + _ -> Bad "expected format 'x y'" + + +-- seen on display + +cMenuDisplay :: String -> Command +cMenuDisplay s = CAddOption (menuDisplay s) +-} +newCatMenu env = [(CNewCat c, prQIdent c) | ---- printname env initSState c) | + (c,[]) <- allCatsOf (canCEnv env)] + +mkRefineMenu :: CEnv -> SState -> [(Command,String)] +mkRefineMenu env sstate = [(c,s) | (c,(s,_)) <- mkRefineMenuAll env sstate] + +mkRefineMenuAll :: CEnv -> SState -> [(Command,(String,String))] +mkRefineMenuAll env sstate = + case (refinementsState cgr state, candsSState sstate, wrappingsState cgr state) of + ([],[],wraps) -> + [(CWrapWithFun fi, prWrap fit) | fit@(fi,_) <- wraps] ++ + [(CChangeHead f, prChangeHead f) | f <- headChangesState cgr state] ++ + [(CPeelHead, (ifShort "ph" "PeelHead", "ph")) | canPeelState cgr state] ++ + [(CDelete, (ifShort "d" "Delete", "d"))] + (refs,[],_) -> [(CRefineWithAtom (prRefinement f), prRef t) | t@(f,_) <- refs] + (_,cands,_) -> [(CSelectCand i, prCand (t,i)) | (t,i) <- zip cands [0..]] + + where + prRef (f,t) = + (ifShort "r" "Refine" +++ prOrLinExp f +++ ifTyped (":" +++ prt t), + "r" +++ prRefinement f) + prChangeHead f = + (ifShort "ch" "ChangeHead" +++ prOrLinFun f, + "ch" +++ prQIdent f) + prWrap ((f,i),t) = + (ifShort "w" "Wrap" +++ prOrLinFun f +++ ifTyped (":" +++ prt t) +++ + ifShort (show i) (prBracket (show i)), + "w" +++ prQIdent f +++ show i) + prCand (t,i) = + (ifShort ("s" +++ prOrLinExp t) ("Select" +++ prOrLinExp t),"s" +++ show i) + + gr = grammarCEnv env + cgr = canCEnv env + state = stateSState sstate + opts = addOptions (optsSState sstate) (globalOptions env) + ifOpt f v a b = case getOptVal opts f of + Just s | s == v -> a + _ -> b + ifShort = ifOpt sizeDisplay "short" + ifTyped t = ifOpt typeDisplay "typed" t "" + prOrLinExp t = prRefinement t --- maybe (prt t) prOrLinFun $ M.justIdentOf t + prOrLinTree t = case getOptVal opts menuDisplay of + Just "Abs" -> prt t + Just lang -> optLinearizeTreeVal (addOption firstLin opts) + (stateGrammarOfLang env (language lang)) t + _ -> prt t + prOrLinFun = printname env sstate + +-- there are three orthogonal parameters: Abs/[conc], short/long, typed/untyped +-- the default is Abs, long, untyped; the Menus menu changes the parameter + +emptyMenuItem = (CVoid,("","")) + + + +---- allStringCommands = snd $ customInfo customStringCommand +termCommandMenu, stringCommandMenu :: [(Command,String)] +termCommandMenu = [] +stringCommandMenu = [] + +displayCommandMenu :: CEnv -> [(Command,String)] +displayCommandMenu env = [] +{- ---- +---- allTermCommands = snd $ customInfo customEditCommand +termCommandMenu = [(CTermCommand s, s) | s <- allTermCommands] + +stringCommandMenu = + (CAddOption showStruct, "structured") : + (CRemoveOption showStruct, "unstructured") : + [(CAddOption (filterString s), s) | s <- allStringCommands] + +displayCommandMenu env = + [(CAddOption (menuDisplay s), s) | s <- "Abs" : langs] ++ + [(CAddOption (sizeDisplay s), s) | s <- ["short", "long"]] ++ + [(CAddOption (typeDisplay s), s) | s <- ["typed", "untyped"]] + where + langs = map prLanguage $ allLanguages env + +changeMenuLanguage, changeMenuSize, changeMenuTyped :: String -> Command +changeMenuLanguage s = CAddOption (menuDisplay s) +changeMenuSize s = CAddOption (sizeDisplay s) +changeMenuTyped s = CAddOption (typeDisplay s) +-} + +menuState env = map snd . mkRefineMenu env + +prState :: State -> [String] +prState s = prMarkedTree (loc2treeMarked s) + +displayJustStateIn env state = case displaySStateIn env state of + (t,msg,_) -> unlines (t ++ ["",""] ++ msg) --- ad hoc for CommandF + +displaySStateIn env state = (tree',msg,menu) where + (tree,msg,menu) = displaySState env state + grs = allStateGrammars env + lang = (viewSState state) `mod` (length grs + 3) + tree' = (tree : exp : linAll ++ separ (linAll ++ [tree])) !! lang + opts = addOptions (optsSState state) (globalOptions env) -- state opts override + lin g = linearizeState fudWrap opts g zipper + exp = return $ tree2string $ loc2tree zipper + zipper = stateSState state + linAll = map lin grs + separ = singleton . map unlines . intersperse [replicate 72 '*'] + +displaySStateJavaX env state = unlines $ tagXML "gfedit" $ concat [ + tagXML "linearizations" (concat + [tagAttrXML "lin" ("lang", prLanguage lang) ss | (lang,ss) <- lins]), + tagXML "tree" tree, + tagXML "message" msg, + tagXML "menu" (tagsXML "item" menu') + ] + where + (tree,msg,menu) = displaySState env state + menu' = [tagXML "show" [s] ++ tagXML "send" [c] | (s,c) <- menu] + (ls,grs) = unzip $ lgrs + lgrs = allStateGrammarsWithNames env --- allActiveStateGrammarsWithNames env + lins = (langAbstract, exp) : linAll + opts = addOptions (optsSState state) (globalOptions env) -- state opts override + lin (n,gr) = (n, map uni $ linearizeState noWrap opts gr zipper) where + uni = optEncodeUTF8 n gr . mkUnicode + exp = prprTree $ loc2tree zipper +--- xml = prExpXML gr $ tree2exp $ loc2tree zipper --- better: dir. from zipper + zipper = stateSState state + linAll = map lin lgrs + gr = firstStateGrammar env + +langAbstract = language "Abstract" +langXML = language "XML" + + +linearizeState :: (String -> [String]) -> Options -> GFGrammar -> State -> [String] +linearizeState wrap opts gr = + wrap . strop . unt . optLinearizeTreeVal opts gr . loc2tree + --- markedLinString br g + where + unt = id ---- customOrDefault (stateOptions g) useUntokenizer customUntokenizer g + strop = id ---- maybe id ($ g) $ customAsOptVal opts filterString customStringCommand + br = oElem showStruct opts + +noWrap, fudWrap :: String -> [String] +noWrap = lines +fudWrap = lines . wrapLines 0 --- + +displaySState :: CEnv -> SState -> ([String],[String],[(String,String)]) +displaySState env state = + (prState (stateSState state), msgSState state, menuSState env state) + +menuSState :: CEnv -> SState -> [(String,String)] +menuSState env state = [(s,c) | (_,(s,c)) <- mkRefineMenuAll env state] + +printname :: CEnv -> SState -> G.Fun -> String +printname env state f = case getOptVal opts menuDisplay of + Just "Abs" -> prQIdent f +---- Just lang -> printn lang f + _ -> prQIdent f + where + opts = addOptions (optsSState state) (globalOptions env) + printn lang = linearize gr ---- printOrLinearize (grammarOfLang env (language lang)) + gr = grammarCEnv env + + +--- XML printing; does not belong here! + +tagsXML t = concatMap (tagXML t) +tagAttrXML t av ss = mkTagAttrXML t av : map (indent 2) ss ++ [mkEndTagXML t] +tagXML t ss = mkTagXML t : map (indent 2) ss ++ [mkEndTagXML t] +mkTagXML t = '<':t ++ ">" +mkEndTagXML t = mkTagXML ('/':t) +mkTagAttrsXML t avs = '<':t +++ unwords [a++"="++v | (a,v) <- avs] ++">" +mkTagAttrXML t av = mkTagAttrsXML t [av] + diff --git a/src/GF/Shell/JGF.hs b/src/GF/Shell/JGF.hs new file mode 100644 index 000000000..215ad3e3e --- /dev/null +++ b/src/GF/Shell/JGF.hs @@ -0,0 +1,59 @@ +module JGF where + +import Operations +import UseIO + +import IOGrammar +import Option +import ShellState +import Session +import Commands +import CommandL + +import System +import UTF8 + + +-- GF editing session controlled by e.g. a Java program. AR 16/11/2001 + +sessionLineJ :: ShellState -> IO () +sessionLineJ env = do + putStrLnFlush $ initEditMsgJavaX env + let env' = addGlobalOptions (options [sizeDisplay "short"]) env + editLoopJ env' (initSState) + +editLoopJ :: CEnv -> SState -> IO () +editLoopJ = editLoopJnewX + +-- this is the real version, with XML + +editLoopJnewX :: CEnv -> SState -> IO () +editLoopJnewX env state = do + c <- getCommandUTF + case c of + CQuit -> return () + + c -> do + (env',state') <- execCommand env c state + let package = case c of + CCEnvImport _ -> initAndEditMsgJavaX env' state' + CCEnvEmptyAndImport _ -> initAndEditMsgJavaX env' state' + CCEnvOpenTerm _ -> initAndEditMsgJavaX env' state' + CCEnvOpenString _ -> initAndEditMsgJavaX env' state' + CCEnvEmpty -> initEditMsgJavaX env' + _ -> displaySStateJavaX env' state' + putStrLnFlush package + editLoopJnewX env' state' + +welcome = + "An experimental GF Editor for Java." ++ + "(c) Kristofer Johannisson, Janna Khegai, and Aarne Ranta 2002 under CNU GPL." + +initEditMsgJavaX env = encodeUTF8 $ unlines $ tagXML "gfinit" $ + tagsXML "newcat" [["n" +++ cat] | (_,cat) <- newCatMenu env] ++ + tagXML "language" [prLanguage langAbstract] ++ + concat [tagAttrXML "language" ("file",file) [prLanguage lang] | + (file,lang) <- zip (allGrammarFileNames env) (allLanguages env)] + +initAndEditMsgJavaX env state = + initEditMsgJavaX env ++++ displaySStateJavaX env state diff --git a/src/GF/Shell/PShell.hs b/src/GF/Shell/PShell.hs new file mode 100644 index 000000000..f28218f27 --- /dev/null +++ b/src/GF/Shell/PShell.hs @@ -0,0 +1,115 @@ +module PShell where + +import Operations +import UseIO +import ShellState +import Shell +import Option +import PGrammar (pzIdent, pTrm) --- (string2formsAndTerm) +import API +import Arch(fetchCommand) +import Char (isDigit) + +-- parsing GF shell commands. AR 11/11/2001 + +-- getting a sequence of command lines as input + +getCommandLines :: IO (String,[CommandLine]) +getCommandLines = do + s <- fetchCommand "> " + return (s,pCommandLines s) + +pCommandLines :: String -> [CommandLine] +pCommandLines = map pCommandLine . concatMap (chunks ";;" . words) . lines + +pCommandLine :: [String] -> CommandLine +pCommandLine s = pFirst (chks s) where + pFirst cos = case cos of + (c,os,[a]) : cs -> ((c,os), a, pCont cs) + _ -> ((CVoid,noOptions), AError "no parse", []) + pCont cos = case cos of + (c,os,_) : cs -> (c,os) : pCont cs + _ -> [] + chks = map pCommandOpt . chunks "|" + +pCommandOpt :: [String] -> (Command, Options, [CommandArg]) +pCommandOpt (w:ws) = let + (os, co) = getOptions "-" ws + (comm, args) = pCommand (w:co) + in + (comm, os, args) +pCommandOpt s = (CVoid, noOptions, [AError "no parse"]) + +pInputString :: String -> [CommandArg] +pInputString s = case s of + ('"':_:_) -> [AString (init (tail s))] + _ -> [AError "illegal string"] + +pCommand :: [String] -> (Command, [CommandArg]) +pCommand ws = case ws of + + "i" : f : [] -> aUnit (CImport f) + "rl" : l : [] -> aUnit (CRemoveLanguage (language l)) + "e" : [] -> aUnit CEmptyState + "tg" : f : [] -> aUnit (CTransformGrammar f) + "cl" : f : [] -> aUnit (CConvertLatex f) + + "ph" : [] -> aUnit CPrintHistory + + "l" : s -> aTermLi CLinearize s + + "p" : s -> aString CParse s + "t" : i:o: s -> aString (CTranslate (language i) (language o)) s + "gr" : [] -> aUnit (CGenerateRandom 1) + "gr" : n : [] -> aUnit (CGenerateRandom (readIntArg n)) -- deprecated 12/5/2001 + "pt" : s -> aTerm CPutTerm s +----- "wt" : f : s -> aTerm (CWrapTerm (string2id f)) s + "ma" : s -> aString CMorphoAnalyse s + "tt" : s -> aString CTestTokenizer s + "cc" : m : s -> aUnit $ CComputeConcrete (pzIdent m) $ unwords s + + "tq" : i:o:[] -> aUnit (CTranslationQuiz (language i) (language o)) + "tl":i:o:n:[] -> aUnit (CTranslationList (language i) (language o) (readIntArg n)) + "mq" : [] -> aUnit CMorphoQuiz + "ml" : n : [] -> aUnit (CMorphoList (readIntArg n)) + + "wf" : f : s -> aString (CWriteFile f) s + "af" : f : s -> aString (CAppendFile f) s + "rf" : f : [] -> aUnit (CReadFile f) + "sa" : s -> aString CSpeakAloud s + "ps" : s -> aString CPutString s + "st" : s -> aTerm CShowTerm s + "!" : s -> aUnit (CSystemCommand (unwords s)) + + "sf" : l : [] -> aUnit (CSetLocalFlag (language l)) + "sf" : [] -> aUnit CSetFlag + + "pg" : [] -> aUnit CPrintGrammar + "pi" : c : [] -> aUnit $ CPrintInformation (pzIdent c) + + "pj" : [] -> aUnit CPrintGramlet + "pxs" : [] -> aUnit CPrintCanonXMLStruct + "px" : [] -> aUnit CPrintCanonXML + "pm" : [] -> aUnit CPrintMultiGrammar + "po" : [] -> aUnit CPrintGlobalOptions + "pl" : [] -> aUnit CPrintLanguages + "h" : [] -> aUnit CHelp + + "q" : [] -> aImpure ICQuit + "eh" : f : [] -> aImpure (ICExecuteHistory f) + n : [] | all isDigit n -> aImpure (ICEarlierCommand (readIntArg n)) + + "es" : [] -> aImpure ICEditSession + "ts" : [] -> aImpure ICTranslateSession + + _ -> (CVoid, []) + + where + aString c ss = (c, pInputString (unwords ss)) + aTerm c ss = (c, [ASTrm $ unwords ss]) ---- [ASTrms [s2t (unwords ss)]]) + aUnit c = (c, [AUnit]) + aImpure = aUnit . CImpure + + aTermLi c ss = (c [], [ASTrm $ unwords ss]) + ---- (c forms, [ASTrms [term]]) where + ---- (forms,term) = ([], s2t (unwords ss)) ---- string2formsAndTerm (unwords ss) diff --git a/src/GF/Shell/SubShell.hs b/src/GF/Shell/SubShell.hs new file mode 100644 index 000000000..c910d3dd0 --- /dev/null +++ b/src/GF/Shell/SubShell.hs @@ -0,0 +1,43 @@ +module SubShell where + +import Operations +import UseIO +import ShellState +import Option +import API + +import CommandL +import ArchEdit + +-- AR 20/4/2000 -- 12/11/2001 + +editSession :: Options -> ShellState -> IO () +editSession opts st + | oElem makeFudget opts = fudlogueEdit font st' + | otherwise = initEditLoop st' (return ()) + where + st' = addGlobalOptions opts st + font = maybe myUniFont mkOptFont $ getOptVal opts useFont + +myUniFont = "-mutt-clearlyu-medium-r-normal--0-0-100-100-p-0-iso10646-1" +mkOptFont = id +{- ---- +translateSession :: Options -> ShellState -> IO () +translateSession opts st = do + let grs = allStateGrammars st + cat = firstCatOpts opts (firstStateGrammar st) + trans = unlines . translateBetweenAll grs cat + translateLoop opts trans + +translateLoop opts trans = do + let fud = oElem makeFudget opts + font = maybe myUniFont mkOptFont $ getOptVal opts useFont + if fud then fudlogueWrite font trans else loopLine + where + loopLine = do + putStrFlush "trans> " + s <- getLine + if s == "." then return () else do + putStrLnFlush $ trans s + loopLine +-} diff --git a/src/GF/Source/AbsGF.hs b/src/GF/Source/AbsGF.hs new file mode 100644 index 000000000..16d342dd8 --- /dev/null +++ b/src/GF/Source/AbsGF.hs @@ -0,0 +1,242 @@ +module AbsGF where + +import Ident --H + +-- Haskell module generated by the BNF converter, except for --H + +-- newtype Ident = Ident String deriving (Eq,Ord,Show) --H + +newtype LString = LString String deriving (Eq,Ord,Show) + +data Grammar = + Gr [ModDef] + deriving (Eq,Ord,Show) + +data ModDef = + MMain Ident Ident [ConcSpec] + | MAbstract Ident Extend Opens [TopDef] + | MResource Ident Extend Opens [TopDef] + | MResourceInt Ident Extend Opens [TopDef] + | MResourceImp Ident Ident Opens [TopDef] + | MConcrete Ident Ident Extend Opens [TopDef] + | MConcreteInt Ident Ident Extend Opens [TopDef] + | MConcreteImp Open Ident Ident + | MTransfer Ident Open Open Extend Opens [TopDef] + | MReuseAbs Ident Ident + | MReuseCnc Ident Ident + | MReuseAll Ident Extend Ident + deriving (Eq,Ord,Show) + +data ConcSpec = + ConcSpec Ident ConcExp + deriving (Eq,Ord,Show) + +data ConcExp = + ConcExp Ident [Transfer] + deriving (Eq,Ord,Show) + +data Transfer = + TransferIn Open + | TransferOut Open + deriving (Eq,Ord,Show) + +data Extend = + Ext Ident + | NoExt + deriving (Eq,Ord,Show) + +data Opens = + NoOpens + | Opens [Open] + deriving (Eq,Ord,Show) + +data Open = + OName Ident + | OQual Ident Ident + deriving (Eq,Ord,Show) + +data Def = + DDecl [Ident] Exp + | DDef [Ident] Exp + | DPatt Ident [Patt] Exp + | DFull [Ident] Exp Exp + deriving (Eq,Ord,Show) + +data TopDef = + DefCat [CatDef] + | DefFun [FunDef] + | DefDef [Def] + | DefData [ParDef] + | DefTrans [FlagDef] + | DefPar [ParDef] + | DefOper [Def] + | DefLincat [PrintDef] + | DefLindef [Def] + | DefLin [Def] + | DefPrintCat [PrintDef] + | DefPrintFun [PrintDef] + | DefFlag [FlagDef] + | DefPrintOld [PrintDef] + | DefLintype [Def] + | DefPattern [Def] + deriving (Eq,Ord,Show) + +data CatDef = + CatDef Ident [DDecl] + deriving (Eq,Ord,Show) + +data FunDef = + FunDef [Ident] Exp + deriving (Eq,Ord,Show) + +data ParDef = + ParDef Ident [ParConstr] + | ParDefIndir Ident Ident + | ParDefAbs Ident + deriving (Eq,Ord,Show) + +data ParConstr = + ParConstr Ident [DDecl] + deriving (Eq,Ord,Show) + +data PrintDef = + PrintDef [Ident] Exp + deriving (Eq,Ord,Show) + +data FlagDef = + FlagDef Ident Ident + deriving (Eq,Ord,Show) + +data LocDef = + LDDecl [Ident] Exp + | LDDef [Ident] Exp + | LDFull [Ident] Exp Exp + deriving (Eq,Ord,Show) + +data Exp = + EIdent Ident + | EConstr Ident + | ECons Ident + | ESort Sort + | EString String + | EInt Integer + | EMeta + | EEmpty + | EStrings String + | ERecord [LocDef] + | ETuple [TupleComp] + | EIndir Ident + | ETyped Exp Exp + | EProj Exp Label + | EQConstr Ident Ident + | EQCons Ident Ident + | EApp Exp Exp + | ETable [Case] + | ETTable Exp [Case] + | ECase Exp [Case] + | EVariants [Exp] + | EPre Exp [Altern] + | EStrs [Exp] + | EConAt Ident Exp + | ESelect Exp Exp + | ETupTyp Exp Exp + | EExtend Exp Exp + | EAbstr [Bind] Exp + | ECTable [Bind] Exp + | EProd Decl Exp + | ETType Exp Exp + | EConcat Exp Exp + | EGlue Exp Exp + | ELet [LocDef] Exp + | EEqs [Equation] + | ELString LString + | ELin Ident + deriving (Eq,Ord,Show) + +data Patt = + PW + | PV Ident + | PCon Ident + | PQ Ident Ident + | PInt Integer + | PStr String + | PR [PattAss] + | PTup [PattTupleComp] + | PC Ident [Patt] + | PQC Ident Ident [Patt] + deriving (Eq,Ord,Show) + +data PattAss = + PA [Ident] Patt + deriving (Eq,Ord,Show) + +data Label = + LIdent Ident + | LVar Integer + deriving (Eq,Ord,Show) + +data Sort = + Sort_Type + | Sort_PType + | Sort_Tok + | Sort_Str + | Sort_Strs + deriving (Eq,Ord,Show) + +data PattAlt = + AltP Patt + deriving (Eq,Ord,Show) + +data Bind = + BIdent Ident + | BWild + deriving (Eq,Ord,Show) + +data Decl = + DDec [Bind] Exp + | DExp Exp + deriving (Eq,Ord,Show) + +data TupleComp = + TComp Exp + deriving (Eq,Ord,Show) + +data PattTupleComp = + PTComp Patt + deriving (Eq,Ord,Show) + +data Case = + Case [PattAlt] Exp + deriving (Eq,Ord,Show) + +data Equation = + Equ [Patt] Exp + deriving (Eq,Ord,Show) + +data Altern = + Alt Exp Exp + deriving (Eq,Ord,Show) + +data DDecl = + DDDec [Bind] Exp + | DDExp Exp + deriving (Eq,Ord,Show) + +data OldGrammar = + OldGr Include [TopDef] + deriving (Eq,Ord,Show) + +data Include = + NoIncl + | Incl [FileName] + deriving (Eq,Ord,Show) + +data FileName = + FString String + | FIdent Ident + | FSlash FileName + | FDot FileName + | FMinus FileName + | FAddId Ident FileName + deriving (Eq,Ord,Show) + diff --git a/src/GF/Source/CompileM.hs b/src/GF/Source/CompileM.hs new file mode 100644 index 000000000..3d97a029e --- /dev/null +++ b/src/GF/Source/CompileM.hs @@ -0,0 +1,141 @@ +module CompileM where + +import Grammar +import Ident +import Option +import PrGrammar +import Update +import Lookup +import Modules +---import Rename + +import Operations +import UseIO + +import Monad + +compileMGrammar :: Options -> SourceGrammar -> IOE SourceGrammar +compileMGrammar opts sgr = do + + ioeErr $ checkUniqueModuleNames sgr + + deps <- ioeErr $ moduleDeps sgr + + deplist <- either return + (\ms -> ioeBad $ "circular modules" +++ unwords (map show ms)) $ + topoTest deps + + let deps' = closureDeps deps + + foldM (compileModule opts deps' sgr) emptyMGrammar deplist + +checkUniqueModuleNames :: MGrammar i f a r c -> Err () +checkUniqueModuleNames gr = do + let ms = map fst $ tree2list $ modules gr + msg = checkUnique ms + if null msg then return () else Bad $ unlines msg + +-- to decide what modules immediately depend on what, and check if the +-- dependencies are appropriate + +moduleDeps :: MGrammar i f a c r -> Err Dependencies +moduleDeps gr = mapM deps $ tree2list $ modules gr where + deps (c,mi) = errIn ("checking dependencies of module" +++ prt c) $ case mi of + ModAbs m -> chDep (IdentM c MTAbstract) + (extends m) MTAbstract (opens m) MTAbstract + ModRes m -> chDep (IdentM c MTResource) + (extends m) MTResource (opens m) MTResource + ModCnc m -> do + a:ops <- case opens m of + os@(_:_) -> return os + _ -> Bad "no abstract indicated for concrete module" + aty <- lookupModuleType gr a + testErr (aty == MTAbstract) "the for-module is not an abstract syntax" + chDep (IdentM c (MTConcrete a)) (extends m) MTResource ops MTResource + + chDep it es ety os oty = do + ests <- mapM (lookupModuleType gr) es + testErr (all (==ety) ests) "inappropriate extension module type" + osts <- mapM (lookupModuleType gr) os + testErr (all (==oty) osts) "inappropriate open module type" + return (it, [IdentM e ety | e <- es] ++ [IdentM o oty | o <- os]) + +type Dependencies = [(IdentM Ident,[IdentM Ident])] + +---compileModule :: Options -> Dependencies -> SourceGrammar -> +--- CanonGrammar -> IdentM -> IOE CanonGrammar +compileModule opts deps sgr cgr i = do + + let name = identM i + + testIfCompiled deps name + + mi <- ioeErr $ lookupModule sgr name + + mi' <- case typeM i of + -- previously compiled cgr used as symbol table + MTAbstract -> compileAbstract cgr mi + MTResource -> compileResource cgr mi + MTConcrete a -> compileConcrete a cgr mi + + ifIsOpt doOutput $ writeCanonFile name mi' + + return $ addModule cgr name mi' + + where + + ifIsOpt o f = if (oElem o opts) then f else return () + doOutput = iOpt "o" + + +testIfCompiled :: Dependencies -> Ident -> IOE Bool +testIfCompiled _ _ = return False ---- + +---writeCanonFile :: Ident -> CanonModInfo -> IOE () +writeCanonFile name mi' = ioeIO $ writeFile (canonFileName name) [] ---- + +canonFileName n = n ++ ".gfc" ---- elsewhere! + +---compileAbstract :: CanonGrammar -> SourceModInfo -> IOE CanonModInfo +compileAbstract can (ModAbs m0) = do + let m1 = renameMAbstract m0 +{- + checkUnique + typeCheck + generateCode + addToCanon +-} + ioeBad "compile abs not yet" + +---compileResource :: CanonGrammar -> SourceModInfo -> IOE CanonModInfo +compileResource can md = do +{- + checkUnique + typeCheck + topoSort + compileOpers -- conservative, since more powerful than lin + generateCode + addToCanon +-} + ioeBad "compile res not yet" + +---compileConcrete :: Ident -> CanonGrammar -> SourceModInfo -> IOE CanonModInfo +compileConcrete ab can md = do +{- + checkUnique + checkComplete ab + typeCheck + topoSort + compileOpers + optimize + createPreservedOpers + generateCode + addToCanon +-} + ioeBad "compile cnc not yet" + + +-- to be imported + +closureDeps :: [(a,[a])] -> [(a,[a])] +closureDeps ds = ds ---- fix-point iteration diff --git a/src/GF/Source/GrammarToSource.hs b/src/GF/Source/GrammarToSource.hs new file mode 100644 index 000000000..6303bcd99 --- /dev/null +++ b/src/GF/Source/GrammarToSource.hs @@ -0,0 +1,181 @@ +module GrammarToSource where + +import Operations +import Grammar +import Modules +import Option +import qualified AbsGF as P +import Ident + +-- AR 13/5/2003 +-- translate internal to parsable and printable source + +trGrammar :: SourceGrammar -> P.Grammar +trGrammar (MGrammar ms) = P.Gr (map trModule ms) -- no includes + +trModule :: (Ident,SourceModInfo) -> P.ModDef +trModule (i,mo) = case mo of + ModMod m -> mkModule i' (trExtend (extends m)) (mkOpens (map trOpen (opens m))) + (mkTopDefs (concatMap trAnyDef (tree2list (jments m)) ++ + (map trFlag (flags m)))) + where + i' = tri i + mkModule = case typeOfModule mo of + MTResource -> P.MResource + MTAbstract -> P.MAbstract + MTConcrete a -> P.MConcrete (tri a) + +trExtend :: Maybe Ident -> P.Extend +trExtend i = maybe P.NoExt (P.Ext . tri) i + +---- this has to be completed with other mtys +forName (MTConcrete a) = tri a + +trOpen :: OpenSpec Ident -> P.Open +trOpen o = case o of + OSimple i -> P.OName (tri i) + OQualif i j -> P.OQual (tri i) (tri j) + +mkOpens ds = if null ds then P.NoOpens else P.Opens ds +mkTopDefs ds = ds + +trAnyDef :: (Ident,Info) -> [P.TopDef] +trAnyDef (i,info) = let i' = tri i in case info of + AbsCat (Yes co) _ -> [P.DefCat [P.CatDef i' (map trDecl co)]] + AbsFun (Yes ty) _ -> [P.DefFun [P.FunDef [i'] (trt ty)]] + AbsFun (May b) _ -> [P.DefFun [P.FunDef [i'] (P.EIndir (tri b))]] + ---- don't destroy definitions! + + ResOper pty ptr -> [P.DefOper [trDef i' pty ptr]] + ResParam pp -> [P.DefPar [case pp of + Yes ps -> P.ParDef i' [P.ParConstr (tri c) (map trDecl co) | (c,co) <- ps] + May b -> P.ParDefIndir i' $ tri b + _ -> P.ParDefAbs i']] + + CncCat (Yes ty) Nope _ -> + [P.DefLincat [P.PrintDef [i'] (trt ty)]] + CncCat pty ptr ppr -> + [P.DefLindef [trDef i' pty ptr]] + ---- P.DefPrintCat [P.PrintDef i' (trt pr)]] + CncFun _ ptr ppr -> + [P.DefLin [trDef i' nope ptr]] + ---- P.DefPrintFun [P.PrintDef i' (trt pr)]] + _ -> [] + +trDef :: Ident -> Perh Type -> Perh Term -> P.Def +trDef i pty ptr = case (pty,ptr) of + (Nope, Nope) -> P.DDef [i] (P.EMeta) --- + (_, Nope) -> P.DDecl [i] (trPerh pty) + (Nope, _ ) -> P.DDef [i] (trPerh ptr) + (_, _ ) -> P.DFull [i] (trPerh pty) (trPerh ptr) + +trPerh p = case p of + Yes t -> trt t + May b -> P.EIndir $ tri b + _ -> P.EMeta --- + + +trFlag :: Option -> P.TopDef +trFlag o = case o of + Opt (f,[x]) -> P.DefFlag [P.FlagDef (identC f) (identC x)] + _ -> P.DefFlag [] --- warning? + +trt :: Term -> P.Exp +trt trm = case trm of + Vr s -> P.EIdent $ tri s + Cn s -> P.ECons $ tri s + Con s -> P.EConstr $ tri s +---- ConAt id typ -> P.EConAt (tri id) (trt typ) + + Sort s -> P.ESort $ case s of + "Type" -> P.Sort_Type + "PType" -> P.Sort_PType + "Tok" -> P.Sort_Tok + "Str" -> P.Sort_Str + "Strs" -> P.Sort_Strs + _ -> error $ "not yet sort " +++ show trm ---- + + + App c a -> P.EApp (trt c) (trt a) + Abs x b -> P.EAbstr [trb x] (trt b) + +---- Eqs pts -> "fn" +++ prCurlyList [prtBranchOld pst | pst <- pts] --- +---- ECase e bs -> "case" +++ prt e +++ "of" +++ prCurlyList (map prtBranch bs) + + Meta m -> P.EMeta + Prod x a b | isWildIdent x -> P.EProd (P.DExp (trt a)) (trt b) + Prod x a b -> P.EProd (P.DDec [trb x] (trt a)) (trt b) + + R r -> P.ERecord $ map trAssign r + RecType r -> P.ERecord $ map trLabelling r + ExtR x y -> P.EExtend (trt x) (trt y) + P t l -> P.EProj (trt t) (trLabel l) + Q t l -> P.EQCons (tri t) (tri l) + QC t l -> P.EQConstr (tri t) (tri l) + T (TTyped ty) cc -> P.ETTable (trt ty) (map trCase cc) + T (TComp ty) cc -> P.ETTable (trt ty) (map trCase cc) + T (TWild ty) cc -> P.ETTable (trt ty) (map trCase cc) + T _ cc -> P.ETable (map trCase cc) + + Table x v -> P.ETType (trt x) (trt v) + S f x -> P.ESelect (trt f) (trt x) +---- Alias c a t -> "{-" +++ prt c +++ "=" +++ "-}" +++ prt t +-- Alias c a t -> prt (Let (c,(Just a,t)) (Vr c)) -- thus Alias is only internal + + Let (x,(ma,b)) t -> + P.ELet [maybe (P.LDDef x' b') (\ty -> P.LDFull x' (trt ty) b') ma] (trt t) + where + b' = trt b + x' = [tri x] + + Empty -> P.EEmpty + K [] -> P.EEmpty + K a -> P.EString a + C a b -> P.EConcat (trt a) (trt b) + + EInt i -> P.EInt $ toInteger i + + Glue a b -> P.EGlue (trt a) (trt b) + Alts (t, tt) -> P.EPre (trt t) [P.Alt (trt v) (trt c) | (v,c) <- tt] + FV ts -> P.EVariants $ map trt ts + Strs tt -> P.EStrs $ map trt tt + _ -> error $ "not yet" +++ show trm ---- + +trp :: Patt -> P.Patt +trp p = case p of + PV s | isWildIdent s -> P.PW + PV s -> P.PV $ tri s + PC c [] -> P.PCon $ tri c + PC c a -> P.PC (tri c) (map trp a) + PP p c [] -> P.PQ (tri p) (tri c) + PP p c a -> P.PQC (tri p) (tri c) (map trp a) + PR r -> P.PR [P.PA [trLabelIdent l] (trp p) | (l,p) <- r] +---- PT t p -> prt p ---- prParenth (prt p +++ ":" +++ prt t) + + +trAssign (lab, (mty, t)) = maybe (P.LDDef x t') (\ty -> P.LDFull x (trt ty) t') mty + where + t' = trt t + x = [trLabelIdent lab] + +trLabelling (lab,ty) = P.LDDecl [trLabelIdent lab] (trt ty) + +trCase (patt,trm) = P.Case [P.AltP (trp patt)] (trt trm) + +trDecl (x,ty) = P.DDDec [trb x] (trt ty) + +tri :: Ident -> Ident +tri i = case prIdent i of + s@('_':_:_) -> identC $ 'h':s ---- unsafe; needed since _3 etc are generated + s -> identC $ s + +trb i = if isWildIdent i then P.BWild else P.BIdent (tri i) + +trLabel i = case i of + LIdent s -> P.LIdent $ identC s + LVar i -> P.LVar $ toInteger i + +trLabelIdent i = identC $ case i of + LIdent s -> s + LVar i -> "v" ++ show i --- should not happen + diff --git a/src/GF/Source/LexGF.hs b/src/GF/Source/LexGF.hs new file mode 100644 index 000000000..e9406dd78 --- /dev/null +++ b/src/GF/Source/LexGF.hs @@ -0,0 +1,127 @@ +module LexGF where + +import Alex +import ErrM + +pTSpec p = PT p . TS + +mk_LString p = PT p . eitherResIdent T_LString + +ident p = PT p . eitherResIdent TV + +string p = PT p . TL . unescapeInitTail + +int p = PT p . TI + + +data Tok = + TS String -- reserved words + | TL String -- string literals + | TI String -- integer literals + | TV String -- identifiers + | TD String -- double precision float literals + | TC String -- character literals + | T_LString String + + deriving (Eq,Show) + +data Token = + PT Posn Tok + | Err Posn + deriving Show + +tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l +tokenPos (Err (Pn _ l _) :_) = "line " ++ show l +tokenPos _ = "end of file" + +prToken t = case t of + PT _ (TS s) -> s + PT _ (TI s) -> s + PT _ (TV s) -> s + PT _ (TD s) -> s + PT _ (TC s) -> s + _ -> show t + +tokens:: String -> [Token] +tokens inp = scan tokens_scan inp + +tokens_scan:: Scan Token +tokens_scan = load_scan (tokens_acts,stop_act) tokens_lx + where + stop_act p "" = [] + stop_act p inp = [Err p] + +eitherResIdent :: (String -> Tok) -> String -> Tok +eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where + isResWord s = isInTree s $ + B "let" (B "concrete" (B "Tok" (B "Str" (B "PType" (B "Lin" N N) N) (B "Strs" N N)) (B "case" (B "abstract" (B "Type" N N) N) (B "cat" N N))) (B "fun" (B "flags" (B "def" (B "data" N N) N) (B "fn" N N)) (B "in" (B "grammar" N N) (B "include" N N)))) (B "pattern" (B "of" (B "lindef" (B "lincat" (B "lin" N N) N) (B "lintype" N N)) (B "out" (B "oper" (B "open" N N) N) (B "param" N N))) (B "strs" (B "resource" (B "printname" (B "pre" N N) N) (B "reuse" N N)) (B "transfer" (B "table" N N) (B "variants" N N)))) + +data BTree = N | B String BTree BTree deriving (Show) + +isInTree :: String -> BTree -> Bool +isInTree x tree = case tree of + N -> False + B a left right + | x < a -> isInTree x left + | x > a -> isInTree x right + | x == a -> True + +unescapeInitTail :: String -> String +unescapeInitTail = unesc . tail where + unesc s = case s of + '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs + '\\':'n':cs -> '\n' : unesc cs + '\\':'t':cs -> '\t' : unesc cs + '"':[] -> [] + c:cs -> c : unesc cs + _ -> [] + +tokens_acts = [("ident",ident),("int",int),("mk_LString",mk_LString),("pTSpec",pTSpec),("string",string)] + +tokens_lx :: [(Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))] +tokens_lx = [lx__0_0,lx__1_0,lx__2_0,lx__3_0,lx__4_0,lx__5_0,lx__6_0,lx__7_0,lx__8_0,lx__9_0,lx__10_0,lx__11_0,lx__12_0,lx__13_0,lx__14_0,lx__15_0,lx__16_0,lx__17_0,lx__18_0,lx__19_0,lx__20_0,lx__21_0] +lx__0_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__0_0 = (False,[],-1,(('\t','\255'),[('\t',10),('\n',10),('\v',10),('\f',10),('\r',10),(' ',10),('!',14),('"',18),('$',14),('\'',15),('(',14),(')',14),('*',11),('+',13),(',',14),('-',1),('.',14),('/',14),('0',21),('1',21),('2',21),('3',21),('4',21),('5',21),('6',21),('7',21),('8',21),('9',21),(':',14),(';',14),('<',14),('=',12),('>',14),('?',14),('@',14),('A',17),('B',17),('C',17),('D',17),('E',17),('F',17),('G',17),('H',17),('I',17),('J',17),('K',17),('L',17),('M',17),('N',17),('O',17),('P',17),('Q',17),('R',17),('S',17),('T',17),('U',17),('V',17),('W',17),('X',17),('Y',17),('Z',17),('[',14),('\\',14),(']',14),('_',14),('a',17),('b',17),('c',17),('d',17),('e',17),('f',17),('g',17),('h',17),('i',17),('j',17),('k',17),('l',17),('m',17),('n',17),('o',17),('p',17),('q',17),('r',17),('s',17),('t',17),('u',17),('v',17),('w',17),('x',17),('y',17),('z',17),('{',4),('|',14),('}',14),('\192',17),('\193',17),('\194',17),('\195',17),('\196',17),('\197',17),('\198',17),('\199',17),('\200',17),('\201',17),('\202',17),('\203',17),('\204',17),('\205',17),('\206',17),('\207',17),('\208',17),('\209',17),('\210',17),('\211',17),('\212',17),('\213',17),('\214',17),('\216',17),('\217',17),('\218',17),('\219',17),('\220',17),('\221',17),('\222',17),('\223',17),('\224',17),('\225',17),('\226',17),('\227',17),('\228',17),('\229',17),('\230',17),('\231',17),('\232',17),('\233',17),('\234',17),('\235',17),('\236',17),('\237',17),('\238',17),('\239',17),('\240',17),('\241',17),('\242',17),('\243',17),('\244',17),('\245',17),('\246',17),('\248',17),('\249',17),('\250',17),('\251',17),('\252',17),('\253',17),('\254',17),('\255',17)])) +lx__1_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__1_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('-','>'),[('-',2),('>',14)])) +lx__2_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__2_0 = (False,[],2,(('\n','\n'),[('\n',3)])) +lx__3_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__3_0 = (True,[(0,"",[],Nothing,Nothing)],-1,(('0','0'),[])) +lx__4_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__4_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('-','-'),[('-',5)])) +lx__5_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__5_0 = (False,[],5,(('-','-'),[('-',8)])) +lx__6_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__6_0 = (False,[],5,(('-','}'),[('-',8),('}',7)])) +lx__7_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__7_0 = (True,[(1,"",[],Nothing,Nothing)],5,(('-','-'),[('-',8)])) +lx__8_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__8_0 = (False,[],5,(('-','}'),[('-',6),('}',9)])) +lx__9_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__9_0 = (True,[(1,"",[],Nothing,Nothing)],-1,(('0','0'),[])) +lx__10_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__10_0 = (True,[(2,"",[],Nothing,Nothing)],-1,(('\t',' '),[('\t',10),('\n',10),('\v',10),('\f',10),('\r',10),(' ',10)])) +lx__11_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__11_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('*','*'),[('*',14)])) +lx__12_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__12_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('>','>'),[('>',14)])) +lx__13_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__13_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('+','+'),[('+',14)])) +lx__14_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__14_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('0','0'),[])) +lx__15_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__15_0 = (False,[],15,(('\'','\''),[('\'',16)])) +lx__16_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__16_0 = (True,[(4,"mk_LString",[],Nothing,Nothing)],15,(('\'','\''),[('\'',16)])) +lx__17_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__17_0 = (True,[(5,"ident",[],Nothing,Nothing)],-1,(('\'','\255'),[('\'',17),('0',17),('1',17),('2',17),('3',17),('4',17),('5',17),('6',17),('7',17),('8',17),('9',17),('A',17),('B',17),('C',17),('D',17),('E',17),('F',17),('G',17),('H',17),('I',17),('J',17),('K',17),('L',17),('M',17),('N',17),('O',17),('P',17),('Q',17),('R',17),('S',17),('T',17),('U',17),('V',17),('W',17),('X',17),('Y',17),('Z',17),('_',17),('a',17),('b',17),('c',17),('d',17),('e',17),('f',17),('g',17),('h',17),('i',17),('j',17),('k',17),('l',17),('m',17),('n',17),('o',17),('p',17),('q',17),('r',17),('s',17),('t',17),('u',17),('v',17),('w',17),('x',17),('y',17),('z',17),('\192',17),('\193',17),('\194',17),('\195',17),('\196',17),('\197',17),('\198',17),('\199',17),('\200',17),('\201',17),('\202',17),('\203',17),('\204',17),('\205',17),('\206',17),('\207',17),('\208',17),('\209',17),('\210',17),('\211',17),('\212',17),('\213',17),('\214',17),('\216',17),('\217',17),('\218',17),('\219',17),('\220',17),('\221',17),('\222',17),('\223',17),('\224',17),('\225',17),('\226',17),('\227',17),('\228',17),('\229',17),('\230',17),('\231',17),('\232',17),('\233',17),('\234',17),('\235',17),('\236',17),('\237',17),('\238',17),('\239',17),('\240',17),('\241',17),('\242',17),('\243',17),('\244',17),('\245',17),('\246',17),('\248',17),('\249',17),('\250',17),('\251',17),('\252',17),('\253',17),('\254',17),('\255',17)])) +lx__18_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__18_0 = (False,[],18,(('\n','\\'),[('\n',-1),('"',20),('\\',19)])) +lx__19_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__19_0 = (False,[],-1,(('"','t'),[('"',18),('\'',18),('\\',18),('n',18),('t',18)])) +lx__20_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__20_0 = (True,[(6,"string",[],Nothing,Nothing)],-1,(('0','0'),[])) +lx__21_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__21_0 = (True,[(7,"int",[],Nothing,Nothing)],-1,(('0','9'),[('0',21),('1',21),('2',21),('3',21),('4',21),('5',21),('6',21),('7',21),('8',21),('9',21)])) + diff --git a/src/GF/Source/PrintGF.hs b/src/GF/Source/PrintGF.hs new file mode 100644 index 000000000..9d71dfe6e --- /dev/null +++ b/src/GF/Source/PrintGF.hs @@ -0,0 +1,435 @@ +module PrintGF where + +-- pretty-printer generated by the BNF converter, except --H + +import AbsGF +import Ident --H +import Char + +-- the top-level printing method +printTree :: Print a => a -> String +printTree = render . prt 0 + +-- you may want to change render and parenth + +render :: [String] -> String +render = rend 0 where + rend i ss = case ss of + + --H these three are hand-written + "{0" :ts -> cons "{" $ rend (i+1) ts + t :"}0" :ts -> cons t $ space "}" $ rend (i-1) ts + t : "." :ts -> cons t $ cons "." $ rend i ts + + "[" :ts -> cons "[" $ rend i ts + "(" :ts -> cons "(" $ rend i ts + "{" :ts -> cons "{" $ new (i+1) $ rend (i+1) ts + "}" : ";":ts -> new (i-1) $ space "}" $ cons ";" $ new (i-1) $ rend (i-1) ts + "}" :ts -> new (i-1) $ cons "}" $ new (i-1) $ rend (i-1) ts + ";" :ts -> cons ";" $ new i $ rend i ts + t : "," :ts -> cons t $ space "," $ rend i ts + t : ")" :ts -> cons t $ cons ")" $ rend i ts + t : "]" :ts -> cons t $ cons "]" $ rend i ts + t :ts -> space t $ rend i ts + _ -> "" + cons s t = s ++ t + new i s = '\n' : replicate (2*i) ' ' ++ dropWhile isSpace s + space t s = if null s then t else t ++ " " ++ s + +parenth :: [String] -> [String] +parenth ss = ["("] ++ ss ++ [")"] + +-- the printer class does the job +class Print a where + prt :: Int -> a -> [String] + prtList :: [a] -> [String] + prtList = concat . map (prt 0) + +instance Print a => Print [a] where + prt _ = prtList + +instance Print Integer where + prt _ = (:[]) . show + +instance Print Double where + prt _ = (:[]) . show + +instance Print Char where + prt _ s = ["'" ++ mkEsc s ++ "'"] + prtList s = ["\"" ++ concatMap mkEsc s ++ "\""] + +mkEsc s = case s of + _ | elem s "\\\"'" -> '\\':[s] + '\n' -> "\\n" + '\t' -> "\\t" + _ -> [s] + +prPrec :: Int -> Int -> [String] -> [String] +prPrec i j = if j<i then parenth else id + + +instance Print Ident where + prt _ i = [prIdent i] --H + prtList es = case es of + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [","] , prt 0 xs]) + + +instance Print LString where + prt _ (LString i) = [i] + + + +instance Print Grammar where + prt i e = case e of + Gr moddefs -> prPrec i 0 (concat [prt 0 moddefs]) + + +instance Print ModDef where + prt i e = case e of + MMain id0 id concspecs -> prPrec i 0 (concat [["grammar"] , prt 0 id0 , ["="] , ["{"] , ["abstract"] , ["="] , prt 0 id , [";"] , prt 0 concspecs , ["}"]]) + MAbstract id extend opens topdefs -> prPrec i 0 (concat [["abstract"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]]) + MResource id extend opens topdefs -> prPrec i 0 (concat [["resource"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]]) + MResourceInt id extend opens topdefs -> prPrec i 0 (concat [["resource"] , ["abstract"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]]) + MResourceImp id0 id opens topdefs -> prPrec i 0 (concat [["resource"] , prt 0 id0 , ["of"] , prt 0 id , ["="] , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]]) + MConcrete id0 id extend opens topdefs -> prPrec i 0 (concat [["concrete"] , prt 0 id0 , ["of"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]]) + MConcreteInt id0 id extend opens topdefs -> prPrec i 0 (concat [["concrete"] , ["abstract"] , ["of"] , prt 0 id0 , ["in"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]]) + MConcreteImp open id0 id -> prPrec i 0 (concat [["concrete"] , ["of"] , prt 0 open , ["="] , prt 0 id0 , ["**"] , prt 0 id]) + MTransfer id open0 open extend opens topdefs -> prPrec i 0 (concat [["transfer"] , prt 0 id , [":"] , prt 0 open0 , ["->"] , prt 0 open , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]]) + MReuseAbs id0 id -> prPrec i 0 (concat [["resource"] , ["abstract"] , prt 0 id0 , ["="] , ["reuse"] , prt 0 id]) + MReuseCnc id0 id -> prPrec i 0 (concat [["resource"] , ["concrete"] , prt 0 id0 , ["="] , ["reuse"] , prt 0 id]) + MReuseAll id0 extend id -> prPrec i 0 (concat [["resource"] , prt 0 id0 , ["="] , prt 0 extend , ["reuse"] , prt 0 id]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 0 x , prt 0 xs]) + +instance Print ConcSpec where + prt i e = case e of + ConcSpec id concexp -> prPrec i 0 (concat [prt 0 id , ["="] , prt 0 concexp]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print ConcExp where + prt i e = case e of + ConcExp id transfers -> prPrec i 0 (concat [prt 0 id , prt 0 transfers]) + + +instance Print Transfer where + prt i e = case e of + TransferIn open -> prPrec i 0 (concat [["("] , ["transfer"] , ["in"] , prt 0 open , [")"]]) + TransferOut open -> prPrec i 0 (concat [["("] , ["transfer"] , ["out"] , prt 0 open , [")"]]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 0 x , prt 0 xs]) + +instance Print Extend where + prt i e = case e of + Ext id -> prPrec i 0 (concat [prt 0 id , ["**"]]) + NoExt -> prPrec i 0 (concat []) + + +instance Print Opens where + prt i e = case e of + NoOpens -> prPrec i 0 (concat []) + Opens opens -> prPrec i 0 (concat [["open"] , prt 0 opens , ["in"]]) + + +instance Print Open where + prt i e = case e of + OName id -> prPrec i 0 (concat [prt 0 id]) + OQual id0 id -> prPrec i 0 (concat [["("] , prt 0 id0 , ["="] , prt 0 id , [")"]]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [","] , prt 0 xs]) + +instance Print Def where + prt i e = case e of + DDecl ids exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp]) + DDef ids exp -> prPrec i 0 (concat [prt 0 ids , ["="] , prt 0 exp]) + DPatt id patts exp -> prPrec i 0 (concat [prt 0 id , prt 0 patts , ["="] , prt 0 exp]) + DFull ids exp0 exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp0 , ["="] , prt 0 exp]) + + prtList es = case es of + [x] -> (concat [prt 0 x , [";"]]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print TopDef where + prt i e = case e of + DefCat catdefs -> prPrec i 0 (concat [["cat"] , prt 0 catdefs]) + DefFun fundefs -> prPrec i 0 (concat [["fun"] , prt 0 fundefs]) + DefDef defs -> prPrec i 0 (concat [["def"] , prt 0 defs]) + DefData pardefs -> prPrec i 0 (concat [["data"] , prt 0 pardefs]) + DefTrans flagdefs -> prPrec i 0 (concat [["transfer"] , prt 0 flagdefs]) + DefPar pardefs -> prPrec i 0 (concat [["param"] , prt 0 pardefs]) + DefOper defs -> prPrec i 0 (concat [["oper"] , prt 0 defs]) + DefLincat printdefs -> prPrec i 0 (concat [["lincat"] , prt 0 printdefs]) + DefLindef defs -> prPrec i 0 (concat [["lindef"] , prt 0 defs]) + DefLin defs -> prPrec i 0 (concat [["lin"] , prt 0 defs]) + DefPrintCat printdefs -> prPrec i 0 (concat [["printname"] , ["cat"] , prt 0 printdefs]) + DefPrintFun printdefs -> prPrec i 0 (concat [["printname"] , ["fun"] , prt 0 printdefs]) + DefFlag flagdefs -> prPrec i 0 (concat [["flags"] , prt 0 flagdefs]) + DefPrintOld printdefs -> prPrec i 0 (concat [["printname"] , prt 0 printdefs]) + DefLintype defs -> prPrec i 0 (concat [["lintype"] , prt 0 defs]) + DefPattern defs -> prPrec i 0 (concat [["pattern"] , prt 0 defs]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 0 x , prt 0 xs]) + +instance Print CatDef where + prt i e = case e of + CatDef id ddecls -> prPrec i 0 (concat [prt 0 id , prt 0 ddecls]) + + prtList es = case es of + [x] -> (concat [prt 0 x , [";"]]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print FunDef where + prt i e = case e of + FunDef ids exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp]) + + prtList es = case es of + [x] -> (concat [prt 0 x , [";"]]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print ParDef where + prt i e = case e of + ParDef id parconstrs -> prPrec i 0 (concat [prt 0 id , ["="] , prt 0 parconstrs]) + ParDefIndir id0 id -> prPrec i 0 (concat [prt 0 id0 , ["="] , ["("] , ["in"] , prt 0 id , [")"]]) + ParDefAbs id -> prPrec i 0 (concat [prt 0 id]) + + prtList es = case es of + [x] -> (concat [prt 0 x , [";"]]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print ParConstr where + prt i e = case e of + ParConstr id ddecls -> prPrec i 0 (concat [prt 0 id , prt 0 ddecls]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , ["|"] , prt 0 xs]) + +instance Print PrintDef where + prt i e = case e of + PrintDef ids exp -> prPrec i 0 (concat [prt 0 ids , ["="] , prt 0 exp]) + + prtList es = case es of + [x] -> (concat [prt 0 x , [";"]]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print FlagDef where + prt i e = case e of + FlagDef id0 id -> prPrec i 0 (concat [prt 0 id0 , ["="] , prt 0 id]) + + prtList es = case es of + [x] -> (concat [prt 0 x , [";"]]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print LocDef where + prt i e = case e of + LDDecl ids exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp]) + LDDef ids exp -> prPrec i 0 (concat [prt 0 ids , ["="] , prt 0 exp]) + LDFull ids exp0 exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp0 , ["="] , prt 0 exp]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print Exp where + prt i e = case e of + EIdent id -> prPrec i 4 (concat [prt 0 id]) + EConstr id -> prPrec i 4 (concat [["{0"] , prt 0 id , ["}0"]]) --H + ECons id -> prPrec i 4 (concat [["["] , prt 0 id , ["]"]]) + ESort sort -> prPrec i 4 (concat [prt 0 sort]) + EString str -> prPrec i 4 (concat [prt 0 str]) + EInt n -> prPrec i 4 (concat [prt 0 n]) + EMeta -> prPrec i 4 (concat [["?"]]) + EEmpty -> prPrec i 4 (concat [["["] , ["]"]]) + EStrings str -> prPrec i 4 (concat [["["] , prt 0 str , ["]"]]) + ERecord locdefs -> prPrec i 4 (concat [["{"] , prt 0 locdefs , ["}"]]) + ETuple tuplecomps -> prPrec i 4 (concat [["<"] , prt 0 tuplecomps , [">"]]) + EIndir id -> prPrec i 4 (concat [["("] , ["in"] , prt 0 id , [")"]]) + ETyped exp0 exp -> prPrec i 4 (concat [["<"] , prt 0 exp0 , [":"] , prt 0 exp , [">"]]) + EProj exp label -> prPrec i 3 (concat [prt 3 exp , ["."] , prt 0 label]) + EQConstr id0 id -> prPrec i 3 (concat [["{0"] , prt 0 id0 , ["."] , prt 0 id , ["}0"]]) --H + EQCons id0 id -> prPrec i 3 (concat [["["] , prt 0 id0 , ["."] , prt 0 id , ["]"]]) + EApp exp0 exp -> prPrec i 2 (concat [prt 2 exp0 , prt 3 exp]) + ETable cases -> prPrec i 2 (concat [["table"] , ["{"] , prt 0 cases , ["}"]]) + ETTable exp cases -> prPrec i 2 (concat [["table"] , prt 4 exp , ["{"] , prt 0 cases , ["}"]]) + ECase exp cases -> prPrec i 2 (concat [["case"] , prt 0 exp , ["of"] , ["{"] , prt 0 cases , ["}"]]) + EVariants exps -> prPrec i 2 (concat [["variants"] , ["{"] , prt 0 exps , ["}"]]) + EPre exp alterns -> prPrec i 2 (concat [["pre"] , ["{"] , prt 0 exp , [";"] , prt 0 alterns , ["}"]]) + EStrs exps -> prPrec i 2 (concat [["strs"] , ["{"] , prt 0 exps , ["}"]]) + EConAt id exp -> prPrec i 2 (concat [prt 0 id , ["@"] , prt 4 exp]) + ESelect exp0 exp -> prPrec i 1 (concat [prt 1 exp0 , ["!"] , prt 2 exp]) + ETupTyp exp0 exp -> prPrec i 1 (concat [prt 1 exp0 , ["*"] , prt 2 exp]) + EExtend exp0 exp -> prPrec i 1 (concat [prt 1 exp0 , ["**"] , prt 2 exp]) + EAbstr binds exp -> prPrec i 0 (concat [["\\"] , prt 0 binds , ["->"] , prt 0 exp]) + ECTable binds exp -> prPrec i 0 (concat [["\\"] , ["\\"] , prt 0 binds , ["=>"] , prt 0 exp]) + EProd decl exp -> prPrec i 0 (concat [prt 0 decl , ["->"] , prt 0 exp]) + ETType exp0 exp -> prPrec i 0 (concat [prt 1 exp0 , ["=>"] , prt 0 exp]) + EConcat exp0 exp -> prPrec i 0 (concat [prt 1 exp0 , ["++"] , prt 0 exp]) + EGlue exp0 exp -> prPrec i 0 (concat [prt 1 exp0 , ["+"] , prt 0 exp]) + ELet locdefs exp -> prPrec i 0 (concat [["let"] , ["{"] , prt 0 locdefs , ["}"] , ["in"] , prt 0 exp]) + EEqs equations -> prPrec i 0 (concat [["fn"] , ["{"] , prt 0 equations , ["}"]]) + ELString lstring -> prPrec i 4 (concat [prt 0 lstring]) + ELin id -> prPrec i 2 (concat [["Lin"] , prt 0 id]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print Patt where + prt i e = case e of + PW -> prPrec i 1 (concat [["_"]]) + PV id -> prPrec i 1 (concat [prt 0 id]) + PCon id -> prPrec i 1 (concat [["{0"] , prt 0 id , ["}0"]]) --H + PQ id0 id -> prPrec i 1 (concat [prt 0 id0 , ["."] , prt 0 id]) + PInt n -> prPrec i 1 (concat [prt 0 n]) + PStr str -> prPrec i 1 (concat [prt 0 str]) + PR pattasss -> prPrec i 1 (concat [["{"] , prt 0 pattasss , ["}"]]) + PTup patttuplecomps -> prPrec i 1 (concat [["<"] , prt 0 patttuplecomps , [">"]]) + PC id patts -> prPrec i 0 (concat [prt 0 id , prt 0 patts]) + PQC id0 id patts -> prPrec i 0 (concat [prt 0 id0 , ["."] , prt 0 id , prt 0 patts]) + + prtList es = case es of + [x] -> (concat [prt 1 x]) + x:xs -> (concat [prt 1 x , prt 0 xs]) + +instance Print PattAss where + prt i e = case e of + PA ids patt -> prPrec i 0 (concat [prt 0 ids , ["="] , prt 0 patt]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print Label where + prt i e = case e of + LIdent id -> prPrec i 0 (concat [prt 0 id]) + LVar n -> prPrec i 0 (concat [["$"] , prt 0 n]) + + +instance Print Sort where + prt i e = case e of + Sort_Type -> prPrec i 0 (concat [["Type"]]) + Sort_PType -> prPrec i 0 (concat [["PType"]]) + Sort_Tok -> prPrec i 0 (concat [["Tok"]]) + Sort_Str -> prPrec i 0 (concat [["Str"]]) + Sort_Strs -> prPrec i 0 (concat [["Strs"]]) + + +instance Print PattAlt where + prt i e = case e of + AltP patt -> prPrec i 0 (concat [prt 0 patt]) + + prtList es = case es of + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , ["|"] , prt 0 xs]) + +instance Print Bind where + prt i e = case e of + BIdent id -> prPrec i 0 (concat [prt 0 id]) + BWild -> prPrec i 0 (concat [["_"]]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [","] , prt 0 xs]) + +instance Print Decl where + prt i e = case e of + DDec binds exp -> prPrec i 0 (concat [["("] , prt 0 binds , [":"] , prt 0 exp , [")"]]) + DExp exp -> prPrec i 0 (concat [prt 2 exp]) + + +instance Print TupleComp where + prt i e = case e of + TComp exp -> prPrec i 0 (concat [prt 0 exp]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [","] , prt 0 xs]) + +instance Print PattTupleComp where + prt i e = case e of + PTComp patt -> prPrec i 0 (concat [prt 0 patt]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [","] , prt 0 xs]) + +instance Print Case where + prt i e = case e of + Case pattalts exp -> prPrec i 0 (concat [prt 0 pattalts , ["=>"] , prt 0 exp]) + + prtList es = case es of + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print Equation where + prt i e = case e of + Equ patts exp -> prPrec i 0 (concat [prt 0 patts , ["->"] , prt 0 exp]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print Altern where + prt i e = case e of + Alt exp0 exp -> prPrec i 0 (concat [prt 0 exp0 , ["/"] , prt 0 exp]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print DDecl where + prt i e = case e of + DDDec binds exp -> prPrec i 0 (concat [["("] , prt 0 binds , [":"] , prt 0 exp , [")"]]) + DDExp exp -> prPrec i 0 (concat [prt 4 exp]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 0 x , prt 0 xs]) + +instance Print OldGrammar where + prt i e = case e of + OldGr include topdefs -> prPrec i 0 (concat [prt 0 include , prt 0 topdefs]) + + +instance Print Include where + prt i e = case e of + NoIncl -> prPrec i 0 (concat []) + Incl filenames -> prPrec i 0 (concat [["include"] , prt 0 filenames]) + + +instance Print FileName where + prt i e = case e of + FString str -> prPrec i 0 (concat [prt 0 str]) + FIdent id -> prPrec i 0 (concat [prt 0 id]) + FSlash filename -> prPrec i 0 (concat [["/"] , prt 0 filename]) + FDot filename -> prPrec i 0 (concat [["."] , prt 0 filename]) + FMinus filename -> prPrec i 0 (concat [["-"] , prt 0 filename]) + FAddId id filename -> prPrec i 0 (concat [prt 0 id , prt 0 filename]) + + prtList es = case es of + [x] -> (concat [prt 0 x , [";"]]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + + diff --git a/src/GF/Source/SkelGF.hs b/src/GF/Source/SkelGF.hs new file mode 100644 index 000000000..cf0932a87 --- /dev/null +++ b/src/GF/Source/SkelGF.hs @@ -0,0 +1,289 @@ +module SkelGF where + +-- Haskell module generated by the BNF converter + +import AbsGF +import Ident +import ErrM +type Result = Err String + +failure :: Show a => a -> Result +failure x = Bad $ "Undefined case: " ++ show x + +transIdent :: Ident -> Result +transIdent x = case x of + _ -> failure x + + +transLString :: LString -> Result +transLString x = case x of + LString str -> failure x + + +transGrammar :: Grammar -> Result +transGrammar x = case x of + Gr moddefs -> failure x + + +transModDef :: ModDef -> Result +transModDef x = case x of + MMain id0 id concspecs -> failure x + MAbstract id extend opens topdefs -> failure x + MResource id extend opens topdefs -> failure x + MResourceInt id extend opens topdefs -> failure x + MResourceImp id0 id opens topdefs -> failure x + MConcrete id0 id extend opens topdefs -> failure x + MConcreteInt id0 id extend opens topdefs -> failure x + MConcreteImp open id0 id -> failure x + MTransfer id open0 open extend opens topdefs -> failure x + MReuseAbs id0 id -> failure x + MReuseCnc id0 id -> failure x + MReuseAll id0 extend id -> failure x + + +transConcSpec :: ConcSpec -> Result +transConcSpec x = case x of + ConcSpec id concexp -> failure x + + +transConcExp :: ConcExp -> Result +transConcExp x = case x of + ConcExp id transfers -> failure x + + +transTransfer :: Transfer -> Result +transTransfer x = case x of + TransferIn open -> failure x + TransferOut open -> failure x + + +transExtend :: Extend -> Result +transExtend x = case x of + Ext id -> failure x + NoExt -> failure x + + +transOpens :: Opens -> Result +transOpens x = case x of + NoOpens -> failure x + Opens opens -> failure x + + +transOpen :: Open -> Result +transOpen x = case x of + OName id -> failure x + OQual id0 id -> failure x + + +transDef :: Def -> Result +transDef x = case x of + DDecl ids exp -> failure x + DDef ids exp -> failure x + DPatt id patts exp -> failure x + DFull ids exp0 exp -> failure x + + +transTopDef :: TopDef -> Result +transTopDef x = case x of + DefCat catdefs -> failure x + DefFun fundefs -> failure x + DefDef defs -> failure x + DefData pardefs -> failure x + DefTrans flagdefs -> failure x + DefPar pardefs -> failure x + DefOper defs -> failure x + DefLincat printdefs -> failure x + DefLindef defs -> failure x + DefLin defs -> failure x + DefPrintCat printdefs -> failure x + DefPrintFun printdefs -> failure x + DefFlag flagdefs -> failure x + DefPrintOld printdefs -> failure x + DefLintype defs -> failure x + DefPattern defs -> failure x + + +transCatDef :: CatDef -> Result +transCatDef x = case x of + CatDef id ddecls -> failure x + + +transFunDef :: FunDef -> Result +transFunDef x = case x of + FunDef ids exp -> failure x + + +transParDef :: ParDef -> Result +transParDef x = case x of + ParDef id parconstrs -> failure x + ParDefIndir id0 id -> failure x + ParDefAbs id -> failure x + + +transParConstr :: ParConstr -> Result +transParConstr x = case x of + ParConstr id ddecls -> failure x + + +transPrintDef :: PrintDef -> Result +transPrintDef x = case x of + PrintDef ids exp -> failure x + + +transFlagDef :: FlagDef -> Result +transFlagDef x = case x of + FlagDef id0 id -> failure x + + +transLocDef :: LocDef -> Result +transLocDef x = case x of + LDDecl ids exp -> failure x + LDDef ids exp -> failure x + LDFull ids exp0 exp -> failure x + + +transExp :: Exp -> Result +transExp x = case x of + EIdent id -> failure x + EConstr id -> failure x + ECons id -> failure x + ESort sort -> failure x + EString str -> failure x + EInt n -> failure x + EMeta -> failure x + EEmpty -> failure x + EStrings str -> failure x + ERecord locdefs -> failure x + ETuple tuplecomps -> failure x + EIndir id -> failure x + ETyped exp0 exp -> failure x + EProj exp label -> failure x + EQConstr id0 id -> failure x + EQCons id0 id -> failure x + EApp exp0 exp -> failure x + ETable cases -> failure x + ETTable exp cases -> failure x + ECase exp cases -> failure x + EVariants exps -> failure x + EPre exp alterns -> failure x + EStrs exps -> failure x + EConAt id exp -> failure x + ESelect exp0 exp -> failure x + ETupTyp exp0 exp -> failure x + EExtend exp0 exp -> failure x + EAbstr binds exp -> failure x + ECTable binds exp -> failure x + EProd decl exp -> failure x + ETType exp0 exp -> failure x + EConcat exp0 exp -> failure x + EGlue exp0 exp -> failure x + ELet locdefs exp -> failure x + EEqs equations -> failure x + ELString lstring -> failure x + ELin id -> failure x + + +transPatt :: Patt -> Result +transPatt x = case x of + PW -> failure x + PV id -> failure x + PCon id -> failure x + PQ id0 id -> failure x + PInt n -> failure x + PStr str -> failure x + PR pattasss -> failure x + PTup patttuplecomps -> failure x + PC id patts -> failure x + PQC id0 id patts -> failure x + + +transPattAss :: PattAss -> Result +transPattAss x = case x of + PA ids patt -> failure x + + +transLabel :: Label -> Result +transLabel x = case x of + LIdent id -> failure x + LVar n -> failure x + + +transSort :: Sort -> Result +transSort x = case x of + Sort_Type -> failure x + Sort_PType -> failure x + Sort_Tok -> failure x + Sort_Str -> failure x + Sort_Strs -> failure x + + +transPattAlt :: PattAlt -> Result +transPattAlt x = case x of + AltP patt -> failure x + + +transBind :: Bind -> Result +transBind x = case x of + BIdent id -> failure x + BWild -> failure x + + +transDecl :: Decl -> Result +transDecl x = case x of + DDec binds exp -> failure x + DExp exp -> failure x + + +transTupleComp :: TupleComp -> Result +transTupleComp x = case x of + TComp exp -> failure x + + +transPattTupleComp :: PattTupleComp -> Result +transPattTupleComp x = case x of + PTComp patt -> failure x + + +transCase :: Case -> Result +transCase x = case x of + Case pattalts exp -> failure x + + +transEquation :: Equation -> Result +transEquation x = case x of + Equ patts exp -> failure x + + +transAltern :: Altern -> Result +transAltern x = case x of + Alt exp0 exp -> failure x + + +transDDecl :: DDecl -> Result +transDDecl x = case x of + DDDec binds exp -> failure x + DDExp exp -> failure x + + +transOldGrammar :: OldGrammar -> Result +transOldGrammar x = case x of + OldGr include topdefs -> failure x + + +transInclude :: Include -> Result +transInclude x = case x of + NoIncl -> failure x + Incl filenames -> failure x + + +transFileName :: FileName -> Result +transFileName x = case x of + FString str -> failure x + FIdent id -> failure x + FSlash filename -> failure x + FDot filename -> failure x + FMinus filename -> failure x + FAddId id filename -> failure x + + + diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs new file mode 100644 index 000000000..f9e098e08 --- /dev/null +++ b/src/GF/Source/SourceToGrammar.hs @@ -0,0 +1,505 @@ +module SourceToGrammar where + +import qualified Grammar as G +import qualified PrGrammar as GP +import qualified Modules as GM +import qualified Macros as M +import qualified Update as U +import qualified Option as GO +import qualified ModDeps as GD +import Ident +import AbsGF +import PrintGF +import RemoveLiT --- for bw compat +import Operations + +import Monad +import Char + +-- based on the skeleton Haskell module generated by the BNF converter + +type Result = Err String + +failure :: Show a => a -> Err b +failure x = Bad $ "Undefined case: " ++ show x + +transIdent :: Ident -> Err Ident +transIdent x = case x of + x -> return x + +transGrammar :: Grammar -> Err G.SourceGrammar +transGrammar x = case x of + Gr moddefs -> do + moddefs' <- mapM transModDef moddefs + GD.mkSourceGrammar moddefs' + +transModDef :: ModDef -> Err (Ident, G.SourceModInfo) +transModDef x = case x of + MMain id0 id concspecs -> do + id0' <- transIdent id0 + id' <- transIdent id + concspecs' <- mapM transConcSpec concspecs + return $ (id0', GM.ModMainGrammar (GM.MainGrammar id' concspecs')) + MAbstract id extends opens defs -> do + id' <- transIdent id + extends' <- transExtend extends + opens' <- transOpens opens + defs0 <- mapM transAbsDef $ getTopDefs defs + defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds] + flags <- return [f | Right fs <- defs0, f <- fs] + return $ (id', GM.ModMod (GM.Module GM.MTAbstract flags extends' opens' defs')) + MResource id extends opens defs -> do + id' <- transIdent id + extends' <- transExtend extends + opens' <- transOpens opens + defs0 <- mapM transResDef $ getTopDefs defs + defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds] + flags <- return [f | Right fs <- defs0, f <- fs] + return $ (id', GM.ModMod (GM.Module GM.MTResource flags extends' opens' defs')) + MConcrete id open extends opens defs -> do + id' <- transIdent id + open' <- transIdent open + extends' <- transExtend extends + opens' <- transOpens opens + defs0 <- mapM transCncDef $ getTopDefs defs + defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds] + flags <- return [f | Right fs <- defs0, f <- fs] + return $ (id', + GM.ModMod (GM.Module (GM.MTConcrete open') flags extends' opens' defs')) + MTransfer id open0 open extends opens defs -> do + id' <- transIdent id + open0' <- transOpen open0 + open' <- transOpen open + extends' <- transExtend extends + opens' <- transOpens opens + defs0 <- mapM transAbsDef $ getTopDefs defs + defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds] + flags <- return [f | Right fs <- defs0, f <- fs] + return $ (id', + GM.ModMod (GM.Module (GM.MTTransfer open0' open') flags extends' opens' defs')) + + MReuseAbs id0 id -> failure x + MReuseCnc id0 id -> failure x + MReuseAll r e c -> do + r' <- transIdent r + e' <- transExtend e + c' <- transIdent c + return $ (r', GM.ModMod (GM.Module (GM.MTReuse c') [] e' [] NT)) + +getTopDefs :: [TopDef] -> [TopDef] +getTopDefs x = x + +transConcSpec :: ConcSpec -> Err (GM.MainConcreteSpec Ident) +transConcSpec x = case x of + ConcSpec id concexp -> do + id' <- transIdent id + (m,mi,mo) <- transConcExp concexp + return $ GM.MainConcreteSpec id' m mi mo + +transConcExp :: ConcExp -> + Err (Ident, Maybe (GM.OpenSpec Ident),Maybe (GM.OpenSpec Ident)) +transConcExp x = case x of + ConcExp id transfers -> do + id' <- transIdent id + trs <- mapM transTransfer transfers + tin <- case [o | Left o <- trs] of + [o] -> return $ Just o + [] -> return $ Nothing + _ -> Bad "ambiguous transfer in" + tout <- case [o | Right o <- trs] of + [o] -> return $ Just o + [] -> return $ Nothing + _ -> Bad "ambiguous transfer out" + return (id',tin,tout) + +transTransfer :: Transfer -> + Err (Either (GM.OpenSpec Ident)(GM.OpenSpec Ident)) +transTransfer x = case x of + TransferIn open -> liftM Left $ transOpen open + TransferOut open -> liftM Right $ transOpen open + +transExtend :: Extend -> Err (Maybe Ident) +transExtend x = case x of + Ext id -> transIdent id >>= return . Just + NoExt -> return Nothing + +transOpens :: Opens -> Err [GM.OpenSpec Ident] +transOpens x = case x of + NoOpens -> return [] + Opens opens -> mapM transOpen opens + +transOpen :: Open -> Err (GM.OpenSpec Ident) +transOpen x = case x of + OName id -> liftM GM.OSimple $ transIdent id + OQual id m -> liftM2 GM.OQualif (transIdent id) (transIdent m) + +transAbsDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option]) +transAbsDef x = case x of + DefCat catdefs -> do + catdefs' <- mapM transCatDef catdefs + returnl [(cat, G.AbsCat (yes cont) nope) | (cat,cont) <- catdefs'] + DefFun fundefs -> do + fundefs' <- mapM transFunDef fundefs + returnl [(fun, G.AbsFun (yes typ) nope) | (funs,typ) <- fundefs', fun <- funs] + DefDef defs -> do + defs' <- liftM concat $ mapM getDefsGen defs + returnl [(c, G.AbsFun nope pe) | (c,(_,pe)) <- defs'] + DefData _ -> returnl [] ---- + DefTrans defs -> do + let (ids,vals) = unzip [(i,v) | FlagDef i v <- defs] + defs' <- liftM2 zip (mapM transIdent ids) (mapM transIdent vals) + returnl [(c, G.AbsTrans f) | (c,f) <- defs'] + DefFlag defs -> liftM Right $ mapM transFlagDef defs + _ -> Bad $ "illegal definition in abstract module:" ++++ printTree x + +returnl :: a -> Err (Either a b) +returnl = return . Left + +transFlagDef :: FlagDef -> Err GO.Option +transFlagDef x = case x of + FlagDef f x -> return $ GO.Opt (prIdent f,[prIdent x]) + +transCatDef :: CatDef -> Err (Ident, G.Context) +transCatDef x = case x of + CatDef id ddecls -> liftM2 (,) (transIdent id) + (mapM transDDecl ddecls >>= return . concat) + +transFunDef :: FunDef -> Err ([Ident], G.Type) +transFunDef x = case x of + FunDef ids typ -> liftM2 (,) (mapM transIdent ids) (transExp typ) + +transResDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option]) +transResDef x = case x of + DefPar pardefs -> do + pardefs' <- mapM transParDef pardefs + returnl $ [(p, G.ResParam (if null pars + then nope -- abstract param type + else (yes pars))) | (p,pars) <- pardefs'] + ++ [(f, G.ResValue (yes (M.mkProdSimple co (G.Cn p)))) | + (p,pars) <- pardefs', (f,co) <- pars] + DefOper defs -> do + defs' <- liftM concat $ mapM getDefs defs + returnl [(f, G.ResOper pt pe) | (f,(pt,pe)) <- defs'] + + DefLintype defs -> do + defs' <- liftM concat $ mapM getDefs defs + returnl [(f, G.ResOper pt pe) | (f,(pt,pe)) <- defs'] + + DefFlag defs -> liftM Right $ mapM transFlagDef defs + _ -> Bad $ "illegal definition form in resource" +++ printTree x + +transParDef :: ParDef -> Err (Ident, [G.Param]) +transParDef x = case x of + ParDef id params -> liftM2 (,) (transIdent id) (mapM transParConstr params) + ParDefAbs id -> liftM2 (,) (transIdent id) (return []) + _ -> Bad $ "illegal definition in resource:" ++++ printTree x + +transCncDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option]) +transCncDef x = case x of + DefLincat defs -> do + defs' <- liftM concat $ mapM transPrintDef defs + returnl [(f, G.CncCat (yes t) nope nope) | (f,t) <- defs'] + DefLindef defs -> do + defs' <- liftM concat $ mapM getDefs defs + returnl [(f, G.CncCat pt pe nope) | (f,(pt,pe)) <- defs'] + DefLin defs -> do + defs' <- liftM concat $ mapM getDefs defs + returnl [(f, G.CncFun Nothing pe nope) | (f,(_,pe)) <- defs'] + DefPrintCat defs -> do + defs' <- liftM concat $ mapM transPrintDef defs + returnl [(f, G.CncCat nope nope (yes e)) | (f,e) <- defs'] + DefPrintFun defs -> do + defs' <- liftM concat $ mapM transPrintDef defs + returnl [(f, G.CncFun Nothing nope (yes e)) | (f,e) <- defs'] + DefPrintOld defs -> do -- a guess, for backward compatibility + defs' <- liftM concat $ mapM transPrintDef defs + returnl [(f, G.CncFun Nothing nope (yes e)) | (f,e) <- defs'] + DefFlag defs -> liftM Right $ mapM transFlagDef defs + DefPattern defs -> do + defs' <- liftM concat $ mapM getDefs defs + let defs2 = [(f, termInPattern t) | (f,(_,Yes t)) <- defs'] + returnl [(f, G.CncFun Nothing (yes t) nope) | (f,t) <- defs2] + + _ -> Bad $ "illegal definition in concrete syntax:" ++++ printTree x + +transPrintDef :: PrintDef -> Err [(Ident,G.Term)] +transPrintDef x = case x of + PrintDef id exp -> do + (ids,e) <- liftM2 (,) (mapM transIdent id) (transExp exp) + return $ [(i,e) | i <- ids] + +getDefsGen :: Def -> Err [(Ident, (G.Perh G.Type, G.Perh G.Term))] +getDefsGen d = case d of + DDecl ids t -> do + ids' <- mapM transIdent ids + t' <- transExp t + return [(i,(yes t', nope)) | i <- ids'] + DDef ids e -> do + ids' <- mapM transIdent ids + e' <- transExp e + return [(i,(nope, yes e')) | i <- ids'] + DFull ids t e -> do + ids' <- mapM transIdent ids + t' <- transExp t + e' <- transExp e + return [(i,(yes t', yes e')) | i <- ids'] + DPatt id patts e -> do + id' <- transIdent id + ps' <- mapM transPatt patts + e' <- transExp e + return [(id',(nope, yes (G.Eqs [(ps',e')])))] + +-- sometimes you need this special case, e.g. in linearization rules +getDefs :: Def -> Err [(Ident, (G.Perh G.Type, G.Perh G.Term))] +getDefs d = case d of + DPatt id patts e -> do + id' <- transIdent id + xs <- mapM tryMakeVar patts + e' <- transExp e + return [(id',(nope, yes (M.mkAbs xs e')))] + _ -> getDefsGen d + +-- accepts a pattern that is either a variable or a wild card +tryMakeVar :: Patt -> Err Ident +tryMakeVar p = do + p' <- transPatt p + case p' of + G.PV i -> return i + G.PW -> return identW + _ -> Bad $ "not a legal pattern in lambda binding" +++ GP.prt p' + +transExp :: Exp -> Err G.Term +transExp x = case x of + EIdent id -> liftM G.Vr $ transIdent id + EConstr id -> liftM G.Con $ transIdent id + ECons id -> liftM G.Cn $ transIdent id + EQConstr m c -> liftM2 G.QC (transIdent m) (transIdent c) + EQCons m c -> liftM2 G.Q (transIdent m) (transIdent c) + EString str -> return $ G.K str + ESort sort -> liftM G.Sort $ transSort sort + EInt n -> return $ G.EInt $ fromInteger n + EMeta -> return $ M.meta $ M.int2meta 0 + EEmpty -> return G.Empty + EStrings [] -> return G.Empty + EStrings str -> return $ foldr1 G.C $ map G.K $ words str + ERecord defs -> erecord2term defs + ETupTyp _ _ -> do + let tups t = case t of + ETupTyp x y -> tups x ++ [y] -- right-associative parsing + _ -> [t] + es <- mapM transExp $ tups x + return $ G.RecType $ M.tuple2recordType es + ETuple tuplecomps -> do + es <- mapM transExp [e | TComp e <- tuplecomps] + return $ G.R $ M.tuple2record es + EProj exp id -> liftM2 G.P (transExp exp) (trLabel id) + EApp exp0 exp -> liftM2 G.App (transExp exp0) (transExp exp) + ETable cases -> liftM (G.T G.TRaw) (transCases cases) + ETTable exp cases -> + liftM2 (\t c -> G.T (G.TTyped t) c) (transExp exp) (transCases cases) + ECase exp cases -> do + exp' <- transExp exp + cases' <- transCases cases + return $ G.S (G.T G.TRaw cases') exp' + ECTable binds exp -> liftM2 M.mkCTable (mapM transBind binds) (transExp exp) + + EVariants exps -> liftM G.FV $ mapM transExp exps + EPre exp alts -> liftM2 (curry G.Alts) (transExp exp) (mapM transAltern alts) + EStrs exps -> liftM G.Strs $ mapM transExp exps + ESelect exp0 exp -> liftM2 G.S (transExp exp0) (transExp exp) + EExtend exp0 exp -> liftM2 G.ExtR (transExp exp0) (transExp exp) + EAbstr binds exp -> liftM2 M.mkAbs (mapM transBind binds) (transExp exp) + ETyped exp0 exp -> liftM2 G.Typed (transExp exp0) (transExp exp) + + EProd decl exp -> liftM2 M.mkProdSimple (transDecl decl) (transExp exp) + ETType exp0 exp -> liftM2 G.Table (transExp exp0) (transExp exp) + EConcat exp0 exp -> liftM2 G.C (transExp exp0) (transExp exp) + EGlue exp0 exp -> liftM2 G.Glue (transExp exp0) (transExp exp) + ELet defs exp -> do + exp' <- transExp exp + defs0 <- mapM locdef2fields defs + defs' <- mapM tryLoc $ concat defs0 + return $ M.mkLet defs' exp' + where + tryLoc (c,(mty,Just e)) = return (c,(mty,e)) + tryLoc (c,_) = Bad $ "local definition of" +++ GP.prt c +++ "without value" + + ELString (LString str) -> return $ G.K str + ELin id -> liftM G.LiT $ transIdent id + + _ -> Bad $ "translation not yet defined for" +++ printTree x ---- + +--- this is complicated: should we change Exp or G.Term ? + +erecord2term :: [LocDef] -> Err G.Term +erecord2term ds = do + ds' <- mapM locdef2fields ds + mkR $ concat ds' + where + mkR fs = do + fs' <- transF fs + return $ case fs' of + Left ts -> G.RecType ts + Right ds -> G.R ds + transF [] = return $ Left [] --- empty record always interpreted as record type + transF fs@(f:_) = case f of + (lab,(Just ty,Nothing)) -> mapM tryRT fs >>= return . Left + _ -> mapM tryR fs >>= return . Right + tryRT f = case f of + (lab,(Just ty,Nothing)) -> return (M.ident2label lab,ty) + _ -> Bad $ "illegal record type field" +++ GP.prt (fst f) --- manifest fields ?! + tryR f = case f of + (lab,(mty, Just t)) -> return (M.ident2label lab,(mty,t)) + _ -> Bad $ "illegal record field" +++ GP.prt (fst f) + + +locdef2fields d = case d of + LDDecl ids t -> do + labs <- mapM transIdent ids + t' <- transExp t + return [(lab,(Just t',Nothing)) | lab <- labs] + LDDef ids e -> do + labs <- mapM transIdent ids + e' <- transExp e + return [(lab,(Nothing, Just e')) | lab <- labs] + LDFull ids t e -> do + labs <- mapM transIdent ids + t' <- transExp t + e' <- transExp e + return [(lab,(Just t', Just e')) | lab <- labs] + +trLabel :: Label -> Err G.Label +trLabel x = case x of + + -- this case is for bward compatibiity and should be removed + LIdent (IC ('v':ds)) | all isDigit ds -> return $ G.LVar $ readIntArg ds + + LIdent (IC s) -> return $ G.LIdent s + LVar x -> return $ G.LVar $ fromInteger x + +transSort :: Sort -> Err String +transSort x = case x of + _ -> return $ printTree x + +transPatt :: Patt -> Err G.Patt +transPatt x = case x of + PW -> return G.wildPatt + PV id -> liftM G.PV $ transIdent id + PC id patts -> liftM2 G.PC (transIdent id) (mapM transPatt patts) + PCon id -> liftM2 G.PC (transIdent id) (return []) + PInt n -> return $ G.PInt (fromInteger n) + PStr str -> return $ G.PString str + PR pattasss -> do + let (lss,ps) = unzip [(ls,p) | PA ls p <- pattasss] + ls = map LIdent $ concat lss + liftM G.PR $ liftM2 zip (mapM trLabel ls) (mapM transPatt ps) + PTup pcs -> + liftM (G.PR . M.tuple2recordPatt) (mapM transPatt [e | PTComp e <- pcs]) + PQ id0 id -> liftM3 G.PP (transIdent id0) (transIdent id) (return []) + PQC id0 id patts -> + liftM3 G.PP (transIdent id0) (transIdent id) (mapM transPatt patts) + +transBind :: Bind -> Err Ident +transBind x = case x of + BIdent id -> transIdent id + BWild -> return identW + +transDecl :: Decl -> Err [G.Decl] +transDecl x = case x of + DDec binds exp -> do + xs <- mapM transBind binds + exp' <- transExp exp + return [(x,exp') | x <- xs] + DExp exp -> liftM (return . M.mkDecl) $ transExp exp + +transCases :: [Case] -> Err [G.Case] +transCases = liftM concat . mapM transCase + +transCase :: Case -> Err [G.Case] +transCase (Case pattalts exp) = do + patts <- mapM transPatt [p | AltP p <- pattalts] + exp' <- transExp exp + return [(p,exp') | p <- patts] + +transAltern :: Altern -> Err (G.Term, G.Term) +transAltern x = case x of + Alt exp0 exp -> liftM2 (,) (transExp exp0) (transExp exp) + +transParConstr :: ParConstr -> Err G.Param +transParConstr x = case x of + ParConstr id ddecls -> do + id' <- transIdent id + ddecls' <- mapM transDDecl ddecls + return (id',concat ddecls') + +transDDecl :: DDecl -> Err [G.Decl] +transDDecl x = case x of + DDDec binds exp -> transDecl $ DDec binds exp + DDExp exp -> transDecl $ DExp exp + +-- to deal with the old format, sort judgements in three modules, forming +-- their names from a given string, e.g. file name or overriding user-given string + +transOldGrammar :: OldGrammar -> String -> Err G.SourceGrammar +transOldGrammar x name = case x of + OldGr includes topdefs -> do --- includes must be collected separately + let moddefs = sortTopDefs topdefs + g1 <- transGrammar $ Gr moddefs + removeLiT g1 --- needed for bw compatibility with an obsolete feature + where + sortTopDefs ds = [mkAbs a,mkRes r,mkCnc c] + where (a,r,c) = foldr srt ([],[],[]) ds + srt d (a,r,c) = case d of + DefCat catdefs -> (d:a,r,c) + DefFun fundefs -> (d:a,r,c) + DefDef defs -> (d:a,r,c) + DefData pardefs -> (d:a,r,c) + DefPar pardefs -> (a,d:r,c) + DefOper defs -> (a,d:r,c) + DefLintype defs -> (a,d:r,c) + DefLincat defs -> (a,r,d:c) + DefLindef defs -> (a,r,d:c) + DefLin defs -> (a,r,d:c) + DefPattern defs -> (a,r,d:c) + DefFlag defs -> (a,r,d:c) --- a guess + DefPrintCat printdefs -> (a,r,d:c) + DefPrintFun printdefs -> (a,r,d:c) + DefPrintOld printdefs -> (a,r,d:c) + mkAbs a = MAbstract absName NoExt (Opens []) $ topDefs a + mkRes r = MResource resName NoExt (Opens []) $ topDefs r + mkCnc r = MConcrete cncName absName NoExt (Opens [OName resName]) $ topDefs r + topDefs t = t + + absName = identC topic + resName = identC ("Res" ++ lang) + cncName = identC lang + + (beg,rest) = span (/='.') name + (topic,lang) = case rest of -- to avoid overwriting old files + ".gf" -> ("Abs" ++ beg,"Cnc" ++ beg) + [] -> ("Abs" ++ beg,"Cnc" ++ beg) + _:s -> (beg, takeWhile (/='.') s) + +transInclude :: Include -> Err [FilePath] +transInclude x = case x of + NoIncl -> return [] + Incl filenames -> return $ map trans filenames + where + trans f = case f of + FString s -> s + FIdent (IC s) -> s + FSlash filename -> '/' : trans filename + FDot filename -> '.' : trans filename + FMinus filename -> '-' : trans filename + FAddId (IC s) filename -> s ++ trans filename + +termInPattern :: G.Term -> G.Term +termInPattern t = M.mkAbs xx $ G.R [(s, (Nothing, toP body))] where + toP t = case t of + G.Vr x -> G.P t s + _ -> M.composSafeOp toP t + s = G.LIdent "s" + (xx,body) = abss [] t + abss xs t = case t of + G.Abs x b -> abss (x:xs) b + _ -> (reverse xs,t) diff --git a/src/GF/Source/TestGF.hs b/src/GF/Source/TestGF.hs new file mode 100644 index 000000000..f1c8e49a1 --- /dev/null +++ b/src/GF/Source/TestGF.hs @@ -0,0 +1,22 @@ +-- automatically generated by BNF Converter +module TestGF where + +import LexGF +import ParGF +import SkelGF +import PrintGF +import AbsGF +import ErrM + +type ParseFun a = [Token] -> Err a + +runFile :: (Print a, Show a) => ParseFun a -> FilePath -> IO() +runFile p f = readFile f >>= run p + +run :: (Print a, Show a) => ParseFun a -> String -> IO() +run p s = case (p (myLexer s)) of + Bad s -> do putStrLn "\nParse Failed...\n" + putStrLn s + Ok tree -> do putStrLn "\nParse Successful!" + putStrLn $ "\n[Abstract Syntax]\n\n" ++ show tree + putStrLn $ "\n[Linearized tree]\n\n" ++ printTree tree diff --git a/src/GF/System/Arch.hs b/src/GF/System/Arch.hs new file mode 100644 index 000000000..5fb963fec --- /dev/null +++ b/src/GF/System/Arch.hs @@ -0,0 +1,71 @@ +module Arch ( + myStdGen, prCPU, selectLater, modifiedFiles, ModTime, getModTime,getNowTime, + welcomeArch, fetchCommand) where + +import Time +import Random +import CPUTime +import Monad (filterM) +import Directory +import Readline + +---- import qualified UnicodeF as U --(fudlogueWrite) + +-- architecture/compiler dependent definitions for unix/hbc + +myStdGen :: Int -> IO StdGen --- +--- myStdGen _ = newStdGen --- gives always the same result +myStdGen int0 = do + t0 <- getClockTime + cal <- toCalendarTime t0 + let int = int0 + ctSec cal + fromInteger (div (ctPicosec cal) 10000000) + return $ mkStdGen int + +prCPU cpu = do + cpu' <- getCPUTime + putStrLn (show ((cpu' - cpu) `div` 1000000000) ++ " msec") + return cpu' + +welcomeArch = "This is the system compiled with ghc." + +fetchCommand :: String -> IO (String) +fetchCommand s = do + res <- readline s + case res of + Nothing -> return "q" + Just s -> do addHistory s + return s + +-- selects the one with the later modification time of two + +selectLater :: FilePath -> FilePath -> IO FilePath +selectLater x y = do + ex <- doesFileExist x + if not ex + then return y --- which may not exist + else do + ey <- doesFileExist y + if not ey + then return x + else do + tx <- getModificationTime x + ty <- getModificationTime y + return $ if tx < ty then y else x + +-- a file is considered as modified also if it has not been read yet + +modifiedFiles :: [(FilePath,ModTime)] -> [FilePath] -> IO [FilePath] +modifiedFiles ofs fs = print (map fst ofs) >> filterM isModified fs where + isModified file = case lookup file ofs of + Just to -> do + t <- getModTime file + return $ to < t + _ -> return True + +type ModTime = ClockTime + +getModTime :: FilePath -> IO ModTime +getModTime = getModificationTime + +getNowTime :: IO ModTime +getNowTime = getClockTime diff --git a/src/GF/Text/Arabic.hs b/src/GF/Text/Arabic.hs new file mode 100644 index 000000000..6df79c4a9 --- /dev/null +++ b/src/GF/Text/Arabic.hs @@ -0,0 +1,48 @@ +module Arabic where + +mkArabic :: String -> String +mkArabic = reverse . unwords . (map mkArabicWord) . words +--- reverse : assumes everything's on same line + +type ArabicChar = Char + +mkArabicWord :: String -> [ArabicChar] +mkArabicWord = map mkArabicChar . getLetterPos + +getLetterPos :: String -> [(Char,Int)] +getLetterPos [] = [] +getLetterPos ('I':cs) = ('*',7) : getLetterPos cs -- 0xfe80 +getLetterPos ('O':cs) = ('*',8) : getIn cs -- 0xfe8b +getLetterPos ('l':'a':cs) = ('*',5) : getLetterPos cs -- 0xfefb +getLetterPos [c] = [(c,1)] -- 1=isolated +getLetterPos (c:cs) | isReduced c = (c,1) : getLetterPos cs +getLetterPos (c:cs) = (c,3) : getIn cs -- 3=initial + + +getIn [] = [] +getIn ('I':cs) = ('*',7) : getLetterPos cs -- 0xfe80 +getIn ('O':cs) = ('*',9) : getIn cs -- 0xfe8c +getIn ('l':'a':cs) = ('*',6) : getLetterPos cs -- 0xfefc +getIn [c] = [(c,2)] -- 2=final +getIn (c:cs) | isReduced c = (c,2) : getLetterPos cs +getIn (c:cs) = (c,4) : getIn cs -- 4=medial + +isReduced :: Char -> Bool +isReduced c = c `elem` "UuWiYOaAdVrzwj" + +mkArabicChar ('*',p) | p > 4 && p < 10 = + (map toEnum [0xfefb,0xfefc,0xfe80,0xfe8b,0xfe8c]) !! (p-5) +mkArabicChar cp@(c,p) = case lookup c cc of Just c' -> (c' !! (p-1)) ; _ -> c + where + cc = mkArabicTab allArabicCodes allArabic + +mkArabicTab (c:cs) as = (c,as1) : mkArabicTab cs as2 where + (as1,as2) = if isReduced c then splitAt 2 as else splitAt 4 as +mkArabicTab [] _ = [] + +allArabicCodes = "UuWiYOabAtvgHCdVrzscSDTZoxfqklmnhwjy" + +allArabic :: String +allArabic = (map toEnum [0xfe81 .. 0xfef4]) -- I=0xfe80 + + diff --git a/src/GF/Text/Greek.hs b/src/GF/Text/Greek.hs new file mode 100644 index 000000000..8cbba8c54 --- /dev/null +++ b/src/GF/Text/Greek.hs @@ -0,0 +1,158 @@ +module Greek where + +mkGreek :: String -> String +mkGreek = unwords . (map mkGreekWord) . mkGravis . words + +--- TODO : optimize character formation by factorizing the case expressions + +type GreekChar = Char + +mkGreekWord :: String -> [GreekChar] +mkGreekWord = map (toEnum . mkGreekChar) . mkGreekSpec + +mkGravis :: [String] -> [String] +mkGravis [] = [] +mkGravis [w] = [w] +mkGravis (w1:w2:ws) + | stressed w2 = mkG w1 : mkGravis (w2:ws) + | otherwise = w1 : w2 : mkGravis ws + where + stressed w = any (`elem` "'~`") w + mkG :: String -> String + mkG w = let (w1,w2) = span (/='\'') w in + case w2 of + '\'':v:cs | not (any isVowel cs) -> w1 ++ "`" ++ [v] ++ cs + '\'':'!':v:cs | not (any isVowel cs) -> w1 ++ "`!" ++ [v] ++ cs + _ -> w + isVowel c = elem c "aehiouw" + +mkGreekSpec :: String -> [(Char,Int)] +mkGreekSpec str = case str of + [] -> [] + '(' :'\'': '!' : c : cs -> (c,25) : mkGreekSpec cs + '(' :'~' : '!' : c : cs -> (c,27) : mkGreekSpec cs + '(' :'`' : '!' : c : cs -> (c,23) : mkGreekSpec cs + '(' : '!' : c : cs -> (c,21) : mkGreekSpec cs + ')' :'\'': '!' : c : cs -> (c,24) : mkGreekSpec cs + ')' :'~' : '!' : c : cs -> (c,26) : mkGreekSpec cs + ')' :'`' : '!' : c : cs -> (c,22) : mkGreekSpec cs + ')' : '!' : c : cs -> (c,20) : mkGreekSpec cs + '\'': '!' : c : cs -> (c,30) : mkGreekSpec cs + '~' : '!' : c : cs -> (c,31) : mkGreekSpec cs + '`' : '!' : c : cs -> (c,32) : mkGreekSpec cs + '!' : c : cs -> (c,33) : mkGreekSpec cs + '(' :'\'': c : cs -> (c,5) : mkGreekSpec cs + '(' :'~' : c : cs -> (c,7) : mkGreekSpec cs + '(' :'`' : c : cs -> (c,3) : mkGreekSpec cs + '(' : c : cs -> (c,1) : mkGreekSpec cs + ')' :'\'': c : cs -> (c,4) : mkGreekSpec cs + ')' :'~' : c : cs -> (c,6) : mkGreekSpec cs + ')' :'`' : c : cs -> (c,2) : mkGreekSpec cs + ')' : c : cs -> (c,0) : mkGreekSpec cs + '\'': c : cs -> (c,10) : mkGreekSpec cs + '~' : c : cs -> (c,11) : mkGreekSpec cs + '`' : c : cs -> (c,12) : mkGreekSpec cs + c : cs -> (c,-1) : mkGreekSpec cs + +mkGreekChar (c,-1) = case lookup c cc of Just c' -> c' ; _ -> fromEnum c + where + cc = zip "abgdezhqiklmnxoprjstyfcuw" allGreekMin +mkGreekChar (c,n) = case (c,n) of + ('a',10) -> 0x03ac + ('a',11) -> 0x1fb6 + ('a',12) -> 0x1f70 + ('a',30) -> 0x1fb4 + ('a',31) -> 0x1fb7 + ('a',32) -> 0x1fb2 + ('a',33) -> 0x1fb3 + ('a',n) | n >19 -> 0x1f80 + n - 20 + ('a',n) -> 0x1f00 + n + ('e',10) -> 0x03ad -- ' +-- ('e',11) -> 0x1fb6 -- ~ can't happen + ('e',12) -> 0x1f72 -- ` + ('e',n) -> 0x1f10 + n + ('h',10) -> 0x03ae -- ' + ('h',11) -> 0x1fc6 -- ~ + ('h',12) -> 0x1f74 -- ` + + ('h',30) -> 0x1fc4 + ('h',31) -> 0x1fc7 + ('h',32) -> 0x1fc2 + ('h',33) -> 0x1fc3 + ('h',n) | n >19 -> 0x1f90 + n - 20 + + ('h',n) -> 0x1f20 + n + ('i',10) -> 0x03af -- ' + ('i',11) -> 0x1fd6 -- ~ + ('i',12) -> 0x1f76 -- ` + ('i',n) -> 0x1f30 + n + ('o',10) -> 0x03cc -- ' +-- ('o',11) -> 0x1fb6 -- ~ can't happen + ('o',12) -> 0x1f78 -- ` + ('o',n) -> 0x1f40 + n + ('y',10) -> 0x03cd -- ' + ('y',11) -> 0x1fe6 -- ~ + ('y',12) -> 0x1f7a -- ` + ('y',n) -> 0x1f50 + n + ('w',10) -> 0x03ce -- ' + ('w',11) -> 0x1ff6 -- ~ + ('w',12) -> 0x1f7c -- ` + + ('w',30) -> 0x1ff4 + ('w',31) -> 0x1ff7 + ('w',32) -> 0x1ff2 + ('w',33) -> 0x1ff3 + ('w',n) | n >19 -> 0x1fa0 + n - 20 + + ('w',n) -> 0x1f60 + n + ('r',1) -> 0x1fe5 + _ -> mkGreekChar (c,-1) --- should not happen + +allGreekMin :: [Int] +allGreekMin = [0x03b1 .. 0x03c9] + + +{- +encoding of Greek writing. Those hard to guess are marked with --- + + maj min +A a Alpha 0391 03b1 +B b Beta 0392 03b2 +G g Gamma 0393 03b3 +D d Delta 0394 03b4 +E e Epsilon 0395 03b5 +Z z Zeta 0396 03b6 +H h Eta --- 0397 03b7 +Q q Theta --- 0398 03b8 +I i Iota 0399 03b9 +K k Kappa 039a 03ba +L l Lambda 039b 03bb +M m My 039c 03bc +N n Ny 039d 03bd +X x Xi 039e 03be +O o Omikron 039f 03bf +P p Pi 03a0 03c0 +R r Rho 03a1 03c1 + j Sigma --- 03c2 +S s Sigma 03a3 03c3 +T t Tau 03a4 03c4 +Y y Ypsilon 03a5 03c5 +F f Phi 03a6 03c6 +C c Khi --- 03a7 03c7 +U u Psi 03a8 03c8 +W w Omega --- 03a9 03c9 + +( spiritus asper +) spiritus lenis +! iota subscriptum + +' acutus +~ circumflexus +` gravis + +-} + + + + + diff --git a/src/GF/Text/Hebrew.hs b/src/GF/Text/Hebrew.hs new file mode 100644 index 000000000..ebcc078e3 --- /dev/null +++ b/src/GF/Text/Hebrew.hs @@ -0,0 +1,21 @@ +module Hebrew where + +mkHebrew :: String -> String +mkHebrew = reverse . unwords . (map mkHebrewWord) . words +--- reverse : assumes everything's on same line + +type HebrewChar = Char + +mkHebrewWord :: String -> [HebrewChar] +mkHebrewWord = map mkHebrewChar + +mkHebrewChar c = case lookup c cc of Just c' -> c' ; _ -> c + where + cc = zip allHebrewCodes allHebrew + +allHebrewCodes = "-abgdhwzHTyKklMmNnSoPpCcqrst" + +allHebrew :: String +allHebrew = (map toEnum (0x05be : [0x05d0 .. 0x05ea])) + + diff --git a/src/GF/Text/Russian.hs b/src/GF/Text/Russian.hs new file mode 100644 index 000000000..07605a83a --- /dev/null +++ b/src/GF/Text/Russian.hs @@ -0,0 +1,31 @@ +module Russian where + +-- an ad hoc ASCII encoding. Delimiters: /_ _/ +mkRussian :: String -> String +mkRussian = unwords . (map mkRussianWord) . words + +-- the KOI8 encoding, incomplete. Delimiters: /* */ +mkRusKOI8 :: String -> String +mkRusKOI8 = unwords . (map mkRussianKOI8) . words + +type RussianChar = Char + +mkRussianWord :: String -> [RussianChar] +mkRussianWord = map (mkRussianChar allRussianCodes) + +mkRussianKOI8 :: String -> [RussianChar] +mkRussianKOI8 = map (mkRussianChar allRussianKOI8) + +mkRussianChar chars c = case lookup c cc of Just c' -> c' ; _ -> c + where + cc = zip chars allRussian + +allRussianCodes = + "ÅåABVGDEXZIJKLMNOPRSTUFHCQW£}!*ÖYÄabvgdexzijklmnoprstufhcqw#01'öyä" +allRussianKOI8 = + "^@áâ÷çäåöúéêëìíîïðòóôõæèãþûýøùÿüàñÁÂ×ÇÄÅÖÚÉÊËÌÍÎÏÐÒÓÔÕÆÈÃÞÛÝØÙßÜÀÑ" + +allRussian :: String +allRussian = (map toEnum (0x0401:0x0451:[0x0410 .. 0x044f])) -- Ëë in odd places + + diff --git a/src/GF/Text/Text.hs b/src/GF/Text/Text.hs new file mode 100644 index 000000000..08e897a9b --- /dev/null +++ b/src/GF/Text/Text.hs @@ -0,0 +1,56 @@ +module Text where + +import Operations +import Char + +-- elementary text postprocessing. AR 21/11/2001 +-- This is very primitive indeed. The functions should work on +-- token lists and not on strings. AR 5/12/2002 + + +formatAsTextLit :: String -> String +formatAsTextLit = formatAsText . unwords . map unStringLit . words +--- hope that there will be deforestation... + +formatAsCodeLit :: String -> String +formatAsCodeLit = formatAsCode . unwords . map unStringLit . words + +formatAsText :: String -> String +formatAsText = unwords . format . cap . words where + format ws = case ws of + w : c : ww | major c -> (w ++ c) : format (cap ww) + w : c : ww | minor c -> (w ++ c) : format ww + c : ww | para c -> "\n\n" : format ww + w : ww -> w : format ww + [] -> [] + cap (p:(c:cs):ww) | para p = p : (toUpper c : cs) : ww + cap ((c:cs):ww) = (toUpper c : cs) : ww + cap [] = [] + major = flip elem (map singleton ".!?") + minor = flip elem (map singleton ",:;") + para = (=="<p>") + +formatAsCode :: String -> String +formatAsCode = unwords . format . words where + format ws = case ws of + p : w : ww | parB p -> format ((p ++ w') : ww') where (w':ww') = format (w:ww) + w : p : ww | par p -> format ((w ++ p') : ww') where (p':ww') = format (p:ww) + w : ww -> w : format ww + [] -> [] + parB = flip elem (map singleton "([{") + parE = flip elem (map singleton "}])") + par t = parB t || parE t + +performBinds :: String -> String +performBinds = unwords . format . words where + format ws = case ws of + w : "&+" : u : ws -> format ((w ++ u) : ws) + w : ws -> w : format ws + [] -> [] + +unStringLit :: String -> String +unStringLit s = case s of + c : cs | strlim c && strlim (last cs) -> init cs + _ -> s + where + strlim = (=='\'') diff --git a/src/GF/Text/UTF8.hs b/src/GF/Text/UTF8.hs new file mode 100644 index 000000000..57b711b4b --- /dev/null +++ b/src/GF/Text/UTF8.hs @@ -0,0 +1,35 @@ +module UTF8 where + +-- From the Char module supplied with HBC. +-- code by Thomas Hallgren (Jul 10 1999) + +-- Take a Unicode string and encode it as a string +-- with the UTF8 method. +decodeUTF8 :: String -> String +decodeUTF8 "" = "" +decodeUTF8 (c:cs) | c < '\x80' = c : decodeUTF8 cs +decodeUTF8 (c:c':cs) | '\xc0' <= c && c <= '\xdf' && + '\x80' <= c' && c' <= '\xbf' = + toEnum ((fromEnum c `mod` 0x20) * 0x40 + fromEnum c' `mod` 0x40) : decodeUTF8 cs +decodeUTF8 (c:c':c'':cs) | '\xe0' <= c && c <= '\xef' && + '\x80' <= c' && c' <= '\xbf' && + '\x80' <= c'' && c'' <= '\xbf' = + toEnum ((fromEnum c `mod` 0x10 * 0x1000) + (fromEnum c' `mod` 0x40) * 0x40 + fromEnum c'' `mod` 0x40) : decodeUTF8 cs +decodeUTF8 _ = error "UniChar.decodeUTF8: bad data" + +encodeUTF8 :: String -> String +encodeUTF8 "" = "" +encodeUTF8 (c:cs) = + if c > '\x0000' && c < '\x0080' then + c : encodeUTF8 cs + else if c < toEnum 0x0800 then + let i = fromEnum c + in toEnum (0xc0 + i `div` 0x40) : + toEnum (0x80 + i `mod` 0x40) : + encodeUTF8 cs + else + let i = fromEnum c + in toEnum (0xe0 + i `div` 0x1000) : + toEnum (0x80 + (i `mod` 0x1000) `div` 0x40) : + toEnum (0x80 + i `mod` 0x40) : + encodeUTF8 cs diff --git a/src/GF/Text/Unicode.hs b/src/GF/Text/Unicode.hs new file mode 100644 index 000000000..78aba0461 --- /dev/null +++ b/src/GF/Text/Unicode.hs @@ -0,0 +1,24 @@ +module Unicode where + +import Greek (mkGreek) +import Arabic (mkArabic) +import Hebrew (mkHebrew) +import Russian (mkRussian, mkRusKOI8) + +-- ad hoc Unicode conversions from different alphabets + +-- AR 12/4/2000, 18/9/2001, 30/5/2002 + +mkUnicode s = case s of + '/':'/':cs -> mkGreek (remClosing cs) + '/':'+':cs -> mkHebrew (remClosing cs) + '/':'-':cs -> mkArabic (remClosing cs) + '/':'_':cs -> mkRussian (remClosing cs) + '/':'*':cs -> mkRusKOI8 (remClosing cs) + _ -> s + +remClosing cs + | lcs > 1 && last cs == '/' = take (lcs-2) cs + | otherwise = cs + where lcs = length cs + diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs new file mode 100644 index 000000000..bf84d776b --- /dev/null +++ b/src/GF/UseGrammar/Custom.hs @@ -0,0 +1,256 @@ +module Custom where + +import Operations +import Text +import Tokenize +import qualified Grammar as G +import qualified AbsGFC as A +import qualified GFC as C +import qualified AbsGF as GF +import qualified MMacros as MM +import AbsCompute +import TypeCheck +------import Compile +import ShellState +import Editing +import Paraphrases +import Option +import CF +import CFIdent + +---- import CFtoGrammar +import PPrCF +import PrGrammar + +----import Morphology +-----import GrammarToHaskell +-----import GrammarToCanon (showCanon, showCanonOpt) +-----import qualified GrammarToGFC as GFC + +-- the cf parsing algorithms +import ChartParser -- or some other CF Parser + +import MoreCustom -- either small/ or big/. The one in Small is empty. + +import UseIO + +-- minimal version also used in Hugs. AR 2/12/2002. + +-- databases for customizable commands. AR 21/11/2001 +-- for: grammar parsers, grammar printers, term commands, string commands +-- idea: items added here are usable throughout GF; nothing else need be edited +-- they are often usable through the API: hence API cannot be imported here! + +-- Major redesign 3/4/2002: the first entry in each database is DEFAULT. +-- If no other value is given, the default is selected. +-- Because of this, two invariants have to be preserved: +-- ** no databases may be empty +-- ** additions are made to the end of the database + +-- these are the databases; the comment gives the name of the flag + +-- grammarFormat, "-format=x" or file suffix +customGrammarParser :: CustomData (FilePath -> IOE C.CanonGrammar) + +-- grammarPrinter, "-printer=x" +customGrammarPrinter :: CustomData (StateGrammar -> String) + +-- syntaxPrinter, "-printer=x" +customSyntaxPrinter :: CustomData (GF.Grammar -> String) + +-- termPrinter, "-printer=x" +customTermPrinter :: CustomData (StateGrammar -> A.Exp -> String) + +-- termCommand, "-transform=x" +customTermCommand :: CustomData (StateGrammar -> A.Exp -> [A.Exp]) + +-- editCommand, "-edit=x" +customEditCommand :: CustomData (StateGrammar -> Action) + +-- filterString, "-filter=x" +customStringCommand :: CustomData (StateGrammar -> String -> String) + +-- useParser, "-parser=x" +customParser :: CustomData (StateGrammar -> CFCat -> CFParser) + +-- useTokenizer, "-lexer=x" +customTokenizer :: CustomData (StateGrammar -> String -> [CFTok]) + +-- useUntokenizer, "-unlexer=x" --- should be from token list to string +customUntokenizer :: CustomData (StateGrammar -> String -> String) + + +-- this is the way of selecting an item +customOrDefault :: Options -> OptFun -> CustomData a -> a +customOrDefault opts optfun db = maybe (defaultCustomVal db) id $ + customAsOptVal opts optfun db + +-- to produce menus of custom operations +customInfo :: CustomData a -> (String, [String]) +customInfo c = (titleCustomData c, map (ciStr . fst) (dbCustomData c)) + +------------------------------- + +type CommandId = String + +strCI :: String -> CommandId +strCI = id + +ciStr :: CommandId -> String +ciStr = id + +ciOpt :: CommandId -> Option +ciOpt = iOpt + +newtype CustomData a = CustomData (String, [(CommandId,a)]) +customData title db = CustomData (title,db) +dbCustomData (CustomData (_,db)) = db +titleCustomData (CustomData (t,_)) = t + +lookupCustom :: CustomData a -> CommandId -> Maybe a +lookupCustom = flip lookup . dbCustomData + +customAsOptVal :: Options -> OptFun -> CustomData a -> Maybe a +customAsOptVal opts optfun db = do + arg <- getOptVal opts optfun + lookupCustom db (strCI arg) + +-- take the first entry from the database +defaultCustomVal :: CustomData a -> a +defaultCustomVal (CustomData (s,db)) = + ifNull (error ("empty database:" +++ s)) (snd . head) db + +------------------------------------------------------------------------- +-- and here's the customizable part: + +-- grammar parsers: the ID is also used as file name suffix +customGrammarParser = + customData "Grammar parsers, selected by file name suffix" $ + [ +------ (strCI "gf", compileModule noOptions) -- DEFAULT +-- add your own grammar parsers here + ] + ++ moreCustomGrammarParser + + +customGrammarPrinter = + customData "Grammar printers, selected by option -printer=x" $ + [ +---- (strCI "gf", prt) -- DEFAULT + (strCI "cf", prCF . stateCF) + +{- ---- + (strCI "gf", prt . st2grammar . stateGrammarST) -- DEFAULT + ,(strCI "canon", showCanon "Lang" . stateGrammarST) + ,(strCI "gfc", GFC.showGFC . stateGrammarST) + ,(strCI "canonOpt",showCanonOpt "Lang" . stateGrammarST) + ,(strCI "morpho", prMorpho . stateMorpho) + ,(strCI "opts", prOpts . stateOptions) +-} +-- add your own grammar printers here +--- also include printing via grammar2syntax! + ] + ++ moreCustomGrammarPrinter + +customSyntaxPrinter = + customData "Syntax printers, selected by option -printer=x" $ + [ +-- add your own grammar printers here + ] + ++ moreCustomSyntaxPrinter + + +customTermPrinter = + customData "Term printers, selected by option -printer=x" $ + [ + (strCI "gf", const prt) -- DEFAULT +-- add your own term printers here + ] + ++ moreCustomTermPrinter + +customTermCommand = + customData "Term transformers, selected by option -transform=x" $ + [ + (strCI "identity", \_ t -> [t]) -- DEFAULT +{- ---- + ,(strCI "compute", \g t -> err (const [t]) return (computeAbsTerm g t)) + ,(strCI "paraphrase", \g t -> mkParaphrases g t) + ,(strCI "typecheck", \g t -> err (const []) return (checkIfValidExp g t)) + ,(strCI "solve", \g t -> editAsTermCommand g + (uniqueRefinements g) t) + ,(strCI "context", \g t -> editAsTermCommand g + (contextRefinements g) t) +-} +--- ,(strCI "delete", \g t -> [MM.mExp0]) +-- add your own term commands here + ] + ++ moreCustomTermCommand + +customEditCommand = + customData "Editor state transformers, selected by option -edit=x" $ + [ + (strCI "identity", const return) -- DEFAULT + ,(strCI "transfer", const return) --- done ad hoc on top level +{- ---- + ,(strCI "typecheck", reCheckState) + ,(strCI "solve", solveAll) + ,(strCI "context", contextRefinements) + ,(strCI "compute", computeSubTree) +-} + ,(strCI "paraphrase", const return) --- done ad hoc on top level +-- add your own edit commands here + ] + ++ moreCustomEditCommand + +customStringCommand = + customData "String filters, selected by option -filter=x" $ + [ + (strCI "identity", const $ id) -- DEFAULT + ,(strCI "erase", const $ const "") + ,(strCI "take100", const $ take 100) + ,(strCI "text", const $ formatAsText) + ,(strCI "code", const $ formatAsCode) +---- ,(strCI "latexfile", const $ mkLatexFile) + ,(strCI "length", const $ show . length) +-- add your own string commands here + ] + ++ moreCustomStringCommand + +customParser = + customData "Parsers, selected by option -parser=x" $ + [ + (strCI "chart", chartParser . stateCF) +-- add your own parsers here + ] + ++ moreCustomParser + +customTokenizer = + customData "Tokenizers, selected by option -lexer=x" $ + [ + (strCI "words", const $ tokWords) + ,(strCI "literals", const $ tokLits) + ,(strCI "vars", const $ tokVars) + ,(strCI "chars", const $ map (tS . singleton)) + ,(strCI "code", const $ lexHaskell) + ,(strCI "text", const $ lexText) +---- ,(strCI "codelit", lexHaskellLiteral . stateIsWord) +---- ,(strCI "textlit", lexTextLiteral . stateIsWord) + ,(strCI "codeC", const $ lexC2M) + ,(strCI "codeCHigh", const $ lexC2M' True) +-- add your own tokenizers here + ] + ++ moreCustomTokenizer + +customUntokenizer = + customData "Untokenizers, selected by option -unlexer=x" $ + [ + (strCI "unwords", const $ id) -- DEFAULT + ,(strCI "text", const $ formatAsText) + ,(strCI "code", const $ formatAsCode) + ,(strCI "textlit", const $ formatAsTextLit) + ,(strCI "codelit", const $ formatAsCodeLit) + ,(strCI "concat", const $ concat . words) + ,(strCI "bind", const $ performBinds) +-- add your own untokenizers here + ] + ++ moreCustomUntokenizer diff --git a/src/GF/UseGrammar/Editing.hs b/src/GF/UseGrammar/Editing.hs new file mode 100644 index 000000000..616ddc7cc --- /dev/null +++ b/src/GF/UseGrammar/Editing.hs @@ -0,0 +1,358 @@ +module Editing where + +import Abstract +import qualified GFC +import TypeCheck +import LookAbs +import AbsCompute + +import Operations +import Zipper + +-- generic tree editing, with some grammar notions assumed. AR 18/8/2001 +-- 19/6/2003 for GFC + +type CGrammar = GFC.CanonGrammar + +type State = Loc TrNode + +-- the "empty" state +initState :: State +initState = tree2loc uTree + +isRootState :: State -> Bool +isRootState s = case actPath s of + Top -> True + _ -> False + +actTree :: State -> Tree +actTree (Loc (t,_)) = t + +actPath :: State -> Path TrNode +actPath (Loc (_,p)) = p + +actVal :: State -> Val +actVal = valNode . nodeTree . actTree + +actCat :: State -> Cat +actCat = errVal undefined . val2cat . actVal ---- undef + +actAtom :: State -> Atom +actAtom = atomTree . actTree + +actExp = tree2exp . actTree + +-- current local bindings +actBinds :: State -> Binds +actBinds = bindsNode . nodeTree . actTree + +-- constraints in current subtree +actConstrs :: State -> Constraints +actConstrs = allConstrsTree . actTree + +-- constraints in the whole tree +allConstrs :: State -> Constraints +allConstrs = allConstrsTree . loc2tree + +-- metas in current subtree +actMetas :: State -> [Meta] +actMetas = metasTree . actTree + +-- metas in the whole tree +allMetas :: State -> [Meta] +allMetas = metasTree . loc2tree + +actTreeBody :: State -> Tree +actTreeBody = bodyTree . actTree + +allPrevBinds :: State -> Binds +allPrevBinds = concatMap bindsNode . traverseCollect . actPath + +allBinds :: State -> Binds +allBinds s = actBinds s ++ allPrevBinds s + +actGen :: State -> Int +actGen = length . allBinds -- symbol generator for VGen + +allPrevVars :: State -> [Var] +allPrevVars = map fst . allPrevBinds + +allVars :: State -> [Var] +allVars = map fst . allBinds + +vGenIndex = length . allBinds + +actIsMeta = atomIsMeta . actAtom + +actMeta :: State -> Err Meta +actMeta = getMetaAtom . actAtom + +-- meta substs are not only on the actual path... +entireMetaSubst :: State -> MetaSubst +entireMetaSubst = concatMap metaSubstsNode . scanTree . loc2tree + +isCompleteTree = null . filter atomIsMeta . map atomNode . scanTree +isCompleteState = isCompleteTree . loc2tree + +initStateCat :: Context -> Cat -> Err State +initStateCat cont cat = do + return $ tree2loc (Tr (mkNode [] mAtom (cat2val cont cat) ([],[]), [])) + +-- this function only concerns the body of an expression... +annotateInState :: CGrammar -> Exp -> State -> Err Tree +annotateInState gr exp state = do + let binds = allBinds state + val = actVal state + annotateIn gr binds exp (Just val) + +-- ...whereas this one works with lambda abstractions +annotateExpInState :: CGrammar -> Exp -> State -> Err Tree +annotateExpInState gr exp state = do + let cont = allPrevBinds state + binds = actBinds state + val = actVal state + typ <- mkProdVal binds val + annotateIn gr binds exp (Just typ) + +treeByExp :: (Exp -> Err Exp) -> CGrammar -> Exp -> State -> Err Tree +treeByExp trans gr exp0 state = do + exp <- trans exp0 + annotateExpInState gr exp state + +-- actions + +type Action = State -> Err State + +newCat :: CGrammar -> Cat -> Action +newCat gr cat@(m,c) _ = do + cont <- lookupCatContext gr m c + testErr (null cont) "start cat must have null context" -- for easier meta refresh + initStateCat cont cat + +newTree :: Tree -> Action +newTree t _ = return $ tree2loc t + +newExpTC :: CGrammar -> Exp -> Action +newExpTC gr t s = annotate gr (refreshMetas [] t) >>= flip newTree s + +goNextMeta, goPrevMeta, goNextNewMeta, goPrevNewMeta, goNextMetaIfCan :: Action + +goNextMeta = repeatUntilErr actIsMeta goAhead -- can be the location itself +goPrevMeta = repeatUntilErr actIsMeta goBack + +goNextNewMeta s = goAhead s >>= goNextMeta -- always goes away from location +goPrevNewMeta s = goBack s >>= goPrevMeta + +goNextMetaIfCan = actionIfPossible goNextMeta + +actionIfPossible a s = return $ errVal s (a s) + +goFirstMeta, goLastMeta :: Action +goFirstMeta s = goNextMeta $ goRoot s +goLastMeta s = goLast s >>= goPrevMeta + +noMoreMetas :: State -> Bool +noMoreMetas = err (const True) (const False) . goNextMeta + +replaceSubTree :: Tree -> Action +replaceSubTree tree state = changeLoc state tree + +refineWithTree :: Bool -> CGrammar -> Tree -> Action +refineWithTree der gr tree state = do + m <- errIn "move pointer to meta" $ actMeta state + state' <- replaceSubTree tree state + let cs0 = allConstrs state' + (cs,ms) = splitConstraints cs0 + v = vClos $ tree2exp (bodyTree tree) + msubst = (m,v) : ms + metaSubstRefinements gr msubst $ mapLoc (performMetaSubstNode msubst) state' + + -- without dep. types, no constraints, no grammar needed - simply: do + -- testErr (actIsMeta state) "move pointer to meta" + -- replaceSubTree tree state + +refineAllNodes :: Action -> Action +refineAllNodes act state = do + let estate0 = goFirstMeta state + case estate0 of + Bad _ -> return state + Ok state0 -> do + (state',n) <- tryRefine 0 state0 + if n==0 + then return state + else actionIfPossible goFirstMeta state' + where + tryRefine n state = err (const $ return (state,n)) return $ do + state' <- goNextMeta state + meta <- actMeta state' + case act state' of + Ok state2 -> tryRefine (n+1) state2 + _ -> err (const $ return (state',n)) return $ do + state2 <- goNextNewMeta state' + tryRefine n state2 + +uniqueRefinements :: CGrammar -> Action +uniqueRefinements = refineAllNodes . uniqueRefine + +metaSubstRefinements :: CGrammar -> MetaSubst -> Action +metaSubstRefinements gr = refineAllNodes . metaSubstRefine gr + +contextRefinements :: CGrammar -> Action +contextRefinements gr = refineAllNodes contextRefine where + contextRefine state = case varRefinementsState state of + [(e,_)] -> refineWithAtom False gr e state + _ -> Bad "no unique refinement in context" + varRefinementsState state = + [r | r@(e,_) <- refinementsState gr state, isVariable e] + +uniqueRefine :: CGrammar -> Action +uniqueRefine gr state = case refinementsState gr state of + [(e,_)] -> refineWithAtom False gr e state + _ -> Bad "no unique refinement" + +metaSubstRefine :: CGrammar -> MetaSubst -> Action +metaSubstRefine gr msubst state = do + m <- errIn "move pointer to meta" $ actMeta state + case lookup m msubst of + Just v -> do + e <- val2expSafe v + refineWithExpTC False gr e state + _ -> Bad "no metavariable substitution available" + +refineWithExpTC :: Bool -> CGrammar -> Exp -> Action +refineWithExpTC der gr exp0 state = do + let oldmetas = allMetas state + exp = refreshMetas oldmetas exp0 + tree0 <- annotateInState gr exp state + let tree = addBinds (actBinds state) $ tree0 + refineWithTree der gr tree state + +refineWithAtom :: Bool -> CGrammar -> Ref -> Action -- function or variable +refineWithAtom der gr at state = do + val <- lookupRef gr (allBinds state) at + typ <- val2exp val + let oldvars = allVars state + exp <- ref2exp oldvars typ at + refineWithExpTC der gr exp state + +-- in this command, we know that the result is well-typed, since computation +-- rules have been type checked and the result is equal + +computeSubTree :: CGrammar -> Action +computeSubTree gr state = do + let exp = tree2exp (actTree state) + tree <- treeByExp (compute gr) gr exp state + replaceSubTree tree state + +-- but here we don't, since the transfer flag isn't type checked, +-- and computing the transfer function is not checked to preserve equality + +transferSubTree :: Maybe Fun -> CGrammar -> Action +transferSubTree Nothing _ s = return s +transferSubTree (Just fun) gr state = do + let exp = mkApp (qq fun) [tree2exp $ actTree state] + tree <- treeByExp (compute gr) gr exp state + state' <- replaceSubTree tree state + reCheckState gr state' + +deleteSubTree :: CGrammar -> Action +deleteSubTree gr state = + if isRootState state + then do + let cat = actCat state + newCat gr cat state + else do + let metas = allMetas state + binds = actBinds state + exp = refreshMetas metas mExp0 + tree <- annotateInState gr exp state + state' <- replaceSubTree (addBinds binds tree) state + reCheckState gr state' --- must be unfortunately done. 20/11/2001 + +wrapWithFun :: CGrammar -> (Fun,Int) -> Action +wrapWithFun gr (f@(m,c),i) state = do + typ <- lookupFunType gr m c + let olds = allPrevVars state + oldmetas = allMetas state + exp0 <- fun2wrap olds ((f,i),typ) (tree2exp (actTreeBody state)) + let exp = refreshMetas oldmetas exp0 + tree0 <- annotateInState gr exp state + let tree = addBinds (actBinds state) $ tree0 + state' <- replaceSubTree tree state + reCheckState gr state' --- must be unfortunately done. 20/11/2001 + +alphaConvert :: CGrammar -> (Var,Var) -> Action +alphaConvert gr (x,x') state = do + let oldvars = allPrevVars state + testErr (notElem x' oldvars) ("clash with previous bindings" +++ show x') + let binds0 = actBinds state + vars0 = map fst binds0 + testErr (notElem x' vars0) ("clash with other bindings" +++ show x') + let binds = [(if z==x then x' else z, t) | (z,t) <- binds0] + vars = map fst binds + exp' <- alphaConv (vars ++ oldvars) (x,x') (tree2exp (actTreeBody state)) + let exp = mkAbs vars exp' + tree <- annotateExpInState gr exp state + replaceSubTree tree state + +changeFunHead :: CGrammar -> Fun -> Action +changeFunHead gr f state = do + let state' = changeNode (changeAtom (const (atomC f))) state + reCheckState gr state' --- must be done because of constraints elsewhere + +peelFunHead :: CGrammar -> Action +peelFunHead gr state = do + state' <- forgetNode state + reCheckState gr state' --- must be done because of constraints elsewhere + +-- an expensive operation +reCheckState :: CGrammar -> State -> Err State +reCheckState gr st = annotate gr (tree2exp (loc2tree st)) >>= return . tree2loc + +-- extract metasubstitutions from constraints and solve them +solveAll :: CGrammar -> State -> Err State +solveAll gr st0 = do + st <- reCheckState gr st0 + let cs0 = allConstrs st + (cs,ms) = splitConstraints cs0 + metaSubstRefinements gr ms $ mapLoc (performMetaSubstNode ms) st + + +-- active refinements + +refinementsState :: CGrammar -> State -> [(Term,Val)] +refinementsState gr state = + let filt = possibleRefVal gr state in + if actIsMeta state + then refsForType filt gr (allBinds state) (actVal state) + else [] + +wrappingsState :: CGrammar -> State -> [((Fun,Int),Type)] +wrappingsState gr state + | actIsMeta state = [] + | isRootState state = funs + | otherwise = [rule | rule@(_,typ) <- funs, possibleRefVal gr state aval typ] + where + funs = funsOnType (possibleRefVal gr state) gr aval + aval = actVal state + +headChangesState :: CGrammar -> State -> [Fun] +headChangesState gr state = errVal [] $ do + f@(m,c) <- funAtom (actAtom state) + typ0 <- lookupFunType gr m c + return [fun | (fun,typ) <- funRulesOf gr, fun /= f, typ == typ0] + --- alpha-conv ! + +canPeelState :: CGrammar -> State -> Bool +canPeelState gr state = errVal False $ do + f@(m,c) <- funAtom (actAtom state) + typ <- lookupFunType gr m c + return $ isInOneType typ + +possibleRefVal :: CGrammar -> State -> Val -> Type -> Bool +possibleRefVal gr state val typ = errVal True $ do --- was False + vtyp <- valType typ + let gen = actGen state + cs <- return [(val, vClos vtyp)] --- eqVal gen val (vClos vtyp) --- only poss cs + return $ possibleConstraints gr cs --- a simple heuristic + diff --git a/src/GF/UseGrammar/GetTree.hs b/src/GF/UseGrammar/GetTree.hs new file mode 100644 index 000000000..9b545c7dd --- /dev/null +++ b/src/GF/UseGrammar/GetTree.hs @@ -0,0 +1,46 @@ +module GetTree where + +import GFC +import Values +import qualified Grammar as G +import Ident +import MMacros +import Macros +import Rename +import TypeCheck +import PGrammar +import ShellState + +import Operations + +-- how to form linearizable trees from strings and from terms of different levels +-- +-- String --> raw Term --> annot, qualif Term --> Tree + +string2tree :: StateGrammar -> String -> Tree +string2tree gr = errVal uTree . string2treeErr gr + +string2treeErr :: StateGrammar -> String -> Err Tree +string2treeErr gr s = do + t <- pTerm s + let t1 = refreshMetas [] t + let t2 = qualifTerm abstr t1 + annotate grc t2 + where + abstr = absId gr + grc = grammar gr + +string2Cat, string2Fun :: StateGrammar -> String -> (Ident,Ident) +string2Cat gr c = (absId gr,identC c) +string2Fun = string2Cat + +strings2Cat, strings2Fun :: String -> (Ident,Ident) +strings2Cat s = (identC m, identC (drop 1 c)) where (m,c) = span (/= '.') s +strings2Fun = strings2Cat + +string2ref :: StateGrammar -> String -> Err G.Term +string2ref _ ('x':'_':ds) = return $ freshAsTerm ds --- hack for generated vars +string2ref gr s = + if elem '.' s + then return $ uncurry G.Q $ strings2Fun s + else return $ G.Vr $ identC s diff --git a/src/GF/UseGrammar/Information.hs b/src/GF/UseGrammar/Information.hs new file mode 100644 index 000000000..569d8ace6 --- /dev/null +++ b/src/GF/UseGrammar/Information.hs @@ -0,0 +1,130 @@ +module Information where + +import Grammar +import Ident +import Modules +import Option +import CF +import PPrCF +import ShellState +import PrGrammar +import Lookup +import qualified GFC +import qualified AbsGFC + +import Operations +import UseIO + +-- information on module, category, function, operation, parameter,... AR 16/9/2003 +-- uses source grammar + +-- the top level function + +showInformation :: Options -> ShellState -> Ident -> IOE () +showInformation opts st c = do + is <- ioeErr $ getInformation opts st c + mapM_ (putStrLnE . prInformation opts c) is + +-- the data type of different kinds of information + +data Information = + IModAbs SourceAbs + | IModRes SourceRes + | IModCnc SourceCnc + | IModule SourceAbs ---- to be deprecated + | ICatAbs Ident Context [Ident] + | ICatCnc Ident Type [CFRule] Term + | IFunAbs Ident Type (Maybe Term) + | IFunCnc Ident Type [CFRule] Term + | IOper Ident Type Term + | IParam Ident [Param] [Term] + | IValue Ident Type + +type CatId = AbsGFC.CIdent +type FunId = AbsGFC.CIdent + +prInformation :: Options -> Ident -> Information -> String +prInformation opts c i = unlines $ prt c : case i of + IModule m -> [ + "module of type" +++ show (mtype m), + "extends" +++ show (extends m), + "opens" +++ show (opens m), + "defines" +++ unwords (map prt (ownConstants (jments m))) + ] + ICatAbs m co _ -> [ + "category in abstract module" +++ prt m, + "context" +++ prContext co + ] + ICatCnc m ty cfs tr -> [ + "category in concrete module" +++ prt m, + "linearization type" +++ prt ty + ] + IFunAbs m ty _ -> [ + "function in abstract module" +++ prt m, + "type" +++ prt ty + ] + IFunCnc m ty cfs tr -> [ + "function in concrete module" +++ prt m, + "linearization" +++ prt tr + --- "linearization type" +++ prt ty + ] + IOper m ty tr -> [ + "operation in resource module" +++ prt m, + "type" +++ prt ty, + "definition" +++ prt tr + ] + IParam m ty ts -> [ + "parameter type in resource module" +++ prt m, + "constructors" +++ unwords (map prParam ty), + "values" +++ unwords (map prt ts) + ] + IValue m ty -> [ + "parameter constructor in resource module" +++ prt m, + "type" +++ show ty + ] + +-- also finds out if an identifier is defined in many places + +getInformation :: Options -> ShellState -> Ident -> Err [Information] +getInformation opts st c = allChecks $ [ + do + m <- lookupModule src c + case m of + ModMod mo -> return $ IModule mo + _ -> prtBad "not a source module" c + ] ++ map lookInSrc ss ++ map lookInCan cs + where + lookInSrc (i,m) = do + j <- lookupInfo m c + case j of + AbsCat (Yes co) _ -> return $ ICatAbs i co [] --- + AbsFun (Yes ty) _ -> return $ IFunAbs i ty Nothing --- + CncCat (Yes ty) _ _ -> do + ---- let cat = ident2CFCat i c + ---- rs <- concat [rs | (c,rs) <- cf, ] + return $ ICatCnc i ty [] ty --- + CncFun _ (Yes tr) _ -> do + rs <- return [] + return $ IFunCnc i tr rs tr --- + ResOper (Yes ty) (Yes tr) -> return $ IOper i ty tr + ResParam (Yes ps) -> do + ts <- allParamValues src (QC i c) + return $ IParam i ps ts + ResValue (Yes ty) -> return $ IValue i ty --- + + _ -> prtBad "nothing available for" i + lookInCan (i,m) = do + Bad "nothing available yet in canonical" + + src = srcModules st + can = canModules st + ss = [(i,m) | (i,ModMod m) <- modules src] + cs = [(i,m) | (i,ModMod m) <- modules can] + cf = concatMap ruleGroupsOfCF $ map snd $ cfs st + +ownConstants :: BinTree (Ident, Info) -> [Ident] +ownConstants = map fst . filter isOwn . tree2list where + isOwn (c,i) = case i of + AnyInd _ _ -> False + _ -> True + diff --git a/src/GF/UseGrammar/Linear.hs b/src/GF/UseGrammar/Linear.hs new file mode 100644 index 000000000..da1bfce52 --- /dev/null +++ b/src/GF/UseGrammar/Linear.hs @@ -0,0 +1,195 @@ +module Linear where + +import GFC +import AbsGFC +import qualified Abstract as A +import MkGFC (rtQIdent) ---- +import Ident +import PrGrammar +import CMacros +import Look +import Str +import Unlex +----import TypeCheck -- to annotate + +import Operations +import Zipper + +import Monad + +-- Linearization for canonical GF. AR 7/6/2003 + +-- The worker function: linearize a Tree, return +-- a record. Possibly mark subtrees. + +-- NB. Constants in trees are annotated by the name of the abstract module. +-- A concrete module name must be given to find (and choose) linearization rules. + +linearizeToRecord :: CanonGrammar -> Marker -> Ident -> A.Tree -> Err Term +linearizeToRecord gr mk m = lin [] where + + lin ts t = errIn ("lint" +++ prt t) $ ---- + if A.isFocusNode (A.nodeTree t) + then liftM markFocus $ lint ts t + else lint ts t + + lint ts t@(Tr (n,xs)) = do + + let binds = A.bindsNode n + at = A.atomNode n + c <- A.val2cat $ A.valNode n + xs' <- mapM (\ (i,x) -> lin (i:ts) x) $ zip [0..] xs + + r <- case at of + A.AtC f -> look f >>= comp xs' + A.AtL s -> return $ recS $ tK $ prt at + A.AtI i -> return $ recS $ tK $ prt at + A.AtV x -> lookCat c >>= comp [tK (prt at)] + A.AtM m -> lookCat c >>= comp [tK (prt at)] + + return $ mk ts $ mkBinds binds r + + look = lookupLin gr . redirectIdent m . rtQIdent + comp = ccompute gr + mkBinds bs bdy = case bdy of + R fs -> R $ [Ass (LV i) (tK (prt t)) | (i,(t,_)) <- zip [0..] bs] ++ fs + + recS t = R [Ass (L (identC "s")) t] ---- + + lookCat = return . errVal defLindef . look + ---- should always be given in the module + +type Marker = [Int] -> Term -> Term + +-- if no marking is wanted, use the following + +noMark :: [Int] -> Term -> Term +noMark = const id + +-- thus the special case: + +linearizeNoMark :: CanonGrammar -> Ident -> A.Tree -> Err Term +linearizeNoMark gr = linearizeToRecord gr noMark + +-- expand tables in linearized term to full, normal-order tables +-- NB expand from inside-out so that values are not looked up in copies of branches + +expandLinTables :: CanonGrammar -> Term -> Err Term +expandLinTables gr t = case t of + R rs -> liftM (R . map (uncurry Ass)) $ mapPairsM exp [(l,r) | Ass l r <- rs] + T ty rs -> do + rs' <- mapPairsM exp [(l,r) | Cas l r <- rs] -- expand from inside-out + let t' = T ty $ map (uncurry Cas) rs' + vs <- alls ty + ps <- mapM term2patt vs + ts' <- mapM (comp . S t') $ vs + return $ T ty [Cas [p] t | (p,t) <- zip ps ts'] + FV ts -> liftM FV $ mapM exp ts + _ -> return t + where + alls = allParamValues gr + exp = expandLinTables gr + comp = ccompute gr [] + +-- from records, one can get to records of tables of strings + +rec2strTables :: Term -> Err [[(Label,[([Patt],[Str])])]] +rec2strTables r = do + vs <- allLinValues r + mapM (mapPairsM (mapPairsM strsFromTerm)) vs + +-- from these tables, one may want to extract the ones for the "s" label + +strTables2sTables :: [[(Label,[([Patt],[Str])])]] -> [[([Patt],[Str])]] +strTables2sTables ts = [t | r <- ts, (l,t) <- r, l == linLab0] + +linLab0 :: Label +linLab0 = L (identC "s") + +-- to get lists of token lists is easy +sTables2strs :: [[([Patt],[Str])]] -> [[Str]] +sTables2strs = map snd . concat + +-- from this, to get a list of strings --- customize unlexer +strs2strings :: [[Str]] -> [String] +strs2strings = map unlex + +-- finally, a top-level function to get a string from an expression +linTree2string :: CanonGrammar -> Ident -> A.Tree -> String +linTree2string gr m e = err id id $ do + t <- linearizeNoMark gr m e + r <- expandLinTables gr t + ts <- rec2strTables r + let ss = strs2strings $ sTables2strs $ strTables2sTables ts + ifNull (prtBad "empty linearization of" e) (return . head) ss + + +-- argument is a Tree, value is a list of strs; needed in Parsing + +allLinsOfTree :: CanonGrammar -> Ident -> A.Tree -> [Str] +allLinsOfTree gr a e = err (singleton . str) id $ do + e' <- return e ---- annotateExp gr e + r <- linearizeNoMark gr a e' + r' <- expandLinTables gr r + ts <- rec2strTables r' + return $ concat $ sTables2strs $ strTables2sTables ts + +{- +-- the value is a list of strs +allLinStrings :: CanonGrammar -> Tree -> [Str] +allLinStrings gr ft = case allLinsAsStrs gr ft of + Ok ts -> map snd $ concat $ map snd $ concat ts + Bad s -> [str s] + +-- the value is a list of strs, not forgetting their arguments +allLinsAsStrs :: CanonGrammar -> Tree -> Err [[(Label,[([Patt],Str)])]] +allLinsAsStrs gr ft = do + lpts <- allLinearizations gr ft + return $ concat $ mapM (mapPairsM (mapPairsM strsFromTerm)) lpts + +-- the value is a list of terms of type Str, not forgetting their arguments +allLinearizations :: CanonGrammar -> Tree -> Err [[(Label,[([Patt],Term)])]] +allLinearizations gr ft = linearizeTree gr ft >>= allLinValues + +-- to a list of strings +linearizeToStrings :: CanonGrammar -> ([Int] ->Term -> Term) -> Tree -> Err [String] +linearizeToStrings gr mk = liftM (map unlex) . linearizeToStrss gr mk + +-- to a list of token lists +linearizeToStrss :: CanonGrammar -> ([Int] -> Term -> Term) -> Tree -> Err [[Str]] +linearizeToStrss gr mk e = do + R rs <- linearizeToRecord gr mk e ---- + t <- lookupErr linLab0 [(r,s) | Ass r s <- rs] + return $ map strsFromTerm $ allInTable t + + +-- the value is a list of strings, not forgetting their arguments +allLinsOfFun :: CanonGrammar -> CIdent -> Err [[(Label,[([Patt],Term)])]] +allLinsOfFun gr f = do + t <- lookupLin gr f + allLinValues t + + + +-} + + + + +{- ---- +-- returns printname if one exists; otherwise linearizes with metas +printOrLinearize :: CanonGrammar -> Fun -> String +printOrLinearize gr f = +{- ---- + errVal (prtt f) $ case lookupPrintname cnc f of + Ok s -> return s + _ -> -} + + unlines $ take 1 $ err singleton id $ + do + t <- lookupFunType gr f + f' <- ref2exp [] t (AC f) --- [] + lin f' + where + lin = linearizeToStrings gr (const id) ---- +-} diff --git a/src/GF/UseGrammar/MoreCustom.hs b/src/GF/UseGrammar/MoreCustom.hs new file mode 100644 index 000000000..0ebbb25fb --- /dev/null +++ b/src/GF/UseGrammar/MoreCustom.hs @@ -0,0 +1,15 @@ +module MoreCustom where + +-- All these lists are supposed to be empty! +-- Items should be added to ../Custom.hs instead. + +moreCustomGrammarParser = [] +moreCustomGrammarPrinter = [] +moreCustomSyntaxPrinter = [] +moreCustomTermPrinter = [] +moreCustomTermCommand = [] +moreCustomEditCommand = [] +moreCustomStringCommand = [] +moreCustomParser = [] +moreCustomTokenizer = [] +moreCustomUntokenizer = [] diff --git a/src/GF/UseGrammar/Morphology.hs b/src/GF/UseGrammar/Morphology.hs new file mode 100644 index 000000000..102e41340 --- /dev/null +++ b/src/GF/UseGrammar/Morphology.hs @@ -0,0 +1,116 @@ +module Morphology where + +import AbsGFC +import GFC +import PrGrammar + +import Operations + +import Char +import List (sortBy, intersperse) +import Monad (liftM) + +-- construct a morphological analyser from a GF grammar. AR 11/4/2001 + +-- we have found the binary search tree sorted by word forms more efficient +-- than a trie, at least for grammars with 7000 word forms + +type Morpho = BinTree (String,[String]) + +emptyMorpho = NT + +-- with literals +appMorpho :: Morpho -> String -> (String,[String]) +appMorpho m s = (s, ps ++ ms) where + ms = case lookupTree id s m of + Ok vs -> vs + _ -> [] + ps = [] ---- case lookupLiteral s of + ---- Ok (t,_) -> [tagPrt t] + ---- _ -> [] + +-- without literals +appMorphoOnly :: Morpho -> String -> (String,[String]) +appMorphoOnly m s = (s, ms) where + ms = case lookupTree id s m of + Ok vs -> vs + _ -> [] + +-- recognize word, exluding literals +isKnownWord :: Morpho -> String -> Bool +isKnownWord mo = not . null . snd . appMorphoOnly mo + +mkMorpho :: CanonGrammar -> Morpho +mkMorpho gr = emptyMorpho ---- +{- ---- +mkMorpho gr = mkMorphoTree $ concat $ map mkOne $ allItems where + mkOne (Left (fun,c)) = map (prOne fun c) $ allLins fun + mkOne (Right (fun,_)) = map (prSyn fun) $ allSyns fun + + -- gather forms of lexical items + allLins fun = errVal [] $ do + ts <- allLinsOfFun gr fun + ss <- mapM (mapPairsM (mapPairsM (return . wordsInTerm))) ts + return [(p,s) | (p,fs) <- concat $ map snd $ concat ss, s <- fs] + prOne f c (ps,s) = (s, prt f +++ tagPrt c ++ concat (map tagPrt ps)) + + -- gather syncategorematic words + allSyns fun = errVal [] $ do + tss <- allLinsOfFun gr fun + let ss = [s | ts <- tss, (_,fs) <- ts, (_,s) <- fs] + return $ concat $ map wordsInTerm ss + prSyn f s = (s, "+<syncategorematic>" ++ tagPrt f) + + -- all words, Left from lexical rules and Right syncategorematic + allItems = [lexRole t (f,c) | (f,c) <- allFuns, t <- lookType f] where + allFuns = allFunsWithValCat ab + lookType = errVal [] . liftM (:[]) . lookupFunType ab + lexRole t = case typeForm t of + Ok ([],_,_) -> Left + _ -> Right +-} + +-- printing full-form lexicon and results + +prMorpho :: Morpho -> String +prMorpho = unlines . map prMorphoAnalysis . tree2list + +prMorphoAnalysis :: (String,[String]) -> String +prMorphoAnalysis (w,fs) = unlines (w:fs) + +prMorphoAnalysisShort :: (String,[String]) -> String +prMorphoAnalysisShort (w,fs) = prBracket (w' ++ prTList "/" fs) where + w' = if null fs then w +++ "*" else "" + +tagPrt :: Print a => a -> String +tagPrt = ("+" ++) . prt --- could look up print name in grammar + +-- print all words recognized + +allMorphoWords :: Morpho -> [String] +allMorphoWords = map fst . tree2list + +-- analyse running text and show results either in short form or on separate lines +morphoTextShort mo = unwords . map (prMorphoAnalysisShort . appMorpho mo) . words +morphoText mo = unlines . map (('\n':) . prMorphoAnalysis . appMorpho mo) . words + +-- format used in the Italian Verb Engine +prFullForm :: Morpho -> String +prFullForm = unlines . map prOne . tree2list where + prOne (s,ps) = s ++ " : " ++ unwords (intersperse "/" ps) + +-- auxiliaries + +mkMorphoTree :: (Ord a, Eq b) => [(a,b)] -> BinTree (a,[b]) +mkMorphoTree = sorted2tree . sortAssocs + +sortAssocs :: (Ord a, Eq b) => [(a,b)] -> [(a,[b])] +sortAssocs = arrange . sortBy (\ (x,_) (y,_) -> compare x y) where + arrange ((x,v):xvs) = arr x [v] xvs + arrange [] = [] + arr y vs xs = case xs of + (x,v):xvs -> if x==y then arr y vvs xvs else (y,vs) : arr x [v] xvs + where vvs = if elem v vs then vs else (v:vs) + _ -> [(y,vs)] + + diff --git a/src/GF/UseGrammar/Paraphrases.hs b/src/GF/UseGrammar/Paraphrases.hs new file mode 100644 index 000000000..f5dc710f9 --- /dev/null +++ b/src/GF/UseGrammar/Paraphrases.hs @@ -0,0 +1,53 @@ +module Paraphrases (mkParaphrases) where + +import Operations +import AbsGFC +import GFC +import Look +import CMacros ---- (mkApp, eqStrIdent) +import AbsCompute +import List (nub) + +-- paraphrases of GF terms. AR 6/10/1998 -- 24/9/1999 -- 5/7/2000 -- 5/6/2002 +-- Copyright (c) Aarne Ranta 1998--99, under GNU General Public License (see GPL) +-- thus inherited from the old GF. Incomplete and inefficient... + +mkParaphrases :: CanonGrammar -> Exp -> [Exp] +mkParaphrases st t = [t] +---- mkParaphrases st = nub . map (beta []) . paraphrases (allDefs st) + +{- ---- +type Definition = (Fun,Trm) + +paraphrases :: [Definition] -> Trm -> [Trm] +paraphrases th t = + t : + paraImmed th t ++ +--- paraMatch th t ++ + case t of + App c a -> [App d b | d <- paraphrases th c, b <- paraphrases th a] + Abs x b -> [Abs x d | d <- paraphrases th b] + c -> [] + +paraImmed :: [Definition] -> Trm -> [Trm] +paraImmed defs t = + [Cn f | (f, u) <- defs, t == u] ++ --- eqTerm + case t of + Cn c -> [u | (f, u) <- defs, eqStrIdent f c] + _ -> [] +-} +{- --- +paraMatch :: [Definition] -> Trm -> [Trm] +paraMatch th@defs t = + [mkApp (Cn f) xx | (PC f zz, u) <- defs, + let (fs,sn) = fullApp u, fs == h, length sn == length zz] ++ + case findAMatch defs t of + Ok (g,b) -> [substTerm [] g b] + _ -> [] + where + (h,xx) = fullApp t + fullApp c = case c of + App f a -> (f', a' ++ [a]) where (f',a') = fullApp f + c -> (c,[]) + +-} diff --git a/src/GF/UseGrammar/Parsing.hs b/src/GF/UseGrammar/Parsing.hs new file mode 100644 index 000000000..4cd4f4bc8 --- /dev/null +++ b/src/GF/UseGrammar/Parsing.hs @@ -0,0 +1,98 @@ +module Parsing where + +import CheckM +import qualified AbsGFC as C +import GFC +import MkGFC (trExp) ---- +import CMacros +import Linear +import Str +import CF +import CFIdent +import Ident +import TypeCheck +import Values +--import CFMethod +import Tokenize +import Profile +import Option +import Custom +import ShellState + +import Operations + +import List (nub) +import Monad (liftM) + +-- AR 26/1/2000 -- 8/4 -- 28/1/2001 -- 9/12/2002 + +parseString :: Options -> StateGrammar -> CFCat -> String -> Err [Tree] +parseString os sg cat = liftM fst . parseStringMsg os sg cat + +parseStringMsg :: Options -> StateGrammar -> CFCat -> String -> Err ([Tree],String) +parseStringMsg os sg cat s = do + (ts,(_,ss)) <- checkStart $ parseStringC os sg cat s + return (ts,unlines ss) + +parseStringC :: Options -> StateGrammar -> CFCat -> String -> Check [Tree] +parseStringC opts0 sg cat s = do + let opts = unionOptions opts0 $ stateOptions sg + cf = stateCF sg + gr = stateGrammarST sg + cn = cncId sg + tok = customOrDefault opts useTokenizer customTokenizer sg + parser = customOrDefault opts useParser customParser sg cat + tokens2trms opts sg cn parser (tok s) + +tokens2trms :: Options ->StateGrammar ->Ident -> CFParser -> [CFTok] -> Check [Tree] +tokens2trms opts sg cn parser as = do + let res@(trees,info) = parser as + ts0 <- return $ nub (cfParseResults res) + ts <- case () of + _ | null ts0 -> checkWarn "No success in cf parsing" >> return [] + _ | raw -> do + ts1 <- return (map cf2trm0 ts0) ----- should not need annot + mapM (checkErr . (annotate gr) . trExp) ts1 ---- complicated + _ -> do + (ts1,_) <- checkErr $ mapErr postParse ts0 + ts2 <- mapM (checkErr . (annotate gr) . trExp) ts1 ---- + if forgive then return ts2 else do + let tsss = [(t, allLinsOfTree gr cn t) | t <- ts2] + ps = [t | (t,ss) <- tsss, + any (compatToks as) (map str2cftoks ss)] + if null ps + then raise $ "Failure in morphology." ++ + if verb + then "\nPossible corrections: " +++++ + unlines (nub (map sstr (concatMap snd tsss))) + else "" + else return ps + + if verb + then checkWarn $ " the token list" +++ show as ++++ unknown as +++++ info + else return () + + return $ optIntOrAll opts flagNumber $ nub ts + where + gr = stateGrammarST sg + + raw = oElem rawParse opts + verb = oElem beVerbose opts + forgive = oElem forgiveParse opts + + unknown ts = case filter noMatch ts of + [] -> "where all words are known" + us -> "with the unknown tokens" +++ show us --- needs to be fixed for literals + terminals = map TS $ cfTokens $ stateCF sg + noMatch t = all (not . compatTok t) terminals + + +--- too much type checking in building term info? return FullTerm to save work? + +-- raw parsing: so simple it is for a context-free CF grammar +cf2trm0 :: CFTree -> C.Exp +cf2trm0 (CFTree (fun, (_, trees))) = mkAppAtom (cffun2trm fun) (map cf2trm0 trees) + where + cffun2trm (CFFun (fun,_)) = fun + mkApp = foldl C.EApp + mkAppAtom a = mkApp (C.EAtom a) diff --git a/src/GF/UseGrammar/Randomized.hs b/src/GF/UseGrammar/Randomized.hs new file mode 100644 index 000000000..dceb6acc6 --- /dev/null +++ b/src/GF/UseGrammar/Randomized.hs @@ -0,0 +1,47 @@ +module Randomized where + +import Abstract +import Editing + +import Operations +import Zipper + +--- import Arch (myStdGen) --- circular for hbc +import Random --- (mkStdGen, StdGen, randoms) --- bad import for hbc + +-- random generation and refinement. AR 22/8/2001 +-- implemented as sequence of refinement menu selecsions, encoded as integers + +myStdGen = mkStdGen --- + +-- build one random tree; use mx to prevent infinite search +mkRandomTree :: StdGen -> Int -> CGrammar -> QIdent -> Err Tree +mkRandomTree gen mx gr cat = mkTreeFromInts (take mx (randoms gen)) gr cat + +refineRandom :: StdGen -> Int -> CGrammar -> Action +refineRandom gen mx = mkStateFromInts $ take mx $ map abs (randoms gen) + +-- build a tree from a list of integers +mkTreeFromInts :: [Int] -> CGrammar -> QIdent -> Err Tree +mkTreeFromInts ints gr cat = do + st0 <- newCat gr cat initState + state <- mkStateFromInts ints gr st0 + return $ loc2tree state + +mkStateFromInts :: [Int] -> CGrammar -> Action +mkStateFromInts ints gr = mkRandomState ints where + mkRandomState [] state = do + testErr (isCompleteState state) "not completed" + return state + mkRandomState (n:ns) state = do + let refs = refinementsState gr state + testErr (not (null refs)) $ "no refinements available for" +++ + prt (actVal state) + (ref,_) <- (refs !? (n `mod` (length refs))) + state1 <- refineWithAtom False gr ref state + if isCompleteState state1 + then return state1 + else do + state2 <- goNextMeta state1 + mkRandomState ns state2 + diff --git a/src/GF/UseGrammar/RealMoreCustom.hs b/src/GF/UseGrammar/RealMoreCustom.hs new file mode 100644 index 000000000..b9f461a1f --- /dev/null +++ b/src/GF/UseGrammar/RealMoreCustom.hs @@ -0,0 +1,122 @@ +module MoreCustom where + +import Operations +import Text +import Tokenize +import UseGrammar +import qualified UseSyntax as S +import ShellState +import Editing +import Paraphrases +import Option +import CF +import CFIdent --- (CFTok, tS) + +import EBNF +import CFtoGrammar +import PPrCF + +import CFtoHappy +import Morphology +import GrammarToHaskell +import GrammarToCanon (showCanon) +import GrammarToXML +import qualified SyntaxToLatex as L +import GFTex +import MkResource +import SeparateOper + +-- the cf parsing algorithms +import ChartParser -- or some other CF Parser +import Earley -- such as this one +---- import HappyParser -- or this... + +import qualified PPrSRG as SRG +import PPrGSL + +import qualified TransPredCalc as PC + +-- databases for customizable commands. AR 21/11/2001 +-- Extends ../Custom. + +moreCustomGrammarParser = + [ + (strCIm "gfl", S.parseGrammar . extractGFLatex) + ,(strCIm "tex", S.parseGrammar . extractGFLatex) + ,(strCIm "ebnf", pAsGrammar pEBNFasGrammar) + ,(strCIm "cf", pAsGrammar pCFAsGrammar) +-- add your own grammar parsers here + ] + where + -- use a parser with no imports or flags + pAsGrammar p = err Bad (\g -> return (([],noOptions),g)) . p + + +moreCustomGrammarPrinter = + [ + (strCIm "happy", cf2HappyS . stateCF) + ,(strCIm "srg", SRG.prSRG . stateCF) + ,(strCIm "gsl", prGSL . stateCF) + ,(strCIm "gfhs", show . stateGrammarST) + ,(strCIm "haskell", grammar2haskell . st2grammar . stateGrammarST) + ,(strCIm "xml", unlines . prDTD . grammar2dtd . stateAbstract) + ,(strCIm "fullform",prFullForm . stateMorpho) + ,(strCIm "resource",prt . st2grammar . mkResourceGrammar . stateGrammarST) + ,(strCIm "resourcetypes", + prt . operTypeGrammar . st2grammar . mkResourceGrammar . stateGrammarST) + ,(strCIm "resourcedefs", + prt . operDefGrammar . st2grammar . mkResourceGrammar . stateGrammarST) +-- add your own grammar printers here +--- also include printing via grammar2syntax! + ] + +moreCustomSyntaxPrinter = + [ + (strCIm "gf", S.prSyntax) -- DEFAULT + ,(strCIm "latex", L.syntax2latexfile) +-- add your own grammar printers here + ] + +moreCustomTermPrinter = + [ + (strCIm "xml", \g t -> unlines $ prElementX $ term2elemx (stateAbstract g) t) +-- add your own term printers here + ] + +moreCustomTermCommand = + [ + (strCIm "predcalc", \_ t -> PC.transfer t) +-- add your own term commands here + ] + +moreCustomEditCommand = + [ +-- add your own edit commands here + ] + +moreCustomStringCommand = + [ +-- add your own string commands here + ] + +moreCustomParser = + [ + (strCIm "chart", chartParser . stateCF) + ,(strCIm "earley", earleyParser . stateCF) +-- ,(strCIm "happy", const $ lexHaskell) +-- ,(strCIm "td", const $ lexText) +-- add your own parsers here + ] + +moreCustomTokenizer = + [ +-- add your own tokenizers here + ] + +moreCustomUntokenizer = + [ +-- add your own untokenizers here + ] + + +strCIm = id diff --git a/src/GF/UseGrammar/Session.hs b/src/GF/UseGrammar/Session.hs new file mode 100644 index 000000000..bf2dd30ab --- /dev/null +++ b/src/GF/UseGrammar/Session.hs @@ -0,0 +1,110 @@ +module Session where + +import Abstract +import Option +---- import Custom +import Editing + +import Operations + +-- First version 8/2001. Adapted to GFC with modules 19/6/2003. +-- Nothing had to be changed, which is a sign of good modularity. + +-- keep these abstract + +type SState = [(State,[Exp],SInfo)] -- exps are candidate refinements +type SInfo = ([String],(Int,Options)) -- string is message, int is the view + +initSState :: SState +initSState = [(initState, [], (["Select category to start"],(0,noOptions)))] + -- instead of empty + +okInfo n = ([],(n,True)) + +stateSState ((s,_,_):_) = s +candsSState ((_,ts,_):_) = ts +infoSState ((_,_,i):_) = i +msgSState ((_,_,(m,_)):_) = m +viewSState ((_,_,(_,(v,_))):_) = v +optsSState ((_,_,(_,(_,o))):_) = o + +treeSState = actTree . stateSState + + +-- from state to state + +type ECommand = SState -> SState + +-- elementary commands + +-- change state, drop cands, drop message, preserve options +changeState :: State -> ECommand +changeState s ss = changeMsg [] $ (s,[],infoSState ss) : ss + +changeCands :: [Exp] -> ECommand +changeCands ts ss@((s,_,(_,b)):_) = (s,ts,(candInfo ts,b)) : ss -- add new state + +changeMsg :: [String] -> ECommand +changeMsg m ((s,ts,(_,b)):ss) = (s,ts,(m,b)) : ss -- just change message + +changeView :: ECommand +changeView ((s,ts,(m,(v,b))):ss) = (s,ts,(m,(v+1,b))) : ss -- toggle view + +changeStOptions :: (Options -> Options) -> ECommand +changeStOptions f ((s,ts,(m,(v,o))):ss) = (s,ts,(m,(v, f o))) : ss + +noNeedForMsg = changeMsg [] -- everything's all right: no message + +candInfo ts = case length ts of + 0 -> ["no acceptable alternative"] + 1 -> ["just one acceptable alternative"] + n -> [show n +++ "alternatives to select"] + +-- keep SState abstract from this on + +-- editing commands + +action2command :: Action -> ECommand +action2command act state = case act (stateSState state) of + Ok s -> changeState s state + Bad m -> changeMsg [m] state + +action2commandNext :: Action -> ECommand -- move to next meta after execution +action2commandNext act = action2command (\s -> act s >>= goNextMetaIfCan) + +undoCommand :: ECommand +undoCommand ss@[_] = changeMsg ["cannot go back"] ss +undoCommand (_:ss) = changeMsg ["successful undo"] ss + +selectCand :: CGrammar -> Int -> ECommand +selectCand gr i state = err (\m -> changeMsg [m] state) id $ do + exp <- candsSState state !? i + let s = stateSState state + tree <- annotateInState gr exp s + return $ case replaceSubTree tree s of + Ok st' -> changeState st' state + Bad s -> changeMsg [s] state + +refineByExps :: Bool -> CGrammar -> [Exp] -> ECommand +refineByExps der gr trees = case trees of + [t] -> action2commandNext (refineWithExpTC der gr t) + _ -> changeCands trees + +replaceByTrees :: CGrammar -> [Exp] -> ECommand +replaceByTrees gr trees = case trees of + [t] -> action2commandNext (\s -> + annotateExpInState gr t s >>= flip replaceSubTree s) + _ -> changeCands trees + +{- ---- +replaceByEditCommand :: CGrammar -> String -> ECommand +replaceByEditCommand gr co = + action2command $ + maybe return ($ gr) $ + lookupCustom customEditCommand (strCI co) + +replaceByTermCommand :: CGrammar -> String -> Exp -> ECommand +replaceByTermCommand gr co exp = + replaceByTrees gr $ maybe [exp] (\f -> f (abstractOf gr) exp) $ + lookupCustom customTermCommand (strCI co) +-} diff --git a/src/GF/UseGrammar/TeachYourself.hs b/src/GF/UseGrammar/TeachYourself.hs new file mode 100644 index 000000000..9037b9198 --- /dev/null +++ b/src/GF/UseGrammar/TeachYourself.hs @@ -0,0 +1,69 @@ +module TeachYourself where + +import Operations +import UseIO + +import UseGrammar +import Linear (allLinsIfContinuous) +import ShellState +import API +import Option + +import Random --- (randoms) --- bad import for hbc +import Arch (myStdGen) +import System + +-- translation and morphology quiz. AR 10/5/2000 -- 12/4/2002 + +teachTranslation :: Options -> GFGrammar -> GFGrammar -> IO () +teachTranslation opts ig og = do + tts <- transTrainList opts ig og infinity + let qas = [ (q, mkAnswer as) | (q,as) <- tts] + teachDialogue qas "Welcome to GF Translation Quiz." + +transTrainList :: + Options -> GFGrammar -> GFGrammar -> Integer -> IO [(String,[String])] +transTrainList opts ig og number = do + ts <- randomTermsIO opts ig (fromInteger number) + return $ map mkOne $ ts + where + cat = firstCatOpts opts ig + mkOne t = (norml (linearize ig t),map (norml . linearize og) (homonyms ig cat t)) + +teachMorpho :: Options -> GFGrammar -> IO () +teachMorpho opts ig = useIOE () $ do + tts <- morphoTrainList opts ig infinity + let qas = [ (q, mkAnswer as) | (q,as) <- tts] + ioeIO $ teachDialogue qas "Welcome to GF Morphology Quiz." + +morphoTrainList :: Options -> GFGrammar -> Integer -> IOE [(String,[String])] +morphoTrainList opts ig number = do + ts <- ioeIO $ randomTreesIO opts ig (fromInteger number) + gen <- ioeIO $ myStdGen (fromInteger number) + mkOnes gen ts + where + mkOnes gen (t:ts) = do + psss <- ioeErr $ allLinsIfContinuous gr t + let pss = concat psss + let (i,gen') = randomR (0, length pss - 1) gen + (ps,ss) <- ioeErr $ pss !? i + (_,ss0) <- ioeErr $ pss !? 0 + let bas = sstrV $ take 1 ss0 + more <- mkOnes gen' ts + return $ (bas +++ ":" +++ unwords (map prt ps), return (sstrV ss)) : more + mkOnes gen [] = return [] + + gr = stateConcrete ig + +-- compare answer to the list of possible answers, increase score and give feedback +mkAnswer :: [String] -> String -> (Integer, String) +mkAnswer as s = if (elem (norml s) as) + then (1,"Yes.") + else (0,"No, not" +++ s ++ ", but" ++++ unlines as) + +norml = unwords . words + +--- the maximal number of precompiled quiz problems +infinity :: Integer +infinity = 123 + diff --git a/src/GF/UseGrammar/Tokenize.hs b/src/GF/UseGrammar/Tokenize.hs new file mode 100644 index 000000000..dd0879931 --- /dev/null +++ b/src/GF/UseGrammar/Tokenize.hs @@ -0,0 +1,130 @@ +module Tokenize where + +import Operations +---- import UseGrammar (isLiteral,identC) +import CFIdent + +import Char + +-- lexers = tokenizers, to prepare input for GF grammars. AR 4/1/2002 +-- an entry for each is included in Custom.customTokenizer + +-- just words + +tokWords :: String -> [CFTok] +tokWords = map tS . words + +tokLits :: String -> [CFTok] +tokLits = map mkCFTok . words + +tokVars :: String -> [CFTok] +tokVars = map mkCFTokVar . words + +mkCFTok :: String -> CFTok +mkCFTok s = tS s ---- if (isLiteral s) then (mkLit s) else (tS s) + +mkCFTokVar :: String -> CFTok +mkCFTokVar s = case s of + '?':_:_ -> tM s + 'x':'_':_ -> tV s + 'x':[] -> tV s + '$':xs@(_:_) -> if last s == '$' then tV (init xs) else tS s + _ -> tS s + +mkLit :: String -> CFTok +mkLit s = if (all isDigit s) then (tI s) else (tL s) + +mkTL :: String -> CFTok +mkTL s = if (all isDigit s) then (tI s) else (tL ("'" ++ s ++ "'")) + + +-- Haskell lexer, usable for much code + +lexHaskell :: String -> [CFTok] +lexHaskell ss = case lex ss of + [(w@(_:_),ws)] -> tS w : lexHaskell ws + _ -> [] + +-- somewhat shaky text lexer + +lexText :: String -> [CFTok] +lexText = uncap . lx where + + lx s = case s of + p : cs | isMPunct p -> tS [p] : uncap (lx cs) + p : cs | isPunct p -> tS [p] : lx cs + s : cs | isSpace s -> lx cs + _ : _ -> getWord s + _ -> [] + + getWord s = tS w : lx ws where (w,ws) = span isNotSpec s + isMPunct c = elem c ".!?" + isPunct c = elem c ",:;()\"" + isNotSpec c = not (isMPunct c || isPunct c || isSpace c) + uncap (TS (c:cs) : ws) = tC (c:cs) : ws + uncap s = s + +-- lexer for C--, a mini variant of C + +lexC2M :: String -> [CFTok] +lexC2M = lexC2M' False + +lexC2M' :: Bool -> String -> [CFTok] +lexC2M' isHigherOrder s = case s of + '#':cs -> lexC $ dropWhile (/='\n') cs + '/':'*':cs -> lexC $ dropComment cs + c:cs | isSpace c -> lexC cs + c:cs | isAlpha c -> getId s + c:cs | isDigit c -> getLit s + c:d:cs | isSymb [c,d] -> tS [c,d] : lexC cs + c:cs | isSymb [c] -> tS [c] : lexC cs + _ -> [] --- covers end of file and unknown characters + where + lexC = lexC2M' isHigherOrder + getId s = mkT i : lexC cs where (i,cs) = span isIdChar s + getLit s = tI i : lexC cs where (i,cs) = span isDigit s + isIdChar c = isAlpha c || isDigit c || elem c "'_" + isSymb = reservedAnsiCSymbol + dropComment s = case s of + '*':'/':cs -> cs + _:cs -> dropComment cs + _ -> [] + mkT i = if (isRes i) then (tS i) else + if isHigherOrder then (tV i) else (tL ("'" ++ i ++ "'")) + isRes = reservedAnsiC + + +reservedAnsiCSymbol s = case lookupTree show s ansiCtree of + Ok True -> True + _ -> False + +reservedAnsiC s = case lookupTree show s ansiCtree of + Ok False -> True + _ -> False + +-- for an efficient lexer: precompile this! +ansiCtree = buildTree $ [(s,True) | s <- reservedAnsiCSymbols] ++ + [(s,False) | s <- reservedAnsiCWords] + +reservedAnsiCSymbols = words $ + "<<= >>= << >> ++ -- == <= >= *= += -= %= /= &= ^= |= " ++ + "^ { } = , ; + * - ( ) < > & % ! ~" + +reservedAnsiCWords = words $ + "auto break case char const continue default " ++ + "do double else enum extern float for goto if int " ++ + "long register return short signed sizeof static struct switch typedef " ++ + "union unsigned void volatile while " ++ + "main printin putchar" --- these are not ansi-C + +-- turn unknown tokens into string literals; not recursively for literals 123, 'foo' + +unknown2string :: (String -> Bool) -> [CFTok] -> [CFTok] +unknown2string isKnown = map mkOne where + mkOne t@(TS s) = if isKnown s then t else mkTL s + mkOne t@(TC s) = if isKnown s then t else mkTL s + mkOne t = t + +lexTextLiteral isKnown = unknown2string isKnown . lexText +lexHaskellLiteral isKnown = unknown2string isKnown . lexHaskell + diff --git a/src/HelpFile.hs b/src/HelpFile.hs new file mode 100644 index 000000000..224535134 --- /dev/null +++ b/src/HelpFile.hs @@ -0,0 +1,376 @@ +module HelpFile where + +txtHelpFile = + "\n-- commands that change the state" ++ + "\n" ++ + "\ni, import: i File" ++ + "\n Reads a grammar from File and compiles it into a GF runtime grammar." ++ + "\n Files \"include\"d in File are read recursively, nubbing repetitions." ++ + "\n If a grammar with the same language name is already in the state," ++ + "\n it is overwritten - but only if compilation succeeds. " ++ + "\n The grammar parser depends on the file name suffix:" ++ + "\n .gf normal GF source " ++ + "\n .gfl LaTeX file with grammar in \\begGF..\\end{verbatim} environments" ++ + "\n .tex LaTeX file with grammar in \\begGF..\\end{verbatim} environments" ++ + "\n .gfc already optimized - skip compilation and type checking" ++ + "\n .gfhc already compiled (a Haskell data object)" ++ + "\n .ebnf EBNF format" ++ + "\n .cf Context-free format" ++ + "\n options:" ++ + "\n -v verbose: give lots of messages " ++ + "\n -s silent: don't give error messages" ++ + "\n -opt perform branch-sharing optimization" ++ + "\n -retain retain oper and lintype definitions" ++ + "\n -nocf don't build context-free grammar (thus no parser)" ++ + "\n -nocheckcirc don't eliminate circular rules from CF " ++ + "\n -nocirc do eliminate circ rules (default; currently just explicit ones)" ++ + "\n flags:" ++ + "\n -lang set the name used for the grammar in the session" ++ + "\n" ++ + "\nrl, remove language: rl Language" ++ + "\n Takes away the language from the state." ++ + "\n" ++ + "\ne, empty state: e" ++ + "\n Takes away all languages and resets all global flags." ++ + "\n" ++ + "\nsf, set flags: sf Language? Flag*" ++ + "\n The values of the Flags are set for Language. If no language" ++ + "\n is specified, the flags are set globally." ++ + "\n" ++ + "\n-- commands that give information about the state" ++ + "\n" ++ + "\npg, print grammar: pg" ++ + "\n Prints the actual grammar (overridden by the -lang=X flag)." ++ + "\n The -printer=X flag sets the format in which the grammar is" ++ + "\n written." ++ + "\n N.B. since grammars are compiled when imported, this command" ++ + "\n generally does not show the grammar in the same format as the" ++ + "\n source. In particular, the -printer=latex is not supported. " ++ + "\n Use the command tg -printer=latex File to print the source " ++ + "\n grammar in LaTeX." ++ + "\n options:" ++ + "\n -utf8 apply UTF8-encoding to the grammar" ++ + "\n" ++ + "\n flags: " ++ + "\n -printer" ++ + "\n -lang" ++ + "\n " ++ + "\n" ++ + "\npm, print multigrammar: pm" ++ + "\n Prints the current multilingual grammar into a Haskell file" ++ + "\n in a canonical format (usable by the canonical GF editor)." ++ + "\n options" ++ + "\n -opt perform branch-sharing optimization (should not have been done at import)" ++ + "\n" ++ + "\npo, print options: po" ++ + "\n Prints those flag values in the current state that differ from defaults." ++ + "\n" ++ + "\npl, print languages: pl" ++ + "\n Prints the names of currently available languages." ++ + "\n" ++ + "\n" ++ + "\n-- commands that execute and show the session history" ++ + "\n" ++ + "\neh, execute history: eh File" ++ + "\n Executes commands in the file." ++ + "\n" ++ + "\nph, print history; ph" ++ + "\n Prints the commands issued during the GF session." ++ + "\n The result is readable by the eh command." ++ + "\n HINT: write \"ph | wf foo.hist\" to save the history." ++ + "\n" ++ + "\n" ++ + "\n-- linearization, parsing, translation, and computation" ++ + "\n" ++ + "\nl, linearize: l PattList? Tree" ++ + "\n Shows all linearization forms of Tree by the actual grammar" ++ + "\n (which is overridden by the -lang flag). " ++ + "\n The pattern list has the form [P, ... ,Q] where P,...,Q follow GF " ++ + "\n syntax for patterns. All those forms are generated that match with the" ++ + "\n pattern list. Too short lists are filled with variables in the end." ++ + "\n Only the -table flag is available if a pattern list is specified." ++ + "\n HINT: see GF language specification for the syntax of Pattern and Term." ++ + "\n You can also copy and past parsing results." ++ + "\n options: " ++ + "\n -table show parameters" ++ + "\n -struct bracketed form" ++ + "\n -record record, i.e. explicit GF concrete syntax term" ++ + "\n flags:" ++ + "\n -lang linearize in this grammar" ++ + "\n -number give this number of forms at most" ++ + "\n -unlexer filter output through unlexer" ++ + "\n" ++ + "\np, parse: p String" ++ + "\n Shows all Trees returned for String by the actual" ++ + "\n grammar (overridden by the -lang flag), in the category S (overridden" ++ + "\n by the -cat flag)." ++ + "\n options:" ++ + "\n -n non-strict: tolerates morphological errors" ++ + "\n -ign ignore unknown words when parsing" ++ + "\n -raw return context-free terms in raw form" ++ + "\n -v verbose: give more information if parsing fails" ++ + "\n flags:" ++ + "\n -cat parse in this category" ++ + "\n -lang parse in this grammar" ++ + "\n -lexer filter input through this lexer" ++ + "\n -parser use this context-free parsing method" ++ + "\n -number return this many results at most" ++ + "\n" ++ + "\ntt, test tokenizer: tt String" ++ + "\n Show the token list sent to the parser when String is parsed." ++ + "\n HINT: can be useful when debugging the parser." ++ + "\n flags: " ++ + "\n -lexer use this lexer" ++ + "\n" ++ + "\ncc, compute concrete: cc Term" ++ + "\n Compute a term by concrete syntax definitions. " ++ + "\n N.B. You need the flag -retain when importing the grammar, if you want " ++ + "\n the oper definitions to be retained after compilation; otherwise this" ++ + "\n command does not expand oper constants." ++ + "\n N.B.' The resulting Term is not a term in the sense of abstract syntax," ++ + "\n and hence not a valid input to a Tree-demanding command." ++ + "\n flags:" ++ + "\n -lang" ++ + "\n" ++ + "\nt, translate: t Lang Lang String" ++ + "\n Parses String in Lang1 and linearizes the resulting Trees in Lang2." ++ + "\n flags:" ++ + "\n -cat" ++ + "\n -lexer" ++ + "\n -parser" ++ + "\n" ++ + "\ngr, generate random: gr" ++ + "\n Generates a random Tree." ++ + "\n flags:" ++ + "\n -cat generate in this category" ++ + "\n -lang use the abstract syntax of this grammar" ++ + "\n -number generate this number of trees" ++ + "\n -depth use this number of search steps at most" ++ + "\n" ++ + "\nma, morphologically analyse: ma String" ++ + "\n Runs morphological analysis on each word in String and displays" ++ + "\n the results line by line." ++ + "\n options:" ++ + "\n -short show analyses in bracketed words, instead of separate lines" ++ + "\n flags:" ++ + "\n -lang" ++ + "\n" ++ + "\n" ++ + "\n-- elementary generation of Strings and Trees" ++ + "\n" ++ + "\nps, put string: ps String" ++ + "\n Returns its argument String, like Unix echo." ++ + "\n HINT. The strength of ps comes from the possibility to receive the argument" ++ + "\n from a pipeline, and altering it by the -filter flag." ++ + "\n flags:" ++ + "\n -filter filter the result through this string processor " ++ + "\n -length cut the string after this number of characters" ++ + "\n" ++ + "\npt, put tree: pt Tree" ++ + "\n Returns its argument Tree, like a specialized Unix echo." ++ + "\n HINT. The strength of pt comes from the possibility to receive the argument" ++ + "\n from a pipeline, and altering it by the -transform flag." ++ + "\n flags:" ++ + "\n -transform transform the result by this term processor" ++ + "\n -number generate this number of terms at most" ++ + "\n" ++ + "\nst, show tree: st Tree" ++ + "\n Prints the tree as a string. Unlike pt, this command cannot be" ++ + "\n used in a pipe to produce a tree, since its output is a string." ++ + "\n flags:" ++ + "\n -printer show the tree in a special format (-printer=xml supported)" ++ + "\n" ++ + "\nwt, wrap tree: wt Fun Tree" ++ + "\n Returns its argument Tree wrapped in the function Fun." ++ + "\n flags:" ++ + "\n -c compute the resulting tree" ++ + "\n" ++ + "\n" ++ + "\n-- subshells" ++ + "\n" ++ + "\nes, editing session: es" ++ + "\n Opens an interactive editing session." ++ + "\n N.B. Exit from a Fudget session is to the Unix shell, not to GF. " ++ + "\n options:" ++ + "\n -f Fudget GUI (necessary for Unicode; only available in X Window System)" ++ + "\n" ++ + "\nts, translation session: ts" ++ + "\n Translates input lines from any of the actual languages to any other one." ++ + "\n To exit, type a full stop (.) alone on a line." ++ + "\n N.B. Exit from a Fudget session is to the Unix shell, not to GF. " ++ + "\n HINT: Set -parser and -lexer locally in each grammar." ++ + "\n options:" ++ + "\n -f Fudget GUI (necessary for Unicode; only available in X Window System)" ++ + "\n flags:" ++ + "\n -cat" ++ + "\n" ++ + "\ntq, translation quiz: tq Lang Lang" ++ + "\n Random-generates translation exercises from Lang1 to Lang2," ++ + "\n keeping score of success." ++ + "\n To interrupt, type a full stop (.) alone on a line." ++ + "\n HINT: Set -parser and -lexer locally in each grammar." ++ + "\n flags:" ++ + "\n -cat" ++ + "\n" ++ + "\ntl, translation list: tl Lang Lang Int" ++ + "\n Random-generates a list of Int translation exercises from Lang1 to Lang2." ++ + "\n HINT: use wf to save the exercises in a file." ++ + "\n flags:" ++ + "\n -cat" ++ + "\n" ++ + "\nmq, morphology quiz: mq" ++ + "\n Random-generates morphological exercises," ++ + "\n keeping score of success." ++ + "\n To interrupt, type a full stop (.) alone on a line." ++ + "\n HINT: use printname judgements in your grammar to" ++ + "\n produce nice expressions for desired forms." ++ + "\n flags:" ++ + "\n -cat" ++ + "\n -lang" ++ + "\n" ++ + "\nml, morphology list: tl Int" ++ + "\n Random-generates a list of Int morphological exercises," ++ + "\n keeping score of success." ++ + "\n HINT: use wf to save the exercises in a file." ++ + "\n flags:" ++ + "\n -cat" ++ + "\n -lang" ++ + "\n" ++ + "\n" ++ + "\n-- IO related commands" ++ + "\n" ++ + "\nrf, read file: rf File" ++ + "\n Returns the contents of File as a String; error is File does not exist." ++ + "\n" ++ + "\nwf, write file: wf File String" ++ + "\n Writes String into File; File is created if it does not exist." ++ + "\n N.B. the command overwrites File without a warning." ++ + "\n" ++ + "\naf, append file: af File" ++ + "\n Writes String into the end of File; File is created if it does not exist." ++ + "\n" ++ + "\ntg, transform grammar: tg File" ++ + "\n Reads File, parses as a grammar, but instead of compiling further, prints it. " ++ + "\n The environment is not changed. When parsing the grammar, the same file" ++ + "\n name suffixes are supported as in the i command." ++ + "\n HINT: use this command to print the grammar in another format (the -printer" ++ + "\n flag); pipe it to wf to save this format." ++ + "\n flags:" ++ + "\n -printer (only -printer=latex supported currently)" ++ + "\n" ++ + "\ncl, convert latex: cl File" ++ + "\n Reads File, which is expected to be in LaTeX form." ++ + "\n Two environments are treated in special ways:" ++ + "\n \\begGF - \\end{verbatim}, which contains GF judgements," ++ + "\n \\begTGF - \\end{verbatim}, which contains a GF expression (displayed), and" ++ + "\n \\begInTGF - \\end{verbatim}, which contains a GF expressions (inlined)." ++ + "\n Moreover, certain macros should be included in the file; you can" ++ + "\n get those macros by applying 'tg -printer=latex foo.gf' to any grammar" ++ + "\n foo.gf. Notice that the same File can be imported as a GF grammar," ++ + "\n consisting of all the judgements in \\begGF environments." ++ + "\n HINT: pipe with 'wf Foo.tex' to generate a new Latex file." ++ + "\n" ++ + "\nsa, speak aloud: sa String" ++ + "\n Uses the Festival speech generator to produce speech for String." ++ + "\n The command cupports Festival's language flag, which is sent verbatim" ++ + "\n to Festival, e.g. -language=spanish. Omitting this flag gives the " ++ + "\n system-dependent default voice (often British English)." ++ + "\n flags:" ++ + "\n -language" ++ + "\n" ++ + "\nh, help: h" ++ + "\n Displays this help message." ++ + "\n" ++ + "\nq, quit: q" ++ + "\n Exits GF." ++ + "\n HINT: you can use 'ph | wf history' to save your session." ++ + "\n" ++ + "\n!, system command: ! String" ++ + "\n Issues a system command. No value is returned to GF." ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n-- Flags. The availability of flags is defined separately for each command." ++ + "\n" ++ + "\n-cat: category in which parsing is performed." ++ + "\n The default is S." ++ + "\n" ++ + "\n-depth: the search depth in e.g. random generation." ++ + "\n The default depends on application." ++ + "\n" ++ + "\n-filter: operation performed on a string. The default is identity." ++ + "\n -filter=identity no change" ++ + "\n -filter=erase erase the text" ++ + "\n -filter=take100 show the first 100 characters" ++ + "\n -filter=length show the length of the string" ++ + "\n -filter=text format as text (punctuation, capitalization)" ++ + "\n -filter=code format as code (spacing, indentation)" ++ + "\n -filter=latexfile embed in a LaTeX file " ++ + "\n" ++ + "\n-lang: grammar used when executing a grammar-dependent command." ++ + "\n The default is the last-imported grammar." ++ + "\n" ++ + "\n-language: voice used by Festival as its --language flag in the sa command. " ++ + "\n The default is system-dependent. " ++ + "\n" ++ + "\n-length: the maximum number of characters shown of a string. " ++ + "\n The default is unlimited." ++ + "\n" ++ + "\n-lexer: tokenization transforming a string into lexical units for a parser." ++ + "\n The default is words." ++ + "\n -lexer=words tokens are separated by spaces or newlines" ++ + "\n -lexer=literals like words, but GF integer and string literals recognized" ++ + "\n -lexer=vars like words, but \"x\",\"x_...\",\"$...$\" as vars, \"?...\" as meta" ++ + "\n -lexer=chars each character is a token" ++ + "\n -lexer=code use Haskell's lex" ++ + "\n -lexer=text with conventions on punctuation and capital letters" ++ + "\n -lexer=codelit like code, but treat unknown words as string literals" ++ + "\n -lexer=textlit like text, but treat unknown words as string literals" ++ + "\n -lexer=codeC use a C-like lexer" ++ + "\n" ++ + "\n-number: the maximum number of generated items in a list. " ++ + "\n The default is unlimited." ++ + "\n" ++ + "\n-parser: Context-free parsing algorithm. The default is chart." ++ + "\n -parser=earley Earley algorithm" ++ + "\n -parser=chart bottom-up chart parser" ++ + "\n" ++ + "\n-printer: format in which the grammar is printed. The default is gf." ++ + "\n -printer=gf GF grammar" ++ + "\n -printer=cf context-free grammar" ++ + "\n -printer=resource resource grammar (cat+lincat, fun+lin --> oper)" ++ + "\n -printer=resourcetypes resource grammar type signatures" ++ + "\n -printer=resourcedefs resource grammar operation definitions" ++ + "\n -printer=happy source file for Happy parser generator" ++ + "\n -printer=srg speech recognition grammar" ++ + "\n -printer=canon grammar compiled into a canonical form, Haskell module" ++ + "\n -printer=canonOpt canonical form, with branch-sharing optimization" ++ + "\n -printer=gfhs compiled grammar as Haskell data object" ++ + "\n -printer=haskell abstract syntax in Haskell, with translations to/from GF" ++ + "\n -printer=morpho full-form lexicon, long format" ++ + "\n -printer=latex LaTeX file (for the tg command)" ++ + "\n -printer=fullform full-form lexicon, short format" ++ + "\n -printer=xml XML: DTD for the pg command, object for st" ++ + "\n" ++ + "\n-startcat: like -cat, but used in grammars (to avoid clash with the keyword cat)" ++ + "\n" ++ + "\n-transform: transformation performed on a syntax tree. The default is identity." ++ + "\n -transform=identity no change" ++ + "\n -transform=compute compute by using definitions in the grammar" ++ + "\n -transform=typecheck return the term only if it is type-correct" ++ + "\n -transform=solve solve metavariables as derived refinements" ++ + "\n -transform=context solve metavariables by unique refinements as variables" ++ + "\n -transform=delete replace the term by metavariable" ++ + "\n -transform=predcalc generating sentences from predicate calculus formulas" ++ + "\n" ++ + "\n-unlexer: untokenization transforming linearization output into a string." ++ + "\n The default is unwords." ++ + "\n -unlexer=unwords space-separated token list (like unwords)" ++ + "\n -unlexer=text format as text: punctuation, capitalization, paragraph <p>" ++ + "\n -unlexer=code format as code (spacing, indentation)" ++ + "\n -unlexer=textlit like text, but remove string literal quotes" ++ + "\n -unlexer=codelit like code, but remove string literal quotes" ++ + "\n -unlexer=concat remove all spaces" ++ + "\n -unlexer=bind like identity, but bind at \"&+\"" ++ + "\n" ++ + []
\ No newline at end of file diff --git a/src/JavaGUI/DynamicTree.java b/src/JavaGUI/DynamicTree.java new file mode 100644 index 000000000..6acc6ff64 --- /dev/null +++ b/src/JavaGUI/DynamicTree.java @@ -0,0 +1,272 @@ +
+/*
+ * This code is based on an example provided by Richard Stanford,
+ * a tutorial reader.
+ */
+
+import java.awt.*;
+import javax.swing.*;
+import javax.swing.tree.*;
+import javax.swing.event.*;
+import java.util.Vector;
+import java.awt.event.*;
+
+public class DynamicTree extends JPanel implements KeyListener,
+ ActionListener{
+ public static DefaultMutableTreeNode rootNode;
+ protected DefaultTreeModel treeModel;
+ public JTree tree;
+ public int oldSelection = 0;
+ private Toolkit toolkit = Toolkit.getDefaultToolkit();
+ JPopupMenu popup = new JPopupMenu();
+ JMenuItem menuItem;
+ Timer timer = new Timer(500, this);
+ MouseEvent m;
+
+ public DynamicTree() {
+ timer.setRepeats(false);
+ rootNode = new DefaultMutableTreeNode("Root Node");
+ treeModel = new DefaultTreeModel(rootNode);
+ treeModel.addTreeModelListener(new MyTreeModelListener());
+
+ tree = new JTree(treeModel);
+ tree.setRootVisible(false);
+ tree.setEditable(false);
+ tree.getSelectionModel().setSelectionMode
+ (TreeSelectionModel.SINGLE_TREE_SELECTION);
+ tree.addKeyListener(this);
+ menuItem = new JMenuItem("Paste");
+ menuItem.addActionListener(this);
+ popup.add(menuItem);
+
+ //Add listener to components that can bring up popup menus.
+ MouseListener popupListener = new PopupListener();
+ tree.addMouseListener(popupListener);
+
+ tree.addTreeSelectionListener(new TreeSelectionListener() {
+ public void valueChanged(TreeSelectionEvent e) {
+ if (tree.getSelectionRows()!=null) {
+ if (GFEditor.nodeTable == null)
+ {if (GFEditor.debug) System.out.println("null node table");}
+ else
+ {if (GFEditor.debug) System.out.println("node table: "+
+ GFEditor.nodeTable.contains(new Integer(0)) +" "+
+ GFEditor.nodeTable.keys().nextElement()); }
+ if (tree.getSelectionPath() == null)
+ {if (GFEditor.debug) System.out.println("null root path"); }
+ else
+ {if (GFEditor.debug) System.out.println("selected path"+
+ tree.getSelectionPath());}
+ int i = ((Integer)GFEditor.nodeTable.get(
+ tree.getSelectionPath())).intValue();
+ int j = oldSelection;
+ GFEditor.treeChanged = true;
+ if (i>j) GFEditor.send("> "+String.valueOf(i-j));
+ else GFEditor.send("< "+String.valueOf(j-i));
+ }
+ }
+ });
+
+ tree.setCellRenderer(new MyRenderer());
+ tree.setShowsRootHandles(true);
+ setPreferredSize(new Dimension(200, 100));
+ JScrollPane scrollPane = new JScrollPane(tree);
+ setLayout(new GridLayout(1,0));
+ add(scrollPane);
+ }
+
+ /** Remove all nodes except the root node. */
+ public void clear() {
+ rootNode.removeAllChildren();
+ treeModel.reload();
+ }
+
+ /** Remove the currently selected node. */
+ public void removeCurrentNode() {
+ TreePath currentSelection = tree.getSelectionPath();
+ if (currentSelection != null) {
+ DefaultMutableTreeNode currentNode = (DefaultMutableTreeNode)
+ (currentSelection.getLastPathComponent());
+ MutableTreeNode parent = (MutableTreeNode)(currentNode.getParent());
+ if (parent != null) {
+ treeModel.removeNodeFromParent(currentNode);
+ return;
+ }
+ }
+
+ // Either there was no selection, or the root was selected.
+ toolkit.beep();
+ }
+
+ /** Add child to the currently selected node. */
+ public DefaultMutableTreeNode addObject(Object child) {
+ DefaultMutableTreeNode parentNode = null;
+ TreePath parentPath = tree.getSelectionPath();
+
+ if (parentPath == null) {
+ parentNode = rootNode;
+ } else {
+ parentNode = (DefaultMutableTreeNode)
+ (parentPath.getLastPathComponent());
+ }
+
+ return addObject(parentNode, child, true);
+ }
+
+ public DefaultMutableTreeNode addObject(DefaultMutableTreeNode parent,
+ Object child) {
+ return addObject(parent, child, false);
+ }
+
+ public DefaultMutableTreeNode addObject(DefaultMutableTreeNode parent,
+ Object child,
+ boolean shouldBeVisible) {
+ DefaultMutableTreeNode childNode =
+ new DefaultMutableTreeNode(child);
+
+ if (parent == null) {
+ parent = rootNode;
+ }
+
+ treeModel.insertNodeInto(childNode, parent,
+ parent.getChildCount());
+
+ // Make sure the user can see the lovely new node.
+ if (shouldBeVisible) {
+ tree.scrollPathToVisible(new TreePath(childNode.getPath()));
+ }
+ return childNode;
+ }
+
+ class MyTreeModelListener implements TreeModelListener {
+ public void treeNodesChanged(TreeModelEvent e) {
+ DefaultMutableTreeNode node;
+ node = (DefaultMutableTreeNode)
+ (e.getTreePath().getLastPathComponent());
+
+ /*
+ * If the event lists children, then the changed
+ * node is the child of the node we've already
+ * gotten. Otherwise, the changed node and the
+ * specified node are the same.
+ */
+ try {
+ int index = e.getChildIndices()[0];
+ node = (DefaultMutableTreeNode)
+ (node.getChildAt(index));
+ } catch (NullPointerException exc) {}
+
+ if (GFEditor.debug) System.out.println
+ ("The user has finished editing the node.");
+ if (GFEditor.debug) System.out.println(
+ "New value: " + node.getUserObject());
+ }
+ public void treeNodesInserted(TreeModelEvent e) {
+ }
+ public void treeNodesRemoved(TreeModelEvent e) {
+ }
+ public void treeStructureChanged(TreeModelEvent e) {
+ }
+ }
+
+ private class MyRenderer extends DefaultTreeCellRenderer {
+ ImageIcon tutorialIcon;
+
+ public MyRenderer() {
+ tutorialIcon = new ImageIcon("images/middle.gif");
+ }
+
+ public Component getTreeCellRendererComponent(
+ JTree tree,
+ Object value,
+ boolean sel,
+ boolean expanded,
+ boolean leaf,
+ int row,
+ boolean hasFocus) {
+
+ super.getTreeCellRendererComponent(
+ tree, value, sel,
+ expanded, leaf, row,
+ hasFocus);
+ if (leaf && isTutorialBook(value))
+ setIcon(tutorialIcon);
+
+ return this;
+ }
+ protected boolean isTutorialBook(Object value) {
+ DefaultMutableTreeNode node =
+ (DefaultMutableTreeNode)value;
+ String nodeInfo =
+ (String)(node.getUserObject());
+
+ if (nodeInfo.indexOf("?") >= 0) {
+ return true;
+ }
+
+ return false;
+ }
+
+ }//class
+
+ class PopupListener extends MouseAdapter {
+ public void mousePressed(MouseEvent e) {
+ int selRow = tree.getRowForLocation(e.getX(), e.getY());
+ tree.setSelectionRow(selRow);
+ if (GFEditor.debug) System.out.println("selection changed!");
+ maybeShowPopup(e);
+ }
+
+ public void mouseReleased(MouseEvent e) {
+ if (GFEditor.debug) System.out.println("mouse released!");
+ maybeShowPopup(e);
+ }
+ }
+ void maybeShowPopup(MouseEvent e) {
+ if (GFEditor.debug) System.out.println("may be!");
+ if (e.isPopupTrigger()) {
+ m=e;
+ timer.start();
+ }
+ }
+ void addMenuItem(String name){
+ menuItem = new JMenuItem(name);
+ menuItem.addActionListener(this);
+ popup.add(menuItem);
+
+ }
+
+ public void actionPerformed(ActionEvent ae)
+ {
+ if (ae.getSource()==timer){
+ if (GFEditor.debug) System.out.println("changing menu!");
+ popup.removeAll();
+ for (int i = 0; i<GFEditor.listModel.size() ; i++)
+ addMenuItem(GFEditor.listModel.elementAt(i).toString());
+ popup.show(m.getComponent(), m.getX(), m.getY());
+ }
+ else{
+ GFEditor.treeChanged = true;
+ GFEditor.send((String)GFEditor.commands.elementAt
+ (popup.getComponentIndex((JMenuItem)(ae.getSource()))));
+ }
+ }
+
+ /** Handle the key pressed event. */
+ public void keyPressed(KeyEvent e) {
+ int keyCode = e.getKeyCode();
+ switch (keyCode){
+ case 32: GFEditor.send("'"); break;
+ case 127: GFEditor.send("d"); break;
+ }
+ }
+ /** Handle the key typed event. */
+ public void keyTyped(KeyEvent e) {
+ }
+ /** Handle the key released event. */
+ public void keyReleased(KeyEvent e) {
+ }
+
+}
+
+
diff --git a/src/JavaGUI/GFEditor.java b/src/JavaGUI/GFEditor.java new file mode 100644 index 000000000..2625f2e3a --- /dev/null +++ b/src/JavaGUI/GFEditor.java @@ -0,0 +1,1420 @@ +//package javaGUI;
+
+import java.awt.*;
+import java.awt.event.*;
+import javax.swing.*;
+import javax.swing.text.*;
+import javax.swing.event.*;
+import javax.swing.tree.*;
+import java.io.*;
+import java.util.*;
+//import gfWindow.GrammarFilter;
+
+public class GFEditor extends JFrame implements ActionListener, KeyListener {
+
+ public static boolean debug = false;
+ public static boolean newObject = false;
+ public static boolean finished = false;
+ private String parseInput = "";
+ private String alphaInput = "";
+ private static String status = "status";
+ private static String selectedMenuLanguage = "Abstract";
+ private static String linearization = "";
+ private String termInput = "";
+ private static String outputString = "";
+ private static String treeString = "";
+ private static String fileString = "";
+ public static Vector commands = new Vector();
+ public static Hashtable nodeTable = new Hashtable();
+ JFileChooser fc1 = new JFileChooser("./");
+ JFileChooser fc = new JFileChooser("./");
+ private String [] filterMenu = {"Filter", "identity",
+ "erase", "take100", "text", "code", "latexfile",
+ "structured", "unstructured" };
+ private String [] modifyMenu = {"Modify", "identity","transfer",
+ "compute", "paraphrase", "typecheck", "solve", "context" };
+// private String [] modeMenu = {"Menus", "printname",
+// "plain", "short", "long", "typed", "untyped" };
+ private static String [] newMenu = {"New"};
+
+ private static boolean firstLin = true;
+ private static boolean waiting = false;
+ public static boolean treeChanged = true;
+ private static String result;
+ private static int selectionStart;
+ private static int selectionEnd;
+ private static BufferedReader fromProc;
+ private static BufferedWriter toProc;
+ private static String commandPath = new String("GF");
+ private static JTextArea output = new JTextArea();
+ public static DefaultListModel listModel= new DefaultListModel();
+ private JList list = new JList(listModel);
+ private static DynamicTree tree = new DynamicTree();
+
+ private JLabel grammar = new JLabel("No topic ");
+ private JButton save = new JButton("Save");
+ private JButton open = new JButton("Open");
+ private JButton newTopic = new JButton("New Topic");
+ private JButton gfCommand = new JButton("GF command");
+
+ private JButton leftMeta = new JButton("?<");
+ private JButton left = new JButton("<");
+ private JButton top = new JButton("Top");
+ private JButton right = new JButton(">");
+ private JButton rightMeta = new JButton(">?");
+ private JButton read = new JButton("Read");
+ // private JButton parse = new JButton("Parse");
+ // private JButton term = new JButton("Term");
+ private JButton alpha = new JButton("Alpha");
+ private JButton random = new JButton("Random");
+ private JButton undo = new JButton("Undo");
+
+ private JPanel inputPanel = new JPanel();
+ private JPanel inputPanel2 = new JPanel();
+ private JPanel inputPanel3 = new JPanel();
+ private JButton ok = new JButton("OK");
+ private JButton cancel = new JButton("Cancel");
+ private JTextField inputField = new JTextField();
+ private JLabel inputLabel = new JLabel("Read: ");
+ private JButton browse = new JButton("Browse...");
+ private ButtonGroup readGroup = new ButtonGroup();
+ private JRadioButton termReadButton = new JRadioButton("Term");
+ private JRadioButton stringReadButton = new JRadioButton("String");
+
+ private JDialog dialog;
+
+ private static JComboBox menu = new JComboBox(newMenu);
+ private JComboBox filter = new JComboBox(filterMenu);
+ private JComboBox modify = new JComboBox(modifyMenu);
+ // private JComboBox mode = new JComboBox(modeMenu);
+
+ private JPanel downPanel = new JPanel();
+ private JSplitPane treePanel;
+ private JPanel upPanel = new JPanel();
+ private JPanel middlePanel = new JPanel();
+ private JPanel middlePanelUp = new JPanel();
+ private JPanel middlePanelDown = new JPanel();
+ private JSplitPane centerPanel;
+ private static JFrame gui2 = new JFrame();
+ private JPanel centerPanel2= new JPanel();
+ private JPanel centerPanelDown = new JPanel();
+ private JScrollPane outputPanelDown = new JScrollPane(list);
+ private JScrollPane outputPanelCenter = new JScrollPane(output);
+ private JPanel outputPanelUp = new JPanel();
+ private JPanel statusPanel = new JPanel();
+ private static JLabel statusLabel = new JLabel(status);
+ private Container cp;
+
+ private static JMenuBar menuBar= new JMenuBar();;
+ private static ButtonGroup menuGroup = new ButtonGroup();
+ private JMenu viewMenu= new JMenu("View");
+ private JMenu submenu= new JMenu("language");
+ private JMenu modeMenu= new JMenu("Menus");
+ private static JMenu langMenu= new JMenu("Languages");
+ private static JMenu fileMenu= new JMenu("File");
+ private JRadioButtonMenuItem rbMenuItem;
+ private JRadioButtonMenuItem rbMenuItemLong;
+ // private JRadioButtonMenuItem rbMenuItemAbs;
+ private JRadioButtonMenuItem rbMenuItemUnTyped;
+ private static JMenuItem fileMenuItem;
+ private static JCheckBoxMenuItem cbMenuItem;
+ private static RadioListener myListener ;
+ private static ButtonGroup group = new ButtonGroup();
+ private static ButtonGroup languageGroup = new ButtonGroup();
+
+ public GFEditor()
+ {
+ this.addWindowListener(new WindowAdapter() {
+ public void windowClosing(WindowEvent e) {
+ endProgram();
+ }
+ });
+ setJMenuBar(menuBar);
+ setTitle("GF Syntax Editor");
+ viewMenu.setToolTipText("View settings");
+ fileMenu.setToolTipText("Main operations");
+ langMenu.setToolTipText("Language settings");
+ menuBar.add(fileMenu);
+ menuBar.add(langMenu);
+ menuBar.add(viewMenu);
+ menuBar.add(modeMenu);
+
+ cbMenuItem = new JCheckBoxMenuItem("Tree");
+ cbMenuItem.setActionCommand("showTree");
+ myListener = new RadioListener();
+ cbMenuItem.addActionListener(myListener);
+ cbMenuItem.setSelected(true);
+ viewMenu.add(cbMenuItem);
+ viewMenu.addSeparator();
+
+ fileMenuItem = new JMenuItem("Open...");
+ fileMenuItem.setActionCommand("open");
+ fileMenuItem.addActionListener(this);
+ fileMenu.add(fileMenuItem);
+ fileMenuItem = new JMenuItem("New Topic...");
+ fileMenuItem.setActionCommand("newTopic");
+ fileMenuItem.addActionListener(this);
+ fileMenu.add(fileMenuItem);
+ fileMenuItem = new JMenuItem("Reset");
+ fileMenuItem.setActionCommand("reset");
+ fileMenuItem.addActionListener(this);
+ fileMenu.add(fileMenuItem);
+ fileMenuItem = new JMenuItem("Save As...");
+ fileMenuItem.setActionCommand("save");
+ fileMenuItem.addActionListener(this);
+ fileMenu.add(fileMenuItem);
+ fileMenu.addSeparator();
+ fileMenuItem = new JMenuItem("Exit");
+ fileMenuItem.setActionCommand("quit");
+ fileMenuItem.addActionListener(this);
+ fileMenu.add(fileMenuItem);
+
+ rbMenuItem = new JRadioButtonMenuItem("One window");
+ rbMenuItem.setActionCommand("combine");
+ rbMenuItem.addActionListener(myListener);
+ rbMenuItem.setSelected(true);
+/* rbMenuItem.setMnemonic(KeyEvent.VK_R);
+ rbMenuItem.setAccelerator(KeyStroke.getKeyStroke(
+ KeyEvent.VK_1, ActionEvent.ALT_MASK));
+ rbMenuItem.getAccessibleContext().setAccessibleDescription(
+ "This doesn't really do anything");
+*/
+ menuGroup.add(rbMenuItem);
+ viewMenu.add(rbMenuItem);
+
+ rbMenuItem = new JRadioButtonMenuItem("Split windows");
+ rbMenuItem.setMnemonic(KeyEvent.VK_O);
+ rbMenuItem.setActionCommand("split");
+ rbMenuItem.addActionListener(myListener);
+ menuGroup.add(rbMenuItem);
+ viewMenu.add(rbMenuItem);
+
+ modeMenu.add(submenu);
+
+ /* rbMenuItemAbs = new JRadioButtonMenuItem("Abstract");
+ rbMenuItemAbs.setActionCommand("Abstract");
+ rbMenuItemAbs.addActionListener(myListener);
+ languageGroup.add(rbMenuItemAbs);
+ */
+
+ modeMenu.addSeparator();
+ menuGroup = new ButtonGroup();
+ rbMenuItemLong = new JRadioButtonMenuItem("long");
+ rbMenuItemLong.setActionCommand("long");
+ rbMenuItemLong.setSelected(true);
+ rbMenuItemLong.addActionListener(myListener);
+ menuGroup.add(rbMenuItemLong);
+ modeMenu.add(rbMenuItemLong);
+ rbMenuItem = new JRadioButtonMenuItem("short");
+ rbMenuItem.setActionCommand("short");
+ rbMenuItem.addActionListener(myListener);
+ menuGroup.add(rbMenuItem);
+ modeMenu.add(rbMenuItem);
+ modeMenu.addSeparator();
+
+ menuGroup = new ButtonGroup();
+ rbMenuItem = new JRadioButtonMenuItem("typed");
+ rbMenuItem.setActionCommand("typed");
+ rbMenuItem.addActionListener(myListener);
+ rbMenuItem.setSelected(false);
+ menuGroup.add(rbMenuItem);
+ modeMenu.add(rbMenuItem);
+ rbMenuItemUnTyped = new JRadioButtonMenuItem("untyped");
+ rbMenuItemUnTyped.setSelected(true);
+ rbMenuItemUnTyped.setActionCommand("untyped");
+ rbMenuItemUnTyped.addActionListener(myListener);
+ menuGroup.add(rbMenuItemUnTyped);
+ modeMenu.add(rbMenuItemUnTyped);
+
+ cp = getContentPane();
+ cp.setLayout(new BorderLayout());
+ output.setToolTipText("Linearizations' display area");
+ output.setEditable(false);
+ output.setLineWrap(true);
+ output.setWrapStyleWord(true);
+// output.setSelectionColor(Color.green);
+ output.setSelectionColor(Color.white);
+// output.setFont(new Font("Arial Unicode MS", Font.PLAIN, 17));
+ output.setFont(new Font(null, Font.PLAIN, 17));
+// System.out.println(output.getFont().getFontName());
+ gfCommand.setToolTipText("Sending a command to GF");
+ read.setToolTipText("Refining with term or linearization from typed string or file");
+ modify.setToolTipText("Choosing a linearization method");
+ alpha.setToolTipText("Performing alpha-conversion");
+ random.setToolTipText("Generating random refinement");
+ undo.setToolTipText("Going back to the previous state");
+ downPanel.add(gfCommand);
+ //downPanel.add(parse);
+ //downPanel.add(term);
+ downPanel.add(read);
+ downPanel.add(modify);
+ downPanel.add(alpha);
+ downPanel.add(random);
+ downPanel.add(undo);
+
+ leftMeta.setToolTipText("Moving the focus to the previous metavariable");
+ rightMeta.setToolTipText("Moving the focus to the next metavariable");
+ left.setToolTipText("Moving the focus to the previous term");
+ right.setToolTipText("Moving the focus to the next term");
+ top.setToolTipText("Moving the focus to the top term");
+ middlePanelUp.add(leftMeta);
+ middlePanelUp.add(left);
+ middlePanelUp.add(top);
+ middlePanelUp.add(right);
+ middlePanelUp.add(rightMeta);
+ middlePanelDown.add(new JLabel("Select Action on Subterm"));
+ middlePanel.setLayout(new BorderLayout());
+ middlePanel.add(middlePanelUp, BorderLayout.NORTH);
+ middlePanel.add(middlePanelDown, BorderLayout.CENTER);
+
+ menu.setToolTipText("The list of available categories to start editing");
+ open.setToolTipText("Reading both a new environment and an editing object from file. Current editing will be discarded");
+ save.setToolTipText("Writing the current editing object to file in the term or text format");
+ grammar.setToolTipText("Current Topic");
+ newTopic.setToolTipText("Reading a new environment from file. Current editing will be discarded.");
+ upPanel.add(grammar);
+ upPanel.add(menu);
+ upPanel.add(open);
+ upPanel.add(save);
+ upPanel.add(newTopic);
+
+ filter.setToolTipText("Choosing the linearization representation format");
+ modeMenu.setToolTipText("Choosing the refinement options' representation");
+ statusLabel.setToolTipText("The current focus type");
+ list.setToolTipText("The list of current refinment options");
+ tree.setToolTipText("The abstract syntax tree representation of the current editing object");
+ upPanel.add(filter);
+ //upPanel.add(mode);
+ populateTree(tree);
+ outputPanelUp.setLayout(new BorderLayout());
+ outputPanelUp.add(outputPanelCenter, BorderLayout.CENTER);
+ outputPanelUp.add(statusPanel, BorderLayout.SOUTH);
+ statusPanel.setLayout(new GridLayout(1,1));
+ statusPanel.add(statusLabel);
+ treePanel = new JSplitPane(JSplitPane.HORIZONTAL_SPLIT,
+ tree, outputPanelUp);
+ treePanel.setDividerSize(5);
+ treePanel.setDividerLocation(100);
+ centerPanel2.setLayout(new BorderLayout());
+ gui2.setSize(350,150);
+ gui2.setTitle("Select Action on Subterm");
+ gui2.setLocationRelativeTo(treePanel);
+ centerPanelDown.setLayout(new BorderLayout());
+ centerPanel = new JSplitPane(JSplitPane.VERTICAL_SPLIT,
+ treePanel, centerPanelDown);
+ centerPanel.addKeyListener(tree);
+ centerPanel.setOneTouchExpandable(true);
+ centerPanelDown.add(middlePanel, BorderLayout.NORTH);
+ centerPanelDown.add(outputPanelDown, BorderLayout.CENTER);
+ cp.add(centerPanel, BorderLayout.CENTER);
+ cp.add(upPanel, BorderLayout.NORTH);
+ cp.add(downPanel, BorderLayout.SOUTH);
+
+ list.setSelectionMode(ListSelectionModel.SINGLE_SELECTION);
+
+ MouseListener mouseListener = new MouseAdapter() {
+ public void mouseClicked(MouseEvent e) {
+ if (e.getClickCount() == 2) {
+ listAction(list.locationToIndex(e.getPoint()));
+ }
+ }
+ };
+ list.addMouseListener(mouseListener);
+ list.addKeyListener(this);
+ menu.addActionListener(this);
+ save.addActionListener(this);
+ open.addActionListener(this);
+ newTopic.addActionListener(this);
+ gfCommand.addActionListener(this);
+
+ filter.addActionListener(this);
+ filter.setMaximumRowCount(9);
+ leftMeta.addActionListener(this);
+ left.addActionListener(this);
+
+ menu.setFocusable(false);
+ save.setFocusable(false);
+ save.setActionCommand("save");
+ open.setFocusable(false);
+ open.setActionCommand("open");
+ newTopic.setFocusable(false);
+ newTopic.setActionCommand("newTopic");
+ gfCommand.setFocusable(false);
+
+ filter.setFocusable(false);
+ leftMeta.setFocusable(false);
+ left.setFocusable(false);
+
+ top.addActionListener(this);
+ right.addActionListener(this);
+ rightMeta.addActionListener(this);
+ //parse.addActionListener(this);
+ //term.addActionListener(this);
+ read.addActionListener(this);
+ modify.addActionListener(this);
+ //mode.addActionListener(this);
+ alpha.addActionListener(this);
+ random.addActionListener(this);
+ undo.addActionListener(this);
+
+ top.setFocusable(false);
+ right.setFocusable(false);
+ rightMeta.setFocusable(false);
+ //parse.setFocusable(false);
+ //term.setFocusable(false);
+ read.setFocusable(false);
+ modify.setFocusable(false);
+ //mode.setFocusable(false);
+ alpha.setFocusable(false);
+ random.setFocusable(false);
+ undo.setFocusable(false);
+
+ output.addKeyListener(tree);
+ setSize(800,730);
+ outputPanelUp.setPreferredSize(new Dimension(500,300));
+ treePanel.setDividerLocation(0.3);
+ nodeTable.put(new TreePath(DynamicTree.rootNode.getPath()), new Integer(0));
+ setVisible(true);
+
+ JRadioButton termButton = new JRadioButton("Term");
+ termButton.setActionCommand("term");
+ termButton.setSelected(true);
+ JRadioButton linButton = new JRadioButton("Text");
+ linButton.setActionCommand("lin");
+ // Group the radio buttons.
+ group.add(linButton);
+ group.add(termButton);
+ JPanel buttonPanel = new JPanel();
+ buttonPanel.setPreferredSize(new Dimension(70, 70));
+ buttonPanel.add(new JLabel("Format:"));
+ buttonPanel.add(linButton);
+ buttonPanel.add(termButton);
+ fc1.setAccessory(buttonPanel);
+
+ termReadButton.setActionCommand("term");
+ stringReadButton.setSelected(true);
+ stringReadButton.setActionCommand("lin");
+ // Group the radio buttons.
+ readGroup.add(stringReadButton);
+ readGroup.add(termReadButton);
+ JPanel readButtonPanel = new JPanel();
+ readButtonPanel.setLayout(new GridLayout(3,1));
+ readButtonPanel.setPreferredSize(new Dimension(70, 70));
+ readButtonPanel.add(new JLabel("Format:"));
+ readButtonPanel.add(stringReadButton);
+ readButtonPanel.add(termReadButton);
+ dialog= new JDialog(this, "Input");
+ dialog.setLocationRelativeTo(this);
+ dialog.getContentPane().add(inputPanel);
+ inputPanel.setLayout(new BorderLayout(10,10));
+ inputPanel3.setLayout(new GridLayout(2,1,5,5));
+ inputPanel3.add(inputLabel);
+ inputPanel3.add(inputField);
+ ok.addActionListener(this);
+ browse.addActionListener(this);
+ cancel.addActionListener(this);
+ inputField.setPreferredSize(new Dimension(300,23));
+ inputPanel.add(inputPanel3, BorderLayout.CENTER);
+ inputPanel.add(new JLabel(" "), BorderLayout.WEST);
+ inputPanel.add(readButtonPanel, BorderLayout.EAST);
+ inputPanel.add(inputPanel2, BorderLayout.SOUTH);
+ inputPanel2.add(ok);
+ inputPanel2.add(cancel);
+ inputPanel2.add(browse);
+ dialog.setSize(350,135);
+
+ try {
+ result = fromProc.readLine();
+ while(result != null) {
+ finished = false;
+ if (debug) System.out.println("1 "+result);
+ while (result.indexOf("gf")==-1){
+ outputString +=result+"\n";
+ result = fromProc.readLine();
+ if (debug) System.out.println("1 "+result);
+ }
+ output.append(outputString);
+ while ((result.indexOf("newcat")==-1)&&(result.indexOf("<lin ")==-1)){
+ result = fromProc.readLine();
+ if (debug) System.out.println("1 "+result);
+ }
+ if (result.indexOf("<lin ")==-1)
+ formNewMenu();
+
+ if (!finished) {
+
+ while ((result.length()==0)||(result.indexOf("<lin ")==-1)) {
+ result = fromProc.readLine();
+ if (result!=null){
+ if (debug) System.out.println("10 "+result);
+ }
+ else System.exit(0);
+ }
+ readLin();
+ readTree();
+ readMessage();
+ if (newObject)
+ formSelectMenu();
+ else {
+ while(result.indexOf("</menu")==-1) {
+ result = fromProc.readLine();
+ if (debug) System.out.println("12 "+result);
+ }
+ }
+ for (int i=0; i<3; i++){
+ result = fromProc.readLine();
+ if (debug) System.out.println("11 "+result);
+ }
+ }
+ }
+ output.append("*** NOTHING MORE TO READ FROM " + commandPath + "\n");
+ } catch (IOException e) {
+ System.out.println("Could not read from external process");
+ }
+ }
+
+ public static void send(String text){
+ try {
+ output.setText("");
+ outputString = "";
+ if (debug) System.out.println("output cleared");
+ toProc.write(text, 0, text.length());
+ toProc.newLine();
+ toProc.flush();
+ } catch (IOException e) {
+ System.out.println("Could not write to external process");
+ }
+ }
+
+ public void endProgram(){
+ send("q");
+ System.exit(0);
+ }
+
+ public static void main(String args[])
+ {
+ Locale.setDefault(Locale.US);
+ try {
+ Process extProc = Runtime.getRuntime().exec(args[0]);
+ fromProc = new BufferedReader (new InputStreamReader(
+ extProc.getInputStream(),"UTF8"));
+ toProc = new BufferedWriter(new OutputStreamWriter(extProc.getOutputStream()));
+ /* try {
+ UIManager.setLookAndFeel(
+ //UIManager.getSystemLookAndFeelClassName() );
+ "com.sun.java.swing.plaf.windows.WindowsLookAndFeel");
+ } catch (Exception e) { }
+ */
+ GFEditor gui = new GFEditor();
+
+ } catch (IOException e) {
+ System.out.println("Could not start " + commandPath);
+ }
+ }
+
+ public static void formSelectMenu (){
+ if (debug) System.out.println("list model changing! ");
+ String s ="";
+ try {
+ //read item
+ result = fromProc.readLine();
+ if (debug) System.out.println("8 "+result);
+ listModel.clear();
+ commands.clear();
+ while (result.indexOf("/menu")==-1){
+ //read show
+ result = fromProc.readLine();
+ if (debug) System.out.println("8 "+result);
+ while (result.indexOf("/show")==-1){
+ result = fromProc.readLine();
+ if (debug) System.out.println("9 "+result);
+ if (result.indexOf("/show")==-1)
+ {
+ if (result.length()>8)
+ s+=result.trim();
+ else
+ s+=result;
+ }
+ }
+// if (s.charAt(0)!='d')
+// listModel.addElement("Refine " + s);
+// else
+ listModel.addElement(s);
+ s="";
+ //read /show
+ //read send
+ result = fromProc.readLine();
+ if (debug) System.out.println("8 "+result);
+ result = fromProc.readLine();
+ if (debug) System.out.println("8 "+result);
+ saveCommand();
+ // read /item
+ result = fromProc.readLine();
+ if (debug) System.out.println("8 "+result);
+ result = fromProc.readLine();
+ if (debug) System.out.println("8 "+result);
+ }
+ } catch(IOException e){ }
+ }
+
+ public static void saveCommand(){
+ if (newObject) commands.add(result);
+ try {
+ result = fromProc.readLine();
+ if (debug) System.out.println("9 "+result);
+ } catch(IOException e){ }
+ }
+
+ public void readLin(){
+ try {
+ linearization="";
+ linearization += result+"\n";
+ result = fromProc.readLine();
+ if (debug) System.out.println("6 "+result);
+ while (result.indexOf("/linearization")==-1){
+ linearization += result+"\n";
+ result = fromProc.readLine();
+ if (debug) System.out.println("6 "+result);
+ }
+ if (newObject) formLin();
+ result = fromProc.readLine();
+ if (debug) System.out.println("6 "+result);
+ } catch(IOException e){ }
+ }
+
+ public static void readTree(){
+ try {
+ result = fromProc.readLine();
+ if (debug) System.out.println("6 "+result);
+ while (result.indexOf("/tree")==-1){
+ treeString += result+"\n";
+ result = fromProc.readLine();
+ if (debug) System.out.println("6 "+result);
+ }
+ if (treeChanged && (newObject)) {
+ formTree(tree);
+ treeChanged = false;
+ }
+ treeString="";
+ result = fromProc.readLine();
+ if (debug) System.out.println("6 "+result);
+ } catch(IOException e){ }
+ }
+
+ public static void readMessage(){
+ String s ="";
+ try {
+ result = fromProc.readLine();
+ if (debug) System.out.println("7 "+result);
+ while (result.indexOf("/message")==-1){
+ s += result+"\n";
+ result = fromProc.readLine();
+ if (debug) System.out.println("7 "+result);
+ }
+ if (s.length()>1)
+ output.append("-------------"+'\n'+s);
+ result = fromProc.readLine();
+ if (debug) System.out.println("7 "+result);
+ } catch(IOException e){ }
+ }
+
+ public void formNewMenu () {
+ boolean more = true;
+ try {
+ result = fromProc.readLine();
+ if (debug) System.out.println("2 "+result);
+
+ while (more){
+ if (result.indexOf("language")==-1) {
+ menu.addItem(result.substring(6));
+ }
+ else
+ more = false;
+ result = fromProc.readLine();
+ if (debug) System.out.println("2 "+result);
+ result = fromProc.readLine();
+ if (debug) System.out.println("3 "+result);
+ if (result.indexOf("language")!=-1)
+ more = false;
+ result = fromProc.readLine();
+ if (debug) System.out.println("4 "+result);
+ }
+
+ more = true;
+ while (more){
+ if ((result.indexOf("/gf")==-1)&&(result.indexOf("lin")==-1)) {
+ //form lang and Menu menu:
+ cbMenuItem = new JCheckBoxMenuItem(result.substring(4));
+ if (debug) System.out.println ("menu item: "+result.substring(4));
+ cbMenuItem.setSelected(true);
+ cbMenuItem.setActionCommand("lang");
+ cbMenuItem.addActionListener(myListener);
+ langMenu.add(cbMenuItem);
+/* if ((result.substring(4)).equals("Abstract"))
+ {
+ submenu.add(rbMenuItemAbs);
+ if (selectedMenuLanguage.equals("Abstract"))
+ rbMenuItemAbs.setSelected(true);
+ languageGroup.add(rbMenuItemAbs);
+ }
+ else
+ {
+*/
+ rbMenuItem = new JRadioButtonMenuItem(result.substring(4));
+ rbMenuItem.setActionCommand(result.substring(4));
+ rbMenuItem.addActionListener(myListener);
+ languageGroup.add(rbMenuItem);
+ if ((result.substring(4)).equals(selectedMenuLanguage))
+ {
+ System.out.println("Selecting "+selectedMenuLanguage);
+ rbMenuItem.setSelected(true);
+ }
+
+ submenu.add(rbMenuItem);
+// }
+ }
+ else
+ more = false;
+ // read </language>
+ result = fromProc.readLine();
+ if (debug) System.out.println("2 "+result);
+ // read <language> or </gf...>
+ result = fromProc.readLine();
+ if (debug) System.out.println("3 "+result);
+ if ((result.indexOf("/gf")!=-1)||(result.indexOf("lin")!=-1))
+ more = false;
+ if (result.indexOf("/gf")!=-1)
+ finished = true;
+ // registering the file name:
+ if (result.indexOf("language")!=-1) {
+ String path = result.substring(result.indexOf('=')+1,
+ result.indexOf('>'));
+ path =path.substring(path.lastIndexOf('/')+1);
+ if (debug) System.out.println("name: "+path);
+ fileString +="--" + path +"\n";
+ if (path.lastIndexOf('.')!=path.indexOf('.'))
+ grammar.setText(path.substring(0,
+ path.indexOf('.')).toUpperCase()+" ");
+ }
+ result = fromProc.readLine();
+ if (debug) System.out.println("4 "+result);
+ }
+ System.out.println("languageGroupElement formed"+
+ languageGroup.getButtonCount());
+ langMenu.addSeparator();
+ fileMenuItem = new JMenuItem("Add...");
+ fileMenuItem.setActionCommand("import");
+ fileMenuItem.addActionListener(this);
+ langMenu.add(fileMenuItem);
+ // in order to get back in main in the beggining of while:
+ result = fromProc.readLine();
+ } catch(IOException e){ }
+ }
+
+ public void outputAppend(){
+ int i, j, k, l, l2, m;
+ i=result.indexOf("type=");
+ j=result.indexOf('>',i);
+ l = result.indexOf("<focus");
+ l2 = result.indexOf("focus");
+ if (l2!=-1){
+
+ // in case focus tag is cut into two lines:
+ if (l==-1) l=l2-7;
+
+ if (debug) System.out.println("form Lin1: "+result);
+ statusLabel.setText(" "+result.substring(i+5,j));
+ //cutting <focus>
+ result= result.substring(0,l)+result.substring(j+1);
+ i=result.indexOf("/f",l);
+System.out.println("/ is at the position"+i);
+ j=result.indexOf('>',i);
+ k=result.length()-j;
+ if (debug) System.out.println("form Lin2: "+result);
+ m = output.getText().length();
+
+ //cutting </focus>
+ // in case focus tag is cut into two lines:
+ if (debug)
+ System.out.println("char at the previous position"+result.charAt(i-1));
+ if (result.charAt(i-1)!='<')
+ result= result.substring(0,i-8)+result.substring(j+1);
+ else
+ result= result.substring(0,i-1)+result.substring(j+1);
+ j= result.indexOf("<focus");
+ l2 = result.indexOf("focus");
+ // in case focus tag is cut into to lines:
+ if ((l2!=-1)&&(j==-1)) j=l2-7;
+ // only one focus
+ if (j==-1){
+ output.append(result+'\n');
+ selectionStart=m+l;
+ selectionEnd=output.getText().length()-k;
+ try {
+ output.getHighlighter().addHighlight(selectionStart, selectionEnd, new DefaultHighlighter.DefaultHighlightPainter(Color.green) );
+// output.getHighlighter().addHighlight(selectionStart, selectionEnd, new DefaultHighlighter.DefaultHighlightPainter(Color.white) );
+ } catch (Exception e) {}
+ }
+ //several focuses
+ else {
+ output.append(result.substring(0,j));
+ result = result.substring(j);
+ selectionStart=m+l;
+ selectionEnd=m+i-1;
+ try {
+// output.getHighlighter().addHighlight(selectionStart, selectionEnd, new DefaultHighlighter.DefaultHighlightPainter(Color.green) );
+ output.getHighlighter().addHighlight(selectionStart, selectionEnd, new DefaultHighlighter.DefaultHighlightPainter(Color.white) );
+ } catch (Exception e) {}
+ outputAppend();
+ }
+ if (debug) System.out.println("form Lin3: "+result);
+ }
+ else
+ output.append(result+'\n');
+ firstLin=false;
+ }
+
+ public void formLin(){
+ boolean visible=true;
+ firstLin=true;
+ result = linearization.substring(0,linearization.indexOf('\n'));
+ String lin = linearization.substring(linearization.indexOf('\n')+1);
+ //extract the language from result
+ int ind = result.indexOf('=');
+ int ind2 = result.indexOf('>');
+ String s = result.substring(ind+1,ind2);
+ result = lin.substring(0,lin.indexOf("</lin>"));
+ lin = lin.substring(lin.indexOf("</lin>"));
+ while (lin.length()>1) {
+ //check if the language is on
+ if (!visible) visible = true;
+ // in the list?
+ for (int i=0; i<langMenu.getItemCount()-2;i++)
+ if (langMenu.getItem(i).getText().equals(s))
+ {
+ visible = false;
+ break;
+ }
+ if (!visible) visible = true;
+ else {
+ //add item to the language list:
+ cbMenuItem = new JCheckBoxMenuItem(s);
+ if (debug) System.out.println ("menu item: "+s);
+ cbMenuItem.setSelected(true);
+ cbMenuItem.setActionCommand("lang");
+ cbMenuItem.addActionListener(myListener);
+ if (langMenu.getItemCount()<2)
+ langMenu.add(cbMenuItem, langMenu.getItemCount());
+ else
+ langMenu.add(cbMenuItem, langMenu.getItemCount()-2);
+
+ rbMenuItem = new JRadioButtonMenuItem(s);
+ rbMenuItem.setActionCommand(s);
+ rbMenuItem.addActionListener(myListener);
+ languageGroup.add(rbMenuItem);
+ submenu.add(rbMenuItem);
+
+ }
+ // selected?
+ for (int i=0; i<langMenu.getItemCount()-2;i++)
+ if ((langMenu.getItem(i).getText().equals(s))&&
+ !(langMenu.getItem(i).isSelected()) ) {
+ visible = false;
+ break;
+ }
+ if (visible) {
+ if (!firstLin)
+ output.append("************"+'\n');
+ if (debug) System.out.println("linearization for the language: "+result);
+ outputAppend();
+ }
+ // read </lin>
+ lin = lin.substring(lin.indexOf('\n')+1);
+ // read lin or 'end'
+ if (lin.length()<1) break;
+
+ result = lin.substring(0,lin.indexOf('\n'));
+ lin = lin.substring(lin.indexOf('\n')+1);
+ if (result.indexOf("<lin ")!=-1){
+ //extract the language from result
+ ind = result.indexOf('=');
+ ind2 = result.indexOf('>');
+ s = result.substring(ind+1,ind2);
+ result = lin.substring(0,lin.indexOf("</lin>"));
+ lin = lin.substring(lin.indexOf("</lin>"));
+ }
+ }
+ }
+
+ public void actionPerformed(ActionEvent ae)
+ {
+ boolean abs = true;
+ Object obj = ae.getSource();
+ if ( obj == menu ) {
+ if (!menu.getSelectedItem().equals("New"))
+ {
+ treeChanged = true;
+ send("n " + menu.getSelectedItem());
+ newObject = true;
+ menu.setSelectedIndex(0);
+ }
+ }
+ if ( obj == filter ) {
+ if (!filter.getSelectedItem().equals("Filter"))
+ {
+ send("f " + filter.getSelectedItem());
+ filter.setSelectedIndex(0);
+ }
+ }
+ if ( obj == modify ) {
+ if (!modify.getSelectedItem().equals("Modify"))
+ {
+ treeChanged = true;
+ send("c " + modify.getSelectedItem());
+ modify.setSelectedIndex(0);
+ }
+ }
+/* if ( obj == mode ) {
+ if (!mode.getSelectedItem().equals("Menus"))
+ {
+ send("o " + mode.getSelectedItem());
+ mode.setSelectedIndex(0);
+ }
+ }
+*/
+ // buttons and menu items:
+ try {
+ if (Class.forName("javax.swing.AbstractButton").isInstance(obj)) {
+ String name =((AbstractButton)obj).getActionCommand();
+
+ if ( name.equals("quit")) {
+ endProgram();
+ }
+
+ if ( name.equals("save") ) {
+
+ if (fc1.getChoosableFileFilters().length<2)
+ fc1.addChoosableFileFilter(new GrammarFilter());
+ int returnVal = fc1.showSaveDialog(GFEditor.this);
+ if (returnVal == JFileChooser.APPROVE_OPTION) {
+ File file = fc1.getSelectedFile();
+ if (debug) System.out.println("saving ... ");
+
+ // checking if the abstract syntax is on:
+ for (int i=0; i<langMenu.getItemCount()-2;i++)
+ if ((langMenu.getItem(i).getText().equals("Abstract"))&&
+ !(langMenu.getItem(i).isSelected()) ) {
+ if (debug) System.out.println("No Abstract syntax !!!!");
+ abs = false;
+ break;
+ }
+
+ String text = output.getText();
+ int end = text.indexOf("******");
+
+ // saving as a term:
+ if (group.getSelection().getActionCommand().equals("term")) {
+ if (end !=-1)
+ if (abs) {
+ writeOutput(fileString+text.substring(0, end), file.getPath());
+ abs=true;
+ }
+ else {
+ int i = linearization.indexOf('\n');
+ int j = linearization.indexOf("/lin");
+ writeOutput(fileString+linearization.substring(i+1, j-1), file.getPath());
+ }
+ else
+ JOptionPane.showMessageDialog(this, "No term to save");
+ }
+ // saving as a linearization:
+ else
+ // abstract syntax is shown:
+ if (abs){
+ end = text.indexOf('\n', end);
+ writeOutput(fileString+text.substring(end), file.getPath());
+ abs = true;
+ }
+ else
+ writeOutput(fileString+text, file.getPath());
+ }
+ }
+
+ if ( name.equals("open") ) {
+ if (fc1.getChoosableFileFilters().length<2)
+ fc1.addChoosableFileFilter(new GrammarFilter());
+ int returnVal = fc1.showOpenDialog(GFEditor.this);
+ if (returnVal == JFileChooser.APPROVE_OPTION) {
+
+ /* "sending" should be fixed on the GF side:
+ rbMenuItemLong.setSelected(true);
+ send("ms long");
+ rbMenuItemUnTyped.setSelected(true);
+ send("mt untyped");
+ selectedMenuLanguage = "Abstract";
+ rbMenuItemAbs.setSelected(true);
+ send("ml Abs");
+ */
+
+ treeChanged = true;
+ newObject = true;
+ menu.removeAllItems();
+ menu.addItem("New");
+ langMenu.removeAll();
+
+ AbstractButton ab = null;
+
+ while (languageGroup.getButtonCount()>0)
+ {
+ for (Enumeration e = languageGroup.getElements();
+ e.hasMoreElements() ;)
+ {
+ ab = (AbstractButton)e.nextElement();
+ System.out.println("more to remove ! "+ab.getText());
+ languageGroup.remove(ab);
+ }
+ System.out.println("languageGroupElement after import removal "+
+ languageGroup.getButtonCount());
+ }
+ submenu.removeAll();
+
+ File file = fc1.getSelectedFile();
+ // opening the file for editing :
+ if (debug) System.out.println("opening: "+ file.getPath().replace('\\','/'));
+ if (group.getSelection().getActionCommand().equals("term")) {
+ if (debug) System.out.println(" opening as a term ");
+ send("open "+ file.getPath().replace('\\','/'));
+ }
+ else {
+ if (debug) System.out.println(" opening as a linearization ");
+ send("openstring "+ file.getPath().replace('\\','/'));
+ }
+
+ fileString ="";
+ grammar.setText("No Topic ");
+ }
+ }
+
+ if ( name.equals("import") ) {
+ if (fc.getChoosableFileFilters().length<2)
+ fc.addChoosableFileFilter(new GrammarFilter());
+ int returnVal = fc.showOpenDialog(GFEditor.this);
+ if (returnVal == JFileChooser.APPROVE_OPTION) {
+ File file = fc.getSelectedFile();
+ // importing a new language :
+ if (debug) System.out.println("importing: "+ file.getPath());
+
+ langMenu.removeAll();
+
+ AbstractButton ab = null;
+
+ while (languageGroup.getButtonCount()>0)
+ {
+ for (Enumeration e = languageGroup.getElements();
+ e.hasMoreElements() ;)
+ {
+ ab = (AbstractButton)e.nextElement();
+ System.out.println("more to remove ! "+ab.getText());
+ languageGroup.remove(ab);
+ }
+ System.out.println("languageGroupElement after import removal "+
+ languageGroup.getButtonCount());
+ }
+
+ submenu.removeAll();
+
+ menu.removeAllItems();
+ menu.addItem("New");
+ fileString ="";
+ send("i "+ file.getPath().replace('\\','/'));
+
+ }
+ }
+ if ( name.equals("newTopic") ) {
+ if (fc.getChoosableFileFilters().length<2)
+ fc.addChoosableFileFilter(new GrammarFilter());
+ int returnVal = fc.showOpenDialog(GFEditor.this);
+ if (returnVal == JFileChooser.APPROVE_OPTION) {
+ int n = JOptionPane.showConfirmDialog(this,
+ "This will dismiss the previous editing. Would you like to continue?",
+ "Starting a new topic", JOptionPane.YES_NO_OPTION);
+ if (n == JOptionPane.YES_OPTION){
+ File file = fc.getSelectedFile();
+ // importing a new grammar :
+ newObject = false;
+ statusLabel.setText(status);
+ listModel.clear();
+ tree.clear();
+ populateTree(tree);
+ menu.removeAllItems();
+ menu.addItem("New");
+ langMenu.removeAll();
+
+ AbstractButton ab = null;
+
+ while (languageGroup.getButtonCount()>0)
+ {
+ for (Enumeration e = languageGroup.getElements();
+ e.hasMoreElements() ;)
+ {
+ ab = (AbstractButton)e.nextElement();
+ System.out.println("more to remove ! "+ab.getText());
+ languageGroup.remove(ab);
+ }
+ System.out.println("languageGroupElement after import removal "+
+ languageGroup.getButtonCount());
+ }
+
+ selectedMenuLanguage = "Abstract";
+ rbMenuItemLong.setSelected(true);
+ rbMenuItemUnTyped.setSelected(true);
+ submenu.removeAll();
+
+ fileString="";
+ grammar.setText("No Topic ");
+ send("e "+ file.getPath().replace('\\','/'));
+ }
+ }
+ }
+
+ if ( obj == gfCommand ){
+ String s = JOptionPane.showInputDialog("Command:", parseInput);
+ if (s!=null) {
+ parseInput = s;
+ s = "gf "+s;
+ //treeChanged = true;
+ send(s);
+ }
+ }
+
+ if ( name.equals("reset") ) {
+ newObject = false;
+ statusLabel.setText(status);
+ listModel.clear();
+ tree.clear();
+ populateTree(tree);
+ menu.removeAllItems();
+ menu.addItem("New");
+ langMenu.removeAll();
+
+ AbstractButton ab = null;
+
+ while (languageGroup.getButtonCount()>0)
+ {
+ for (Enumeration e = languageGroup.getElements();
+ e.hasMoreElements() ;)
+ {
+ ab = (AbstractButton)e.nextElement();
+ System.out.println("more to remove ! "+ab.getText());
+ languageGroup.remove(ab);
+ }
+ System.out.println("languageGroupElement after import removal "+
+ languageGroup.getButtonCount());
+ }
+
+ selectedMenuLanguage = "Abstract";
+
+ submenu.removeAll();
+ rbMenuItemLong.setSelected(true);
+ rbMenuItemUnTyped.setSelected(true);
+
+ fileString="";
+ grammar.setText("No Topic ");
+ send("e");
+ }
+
+ if ( obj == leftMeta ) {
+ treeChanged = true;
+ send("<<");
+ }
+ if ( obj == left ) {
+ treeChanged = true;
+ send("<");
+ }
+ if ( obj == top ) {
+ treeChanged = true;
+ send("'");
+ }
+ if ( obj == right ) {
+ treeChanged = true;
+ send(">");
+ }
+ if ( obj == rightMeta ) {
+ treeChanged = true;
+ send(">>");
+ }
+
+ if ( obj == cancel ) {
+ dialog.hide();
+ }
+
+ if ( obj == browse ) {
+ if (fc.getChoosableFileFilters().length<2)
+ fc.addChoosableFileFilter(new GrammarFilter());
+ int returnVal = fc.showOpenDialog(GFEditor.this);
+ if (returnVal == JFileChooser.APPROVE_OPTION) {
+ File file = fc.getSelectedFile();
+ inputField.setText(file.getPath().replace('\\','/'));
+ }
+ }
+
+ if ( obj == ok ) {
+ treeChanged = true;
+ if (termReadButton.isSelected()) {
+ termInput = inputField.getText();
+ if (termInput.indexOf('/')==-1){
+ send("g "+termInput);
+ System.out.println("sending term string");
+ }
+ else {
+ send("tfile "+termInput);
+ System.out.println("sending file term: "+termInput);
+ }
+ }
+ else {
+ parseInput = inputField.getText();
+ if (parseInput.indexOf('/')==-1){
+ send("p "+parseInput);
+ System.out.println("sending parse string"+parseInput);
+ }
+ else {
+ send("pfile "+parseInput);
+ System.out.println("sending file parse string: "+parseInput);
+ }
+ }
+ dialog.hide();
+ }
+
+ if ( obj == read ) {
+ if (stringReadButton.isSelected())
+ inputField.setText(parseInput);
+ else
+ inputField.setText(termInput);
+ dialog.show();
+ }
+
+/* if ( obj == term ) {
+ inputLabel.setText("Term:");
+ inputField.setText(termInput);
+ dialog.show();
+ }
+ if ( obj == parse ) {
+ inputLabel.setText("Parse:");
+ inputField.setText(parseInput);
+ dialog.show();
+ }
+*/
+ if ( obj == alpha){
+ String s = JOptionPane.showInputDialog("Type string:", alphaInput);
+ if (s!=null) {
+ alphaInput = s;
+ treeChanged = true;
+ send("x "+s);
+ }
+ }
+ if ( obj == random){
+ treeChanged = true;
+ send("a");
+ }
+ if ( obj == undo){
+ treeChanged = true;
+ send("u");
+ }
+ }
+ } catch (Exception e){}
+ }
+ static void writeOutput(String str, String fileName) {
+
+ try {
+ FileOutputStream fos = new FileOutputStream(fileName);
+ Writer out = new OutputStreamWriter(fos, "UTF8");
+ out.write(str);
+ out.close();
+ } catch (IOException e) {
+ JOptionPane.showMessageDialog(null,
+ "Document is empty!","Error", JOptionPane.ERROR_MESSAGE);
+ }
+ }
+ public static void populateTree(DynamicTree treePanel) {
+ String p1Name = new String("Root");
+ DefaultMutableTreeNode p1;
+ p1 = treePanel.addObject(null, p1Name);
+ }
+
+ public static void formTree(DynamicTree treePanel) {
+ Hashtable table = new Hashtable();
+ TreePath path=null;
+ boolean treeStarted = false, selected = false;
+ String s = treeString;
+ String name ="";
+ treePanel.clear();
+ int j, shift=0, star=0, index = 0;
+ DefaultMutableTreeNode p2=null, p1=null;
+ if (debug) System.out.print("treeString: "+ s);
+ if (s.indexOf('*')!=-1) star = 1;
+ while (s.length()>0) {
+ while ((s.length()>0) && ((s.charAt(0)=='*')||(s.charAt(0)==' '))){
+ if (s.charAt(0) == '*') selected = true;
+ s = s.substring(1);
+ shift++;
+ }
+ if (s.length()>0) {
+ j = s.indexOf("\n");
+ name = s.substring(0, j);
+ index++;
+ s = s.substring(j+1);
+ shift = (shift - star)/2;
+
+ p1 = (DefaultMutableTreeNode)table.get(new Integer(shift));
+ p2 = treePanel.addObject(p1, name);
+ table.put(new Integer(shift+1), p2);
+ path = new TreePath(p2.getPath());
+ nodeTable.put(path, new Integer(index));
+ if (selected) {
+ treePanel.tree.setSelectionPath(path);
+ treePanel.oldSelection = index;
+ if (debug) System.out.println("new selected index "+ index);
+ selected = false;
+ }
+ treeStarted=true;
+ }
+ shift = 0;
+ }
+ if ((p2!=null)) {
+ treePanel.tree.makeVisible(path);
+ gui2.toFront();
+ index = 0;
+ }
+ }
+
+ /** Listens to the radio buttons. */
+ class RadioListener implements ActionListener {
+ public void actionPerformed(ActionEvent e) {
+ String action = e.getActionCommand();
+ if (action.equals("split") ) {
+ cp.remove(centerPanel);
+ centerPanel2.add(middlePanelUp, BorderLayout.SOUTH);
+ if (((JCheckBoxMenuItem)viewMenu.getItem(0)).isSelected()) {
+ centerPanel2.add(treePanel, BorderLayout.CENTER);
+ }
+ else {
+ centerPanel2.add(outputPanelUp, BorderLayout.CENTER);
+ }
+ cp.add(centerPanel2, BorderLayout.CENTER);
+ gui2.getContentPane().add(outputPanelDown);
+ gui2.setVisible(true);
+ pack();
+ repaint();
+ }
+ if (action.equals("combine") ) {
+ cp.remove(centerPanel2);
+ middlePanel.add(middlePanelUp, BorderLayout.NORTH);
+ if (((JCheckBoxMenuItem)viewMenu.getItem(0)).isSelected()) { gui2.setVisible(false);
+ centerPanel.setLeftComponent(treePanel);
+ }
+ else {
+ centerPanel.setLeftComponent(outputPanelUp);
+ gui2.setVisible(false);
+ }
+ cp.add(centerPanel, BorderLayout.CENTER);
+ centerPanelDown.add(outputPanelDown, BorderLayout.CENTER);
+ pack();
+ repaint();
+ }
+ if (action.equals("showTree") ) {
+ if (!((JCheckBoxMenuItem)e.getSource()).isSelected()){
+ if (debug) System.out.println("was selected");
+ cbMenuItem.setSelected(false);
+ if (((JRadioButtonMenuItem)viewMenu.getItem(2)).isSelected()) {
+ centerPanel.remove(treePanel);
+ centerPanel.setLeftComponent(outputPanelUp);
+ }
+ else {
+ centerPanel2.remove(treePanel);
+ centerPanel2.add(outputPanelUp, BorderLayout.CENTER);
+ }
+ }
+ else {
+ if (debug) System.out.println("was not selected");
+ cbMenuItem.setSelected(true);
+ if (((JRadioButtonMenuItem)viewMenu.getItem(2)).isSelected()) {
+ centerPanel.remove(outputPanelUp);
+ treePanel.setRightComponent(outputPanelUp);
+ centerPanel.setLeftComponent(treePanel);
+ }
+ else {
+ centerPanel2.remove(outputPanelUp);
+ treePanel.setRightComponent(outputPanelUp);
+ centerPanel2.add(treePanel, BorderLayout.CENTER);
+ }
+ }
+ pack();
+ repaint();
+ }
+ if (action.equals("lang")) {
+ if (newObject) {
+ output.setText("");
+ formLin();
+ }
+ if (debug)
+ System.out.println("language option has changed "+((JCheckBoxMenuItem)e.getSource()).getText());
+ if (((JCheckBoxMenuItem)e.getSource()).isSelected()){
+ System.out.println("turning on");
+ send("on "+((JCheckBoxMenuItem)e.getSource()).getText());
+ }
+ else{
+ System.out.println("turning off");
+ send("off "+((JCheckBoxMenuItem)e.getSource()).getText());
+ }
+ }
+ //modeMenus actions:
+ else {
+ if ((action.equals("long")) || (action.equals("short")))
+ {
+ send("ms " + action);
+ }
+ else
+ if ((action.equals("typed")) || (action.equals("untyped")))
+ {
+ send("mt " + action);
+ }
+ else
+ {
+ selectedMenuLanguage = action;
+ if (action.equals("Abstract"))
+ {
+ send("ml Abs");
+ }
+ else
+ {
+ System.out.println("sending "+action);
+ send("ml " + action);
+ }
+ }
+ }
+ }
+ }
+
+ /** Handle the key pressed event. */
+ public void keyPressed(KeyEvent e) {
+ int keyCode = e.getKeyCode();
+ if (keyCode == 10) {
+ listAction(list.getSelectedIndex());
+ }
+ }
+ /** Handle the key typed event. */
+ public void keyTyped(KeyEvent e) {
+ }
+ /** Handle the key released event. */
+ public void keyReleased(KeyEvent e) {
+ }
+
+ public void listAction(int index) {
+ if (index == -1)
+ {if (debug) System.out.println("no selection");}
+ else {
+ treeChanged = true;
+ send((String)commands.elementAt(list.getSelectedIndex()));
+ }
+ }
+}
diff --git a/src/JavaGUI/GrammarFilter.java b/src/JavaGUI/GrammarFilter.java new file mode 100644 index 000000000..514da3fa8 --- /dev/null +++ b/src/JavaGUI/GrammarFilter.java @@ -0,0 +1,30 @@ +import java.io.File; +import javax.swing.*; +import javax.swing.filechooser.*; + +public class GrammarFilter extends FileFilter { + + // Accept all directories and all gf, gfm files. + public boolean accept(File f) { + if (f.isDirectory()) { + return true; + } + + String extension = Utils.getExtension(f); + if (extension != null) { + if (extension.equals(Utils.gf) || + extension.equals(Utils.gfm)) { + return true; + } else { + return false; + } + } + + return false; + } + + // The description of this filter + public String getDescription() { + return "Just Grammars"; + } +} diff --git a/src/JavaGUI/Utils.java b/src/JavaGUI/Utils.java new file mode 100644 index 000000000..f7c6f5b93 --- /dev/null +++ b/src/JavaGUI/Utils.java @@ -0,0 +1,22 @@ + +import java.io.File; + +public class Utils { + + public final static String gf = "gf"; + public final static String gfm = "gfm"; + + /* + * Get the extension of a file. + */ + public static String getExtension(File f) { + String ext = null; + String s = f.getName(); + int i = s.lastIndexOf('.'); + + if (i > 0 && i < s.length() - 1) { + ext = s.substring(i+1).toLowerCase(); + } + return ext; + } +} diff --git a/src/Makefile b/src/Makefile new file mode 100644 index 000000000..2a9019c03 --- /dev/null +++ b/src/Makefile @@ -0,0 +1,23 @@ +GHMAKE=ghc +GHCFLAGS=-package lang -package util +GHCFUDFLAG=-package Fudgets +GHCINCLUDE=-iapi -icompile -igrammar -iinfra -ishell -isource -icanonical -iuseGrammar -icf -ifor-ghc + +all: + make today ; make ghc +ghc: + $(GHMAKE) $(GHCFLAGS) $(GHCINCLUDE) $(GHCFUDFLAG) --make GF.hs -o gf2+ ; strip gf2+ ; mv gf2+ ../bin/ +batch: + $(GHMAKE) $(GHCFLAGS) $(GHCINCLUDE) --make GF2.hs -o gf2 ; strip gf2 +api: + $(GHMAKE) $(GHCFLAGS) $(GHCINCLUDE) --make API.hs +shell: + $(GHMAKE) $(GHCFLAGS) $(GHCINCLUDE) --make Shell.hs +clean: + rm -rf */*.o */*.hi *.o *.hi */*.ghi *.ghi *~ */*~ +hugs: + hugs -P.:for-hugs:api:source:canonical:cf:grammar:infra:shell:useGrammar:compile: GF +today: + runhugs util/MkToday +javac: + cd java ; javac GFEditor.java ; cd .. diff --git a/src/Today.hs b/src/Today.hs new file mode 100644 index 000000000..9bb6712ee --- /dev/null +++ b/src/Today.hs @@ -0,0 +1 @@ +module Today where today = "Mon Sep 22 15:54:44 CEST 2003" diff --git a/src/tools/GFDoc.hs b/src/tools/GFDoc.hs new file mode 100644 index 000000000..0c5f943d9 --- /dev/null +++ b/src/tools/GFDoc.hs @@ -0,0 +1,255 @@ +module Main where + +import List +import System +import Char + +-- produce a HTML document from a list of GF grammar files. AR 6/10/2002 + +-- to read files and write a file + +main :: IO () +main = do + xx <- getArgs + let + (typ,format,name) = case xx of + "+latex" : x: [] -> (True,doc2latex,x) + x:[] -> (False,doc2html,x) + _ -> (True,doc2html, "unknown.txt") --- + if null xx + then do + putStrLn welcome + putStrLn help + else do + ss <- readFile name + let outfile = fileFormat typ name + writeFile outfile $ format $ pDoc $ ss + +welcome = unlines [ + "", + "gfdoc - a rudimentary GF document generator.", + "(c) Aarne Ranta (aarne@cs.chalmers.se) 2002 under GNU GPL." + ] + +help = unlines $ [ + "", + "Usage: gfdoc (+latex) file", + "", + "The program operates with lines in GF code, treating them into LaTeX", + "(flag +latex) or to HTML (by default). The output is written in a file", + "whose name is formed from the input file name by replacing its suffix", + "with html or tex.", + "", + "The translation is line by line", + "depending as follows on how the line begins", + "", + " --[Int] heading of level Int", + " -- new paragraph", + " --. end of document", +--- " --- ignore this comment line in document", +--- " {---} ignore this code line in document", + " --[Text] Text belongs to text paragraph", + " [Text] Text belongs to code paragraph", + "", + "Within a text paragraph, text enclosed between certain characters", + "is treated specially:", + "", + " *[Text]* emphasized (boldface)", + " \"[Text]\" example string (italics)", + " $[Text]$ example code (courier)" + ] + +fileFormat isLatex x = body ++ if isLatex then "tex" else "html" where + body = reverse $ dropWhile (/='.') $ reverse x + +-- the document datatype + +data Doc = Doc Title [Paragraph] + +type Title = [TextItem] + +data Paragraph = + Text [TextItem] -- text line starting with -- + | List [[TextItem]] -- + | Code String -- other text line + | New -- new paragraph: line consisting of -- + | Heading Int [TextItem] -- text line starting with --n where n = 1,2,3,4 + +data TextItem = + Str String + | Emp String -- emphasized, *...* + | Lit String -- string literal, "..." + | Inl String -- inlined code, '...' + + +-- parse document + +pDoc :: String -> Doc +pDoc s = case lines s of + ('-':'-':'1':title) : paras -> Doc (pItems title) (map pPara (grp paras)) + paras -> Doc [] (map pPara (grp paras)) + where + grp ss = case ss of + s : rest --- | ignore s -> grp rest + | isEnd s -> [] + | begComment s -> let (s1,s2) = getComment (drop 2 s : rest) + in map ("-- " ++) s1 ++ grp s2 + | isComment s -> s : grp rest + | all isSpace s -> grp rest + [] -> [] + _ -> unlines code : grp rest where (code,rest) = span (not . isComment) ss + pPara s = case s of + '-':'-':d:text | isDigit d -> Heading (read [d]) (pItems text) + '-':'-':[] -> New + '-':'-':text -> Text (pItems (dropWhile isSpace text)) + _ -> Code s + pItems s = case s of + '*' : cs -> get 1 Emp (=='*') cs + '"' : cs -> get 1 Lit (=='"') cs + '$' : cs -> get 1 Inl (=='$') cs + [] -> [] + _ -> get 0 Str (flip elem "*\"$") s + + get _ _ _ [] = [] + get k con isEnd cs = con beg : pItems (drop k rest) + where (beg,rest) = span (not . isEnd) cs + + ignore s = case s of + '-':'-':'-':_ -> True + '{':'-':'-':'-':'}':_ -> True + _ -> False + + isEnd s = case s of + '-':'-':'.':_ -> True + _ -> False + + +-- render in html + +doc2html :: Doc -> String +doc2html (Doc title paras) = unlines $ + tagXML "html" $ + tagXML "body" $ + unwords (tagXML "i" ["Produced by " ++ welcome]) : + mkTagXML "p" : + concat (tagXML "h1" [concat (map item2html title)]) : + empty : + map para2html paras + +para2html :: Paragraph -> String +para2html p = case p of + Text its -> concat (map item2html its) + Code s -> unlines $ tagXML "pre" $ map (indent 2) $ + remEmptyLines $ lines $ spec s + New -> mkTagXML "p" + Heading i its -> concat $ tagXML ('h':show i) [concat (map item2html its)] + +item2html :: TextItem -> String +item2html i = case i of + Str s -> spec s + Emp s -> concat $ tagXML "b" [spec s] + Lit s -> concat $ tagXML "i" [spec s] + Inl s -> concat $ tagXML "tt" [spec s] + +mkTagXML t = '<':t ++ ">" +mkEndTagXML t = mkTagXML ('/':t) +tagXML t ss = mkTagXML t : ss ++ [mkEndTagXML t] + +spec = elimLt + +elimLt s = case s of + '<':cs -> "<" ++ elimLt cs + c :cs -> c : elimLt cs + _ -> s + + +-- render in latex + +doc2latex :: Doc -> String +doc2latex (Doc title paras) = unlines $ + preludeLatex : + funLatex "title" [concat (map item2latex title)] : + funLatex "author" [fontLatex "footnotesize" (welcome)] : + envLatex "document" ( + funLatex "maketitle" [] : + map para2latex paras) + +para2latex :: Paragraph -> String +para2latex p = case p of + Text its -> concat (map item2latex its) + Code s -> unlines $ envLatex "verbatim" $ map (indent 2) $ + remEmptyLines $ lines $ s + New -> "\n" + Heading i its -> headingLatex i (concat (map item2latex its)) + +item2latex :: TextItem -> String +item2latex i = case i of + Str s -> specl s + Emp s -> fontLatex "bf" (specl s) + Lit s -> fontLatex "it" (specl s) + Inl s -> fontLatex "tt" (specl s) + +funLatex :: String -> [String] -> String +funLatex f xs = "\\" ++ f ++ concat ["{" ++ x ++ "}" | x <- xs] + +envLatex :: String -> [String] -> [String] +envLatex e ss = + funLatex "begin" [e] : + ss ++ + [funLatex "end" [e]] + +headingLatex :: Int -> String -> String +-- for slides +-- headingLatex _ s = funLatex "newone" [] ++ "\n" ++ funLatex "heading" [s] +headingLatex i s = funLatex t [s] where + t = case i of + 2 -> "section" + 3 -> "subsection" + _ -> "subsubsection" + +fontLatex :: String -> String -> String +fontLatex f s = "{\\" ++ f ++ " " ++ s ++ "}" + +specl = eliml + +eliml s = case s of + '|':cs -> mmath "mid" ++ elimLt cs + '{':cs -> mmath "\\{" ++ elimLt cs + '}':cs -> mmath "\\}" ++ elimLt cs + _ -> s + +mmath s = funLatex "mbox" ["$" ++ s ++ "$"] + +preludeLatex = unlines $ [ + "\\documentclass[12pt]{article}", + "\\usepackage{isolatin1}", + "\\setlength{\\oddsidemargin}{0mm}", + "\\setlength{\\evensidemargin}{-2mm}", + "\\setlength{\\topmargin}{-16mm}", + "\\setlength{\\textheight}{240mm}", + "\\setlength{\\textwidth}{158mm}", + "\\setlength{\\parskip}{2mm}", + "\\setlength{\\parindent}{0mm}" + ] + +-- auxiliaries + +empty = "" + +isComment = (== "--") . take 2 + +begComment = (== "{-") . take 2 + +getComment ss = case ss of + "-}":ls -> ([],ls) + l:ls -> (l : s1, s2) where (s1,s2) = getComment ls + _ -> ([],[]) + +indent n = (replicate n ' ' ++) + +remEmptyLines = rem False where + rem prevGood ls = case span empty ls of + (_ :_, ss@(_ : _)) -> (if prevGood then ("":) else id) $ rem False ss + (_, []) -> [] + (_, s:ss) -> s : rem True ss + empty = all isSpace diff --git a/src/tools/MkHelpFile.hs b/src/tools/MkHelpFile.hs new file mode 100644 index 000000000..9355a688e --- /dev/null +++ b/src/tools/MkHelpFile.hs @@ -0,0 +1,20 @@ +module Main where + +main = do + s <- readFile "HelpFile" + let s' = mkHsFile (lines s) + writeFile "HelpFile.hs" s' + +mkHsFile ss = + "module HelpFile where\n\n" ++ + "txtHelpFile =\n" ++ + unlines (map mkOne ss) ++ + " []" + +mkOne s = " \"" ++ pref s ++ (escs s) ++ "\" ++" + where + pref (' ':_) = "\\n" + pref _ = "\\n" --- + escs [] = [] + escs (c:cs) | elem c "\"\\" = '\\':c:escs cs + escs (c:cs) = c:escs cs diff --git a/src/tools/MkToday.hs b/src/tools/MkToday.hs new file mode 100644 index 000000000..1a15de2b5 --- /dev/null +++ b/src/tools/MkToday.hs @@ -0,0 +1,15 @@ +module Main where + +import System + +main :: IO () +main = do + system "date >foo.tmp" + d0 <- readFile "foo.tmp" + let d = head $ lines d0 + writeFile "Today.hs" $ mkToday d + system "rm foo.tmp" + return () + +mkToday d = "module Today where today = \"" ++ d ++ "\"\n" + diff --git a/src/tools/WriteF.hs b/src/tools/WriteF.hs new file mode 100644 index 000000000..fd491b4e5 --- /dev/null +++ b/src/tools/WriteF.hs @@ -0,0 +1,57 @@ +module Main where +import Fudgets +import System + +import Operations + +import Greek (mkGreek) +import Arabic (mkArabic) +import Hebrew (mkHebrew) +import Russian (mkRussian) + +-- AR 12/4/2000 + +main = do + xx <- getArgs + (case xx of + "HELP" : _ -> putStrLn usageWriteF + "FILE" : file : _ -> do + str <- readFileIf file + fudlogueWrite (Just str) + w:_ -> fudlogueWrite (Just (unwords xx)) + _ -> fudlogueWrite Nothing) + +usageWriteF = + "Usage: WriteF [-H20Mg -A5M] [FILE <filename> | <inputstring> | HELP]" ++++ + "Without arguments, an interactive display is opened." ++++ + "Prefix your string with / for Greek, - for Arabic, + for Hebrew, _ for Russian." + +fudlogueWrite mbstr = + fudlogue $ + shellF "Unicode Output" (writeF mbstr >+< quitButtonF) + +writeF Nothing = writeOutputF >==< writeInputF +writeF (Just str) = startupF [str] writeOutputF + +displaySizeP = placerF (spacerP (sizeS (Point 440 500)) verticalP) + +writeOutputF = + displaySizeP (moreF' (setFont myFont)) +--- displaySizeP (scrollF (displayF' (setFont myFont))) +--- >=^< +--- vboxD' 0 . map g + >==< + mapF (map mkUnicode . lines) + +writeInputF = stringInputF' (setShowString mkUnicode . setFont myFont) + +mkUnicode s = case s of + '/':cs -> mkGreek cs + '+':cs -> mkHebrew cs + '-':cs -> mkArabic cs + '_':cs -> mkRussian cs + _ -> s + +myFont = "-mutt-clearlyu-medium-r-normal--17-120-100-100-p-101-iso10646-1" +--- myFont = "-arabic-newspaper-medium-r-normal--32-246-100-100-p-137-iso10646-1" +--- myFont = "-misc-fixed-medium-r-semicondensed--13-120-75-75-c-60-iso10646-1" |