diff options
| author | aarne <aarne@cs.chalmers.se> | 2008-06-25 16:43:48 +0000 |
|---|---|---|
| committer | aarne <aarne@cs.chalmers.se> | 2008-06-25 16:43:48 +0000 |
| commit | b96b36f43de3e2f8b58d5f539daa6f6d47f25870 (patch) | |
| tree | 0992334be13cec6538a1dea22fbbf26ad6bdf224 /src/GF/Devel | |
| parent | fe367412e0aeb4ad5c02de68e6eca382e0f96984 (diff) | |
removed src for 2.9
Diffstat (limited to 'src/GF/Devel')
56 files changed, 0 insertions, 16689 deletions
diff --git a/src/GF/Devel/AbsCompute.hs b/src/GF/Devel/AbsCompute.hs deleted file mode 100644 index a55fbc83f..000000000 --- a/src/GF/Devel/AbsCompute.hs +++ /dev/null @@ -1,145 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : AbsCompute --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/02 20:50:19 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.8 $ --- --- computation in abstract syntax w.r.t. explicit definitions. --- --- old GF computation; to be updated ------------------------------------------------------------------------------ - -module GF.Devel.AbsCompute (LookDef, - compute, - computeAbsTerm, - computeAbsTermIn, - beta - ) where - -import GF.Data.Operations - -import GF.Grammar.Abstract -import GF.Grammar.PrGrammar -import GF.Grammar.LookAbs -import GF.Devel.Compute - -import Debug.Trace -import Data.List(intersperse) -import Control.Monad (liftM, liftM2) - --- for debugging -tracd m t = t --- tracd = trace - -compute :: GFCGrammar -> Exp -> Err Exp -compute = computeAbsTerm - -computeAbsTerm :: GFCGrammar -> Exp -> Err Exp -computeAbsTerm gr = computeAbsTermIn (lookupAbsDef gr) [] - --- | a hack to make compute work on source grammar as well -type LookDef = Ident -> Ident -> Err (Maybe Term) - -computeAbsTermIn :: LookDef -> [Ident] -> Exp -> Err Exp -computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e 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) -> tracd ("\nmatching" +++ prt f) $ - case findMatch eqs aa' of - Ok (d,g) -> do - --- let (xs,ts) = unzip g - --- ts' <- alphaFreshAll vv' ts - let g' = g --- zip xs ts' - d' <- compt vv' $ substTerm vv' g' d - tracd ("by Egs:" +++ prt d') $ return $ mkAbs yy $ d' - _ -> tracd ("no match" +++ prt t') $ - do - let v = mkApp f aa' - return $ mkAbs yy $ v - Just d -> tracd ("define" +++ prt t') $ do - da <- compt vv' $ mkApp d aa' - return $ mkAbs yy $ da - _ -> do - let t2 = mkAbs yy $ mkApp f aa' - tracd ("not defined" +++ prt_ t2) $ return t2 - - look t = case t of - (Q m f) -> case lookd m f of - Ok (Just EData) -> Nothing -- canonical --- should always be QC - Ok md -> md - _ -> Nothing - Eqs _ -> return t ---- for nested fn - _ -> Nothing - -beta :: [Ident] -> Exp -> Exp -beta vv c = case c of - Let (x,(_,a)) b -> beta vv $ substTerm vv [(x,beta vv a)] (beta (x:vv) b) - App f a -> - let (a',f') = (beta vv a, beta vv f) in - case f' of - Abs x b -> beta vv $ substTerm vv [(x,a')] (beta (x:vv) b) - _ -> (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 - --- special version of pattern matching, to deal with comp under lambda - -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 (tracd ("value" +++ prt_ val) 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' = err (\s -> tracd s (Bad s)) (\t -> tracd (prtm p t) (return t)) $ ---- - case (p,t') of - (PV IW, _) | notMeta t -> return [] -- optimization with wildcard - (PV x, _) | notMeta t -> return [(x,t)] - (PString s, ([],K i,[])) | s==i -> return [] - (PInt s, ([],EInt i,[])) | s==i -> return [] - (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding? - (PP q p pp, ([], QC r f, tt)) | - p `eqStrIdent` f && length pp == length tt -> do - matches <- mapM tryMatch (zip pp tt) - return (concat matches) - (PP q p pp, ([], Q r f, tt)) | - p `eqStrIdent` f && length pp == length tt -> do - matches <- mapM tryMatch (zip pp tt) - return (concat matches) - (PT _ p',_) -> trym p' t' - (_, ([],Alias _ _ d,[])) -> tryMatch (p,d) - (PAs x p',_) -> do - subst <- trym p' t' - return $ (x,t) : subst - _ -> Bad ("no match in pattern" +++ prt p +++ "for" +++ prt t) - - notMeta e = case e of - Meta _ -> False - App f a -> notMeta f && notMeta a - Abs _ b -> notMeta b - _ -> True - - prtm p g = - prt p +++ ":" ++++ unwords [" " ++ prt_ x +++ "=" +++ prt_ y +++ ";" | (x,y) <- g] diff --git a/src/GF/Devel/Arch.hs b/src/GF/Devel/Arch.hs deleted file mode 100644 index dedb1b4f5..000000000 --- a/src/GF/Devel/Arch.hs +++ /dev/null @@ -1,89 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Arch --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/10 14:55:01 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.8 $ --- --- architecture\/compiler dependent definitions for unix\/hbc ------------------------------------------------------------------------------ - -module GF.Devel.Arch ( - myStdGen, prCPU, selectLater, modifiedFiles, ModTime, getModTime,getNowTime, - welcomeArch, laterModTime) where - -import System.Time -import System.Random -import System.CPUTime -import Control.Monad (filterM) -import System.Directory - - ----- 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 :: Integer -> IO Integer -prCPU cpu = do - cpu' <- getCPUTime - putStrLn (show ((cpu' - cpu) `div` 1000000000) ++ " msec") - return cpu' - -welcomeArch :: String -welcomeArch = "This is the system compiled with ghc." - --- | 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 modified also if it has not been read yet --- --- new 23\/2\/2004: the environment ofs has just module names -modifiedFiles :: [(FilePath,ModTime)] -> [FilePath] -> IO [FilePath] -modifiedFiles ofs fs = do - filterM isModified fs - where - isModified file = case lookup (justModName file) ofs of - Just to -> do - t <- getModificationTime file - return $ to < t - _ -> return True - - justModName = - reverse . takeWhile (/='/') . tail . dropWhile (/='.') . reverse - -type ModTime = ClockTime - -laterModTime :: ModTime -> ModTime -> Bool -laterModTime = (>) - -getModTime :: FilePath -> IO (Maybe ModTime) -getModTime f = do - b <- doesFileExist f - if b then (getModificationTime f >>= return . Just) else return Nothing - -getNowTime :: IO ModTime -getNowTime = getClockTime diff --git a/src/GF/Devel/CheckGrammar.hs b/src/GF/Devel/CheckGrammar.hs deleted file mode 100644 index 0910802d1..000000000 --- a/src/GF/Devel/CheckGrammar.hs +++ /dev/null @@ -1,1090 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CheckGrammar --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 23:24:33 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.31 $ --- --- 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 ------------------------------------------------------------------------------ - -module GF.Devel.CheckGrammar ( - showCheckModule, justCheckLTerm, allOperDependencies, topoSortOpers) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Grammar.Refresh ---- - -import GF.Devel.TypeCheck -import GF.Grammar.Values (cPredefAbs) --- - -import GF.Grammar.PrGrammar -import GF.Grammar.Lookup -import GF.Grammar.LookAbs -import GF.Grammar.Macros -import GF.Grammar.ReservedWords ---- -import GF.Grammar.PatternMatch -import GF.Grammar.AppPredefined -import GF.Grammar.Lockfield (isLockLabel) - -import GF.Data.Operations -import GF.Infra.CheckM - -import Data.List -import qualified Data.Set as Set -import qualified Data.Map as Map -import Control.Monad -import Debug.Trace --- - - -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 the 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 st fs me ops js) -> do - checkRestrictedInheritance ms (name, mo) - js' <- case mt of - MTAbstract -> mapMTree (checkAbsInfo gr name) js - - MTTransfer a b -> mapMTree (checkAbsInfo gr name) js - - MTResource -> mapMTree (checkResInfo gr name) js - - MTConcrete a -> do - checkErr $ topoSortOpers $ allOperDependencies name js - ModMod abs <- checkErr $ lookupModule gr a - js1 <- checkCompleteGrammar abs mo - mapMTree (checkCncInfo gr name (a,abs)) js1 - - MTInterface -> mapMTree (checkResInfo gr name) js - - MTInstance a -> do - ModMod abs <- checkErr $ lookupModule gr a - -- checkCompleteInstance abs mo -- this is done in Rebuild - mapMTree (checkResInfo gr name) js - - return $ (name, ModMod (Module mt st fs me ops js')) : ms - - _ -> return $ (name,mod) : ms - where - gr = MGrammar $ (name,mod):ms - --- check if restricted inheritance modules are still coherent --- i.e. that the defs of remaining names don't depend on omitted names ----checkRestrictedInheritance :: [SourceModule] -> SourceModule -> Check () -checkRestrictedInheritance mos (name,mo) = do - let irs = [ii | ii@(_,mi) <- extend mo, mi /= MIAll] -- names with restr. inh. - let mrs = [((i,m),mi) | (i,ModMod m) <- mos, Just mi <- [lookup i irs]] - -- the restr. modules themself, with restr. infos - mapM_ checkRem mrs - where - checkRem ((i,m),mi) = do - let (incl,excl) = partition (isInherited mi) (map fst (tree2list (jments m))) - let incld c = Set.member c (Set.fromList incl) - let illegal c = Set.member c (Set.fromList excl) - let illegals = [(f,is) | - (f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)] - case illegals of - [] -> return () - cs -> fail $ "In inherited module" +++ prt i ++ - ", dependence of excluded constants:" ++++ - unlines [" " ++ prt f +++ "on" +++ unwords (map prt is) | - (f,is) <- cs] - allDeps = ---- transClosure $ Map.fromList $ - concatMap (allDependencies (const True)) - [jments m | (_,ModMod m) <- mos] - transClosure ds = ds ---- TODO: check in deeper modules - --- | check if a term is typable -justCheckLTerm :: SourceGrammar -> Term -> Err Term -justCheckLTerm src t = do - ((t',_),_) <- checkStart (inferLType src t) - return t' - -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 typ0) md -> do - typ <- compAbsTyp [] typ0 -- to calculate let definitions - mkCheck "type of function" $ checkTyp st typ - md' <- case md of - Yes d -> do - let d' = elimTables d - mkCheckWarn "definition of function" $ checkEquation st (m,c) d' - return $ Yes d' - _ -> return md - return $ (c,AbsFun (Yes typ) md') - _ -> return (c,info) - where - mkCheck cat ss = case ss of - [] -> return (c,info) - ["[]"] -> return (c,info) ---- - _ -> checkErr $ prtBad (unlines ss ++++ "in" +++ cat) c - ---- temporary solution when tc of defs is incomplete - mkCheckWarn cat ss = case ss of - [] -> return (c,info) - ["[]"] -> return (c,info) ---- - _ -> checkWarn (unlines ss ++++ "in" +++ cat +++ prt c) >> return (c,info) - compAbsTyp g t = case t of - Vr x -> maybe (fail ("no value given to variable" +++ prt x)) return $ lookup x g - Let (x,(_,a)) b -> do - a' <- compAbsTyp g a - compAbsTyp ((x, a'):g) b - Prod x a b -> do - a' <- compAbsTyp g a - b' <- compAbsTyp ((x,Vr x):g) b - return $ Prod x a' b' - Abs _ _ -> return t - _ -> composOp (compAbsTyp g) t - - elimTables e = case e of - S t a -> elimSel (elimTables t) (elimTables a) - T _ cs -> Eqs [(elimPatt p, elimTables t) | (p,t) <- cs] - _ -> composSafeOp elimTables e - elimPatt p = case p of - PR lps -> map snd lps - _ -> [p] - elimSel t a = case a of - R fs -> mkApp t (map (snd . snd) fs) - _ -> mkApp t [a] - -checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check (BinTree Ident Info) -checkCompleteGrammar abs cnc = do - let js = jments cnc - let fs = tree2list $ jments abs - foldM checkOne js fs - where - checkOne js i@(c,info) = case info of - AbsFun (Yes _) _ -> case lookupIdent c js of - Ok _ -> return js - _ -> do - checkWarn $ "WARNING: no linearization of" +++ prt c - return js - AbsCat (Yes _) _ -> case lookupIdent c js of - Ok (AnyInd _ _) -> return js - Ok (CncCat (Yes _) _ _) -> return js - Ok (CncCat _ mt mp) -> do - checkWarn $ - "Warning: no linearization type for" +++ prt c ++ - ", inserting default {s : Str}" - return $ updateTree (c,CncCat (Yes defLinType) mt mp) js - _ -> do - checkWarn $ - "Warning: no linearization type for" +++ prt c ++ - ", inserting default {s : Str}" - return $ updateTree (c,CncCat (Yes defLinType) nope nope) js - _ -> return js - --- | General Principle: only Yes-values are checked. --- A May-value has always been checked in its origin module. -checkResInfo :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info) -checkResInfo gr mo (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') - (_, Yes de) -> do - (de',ty') <- infer de - return (Yes ty', Yes de') - (_,Nope) -> do - checkWarn "No definition given to oper" - return (pty,pde) - _ -> return (pty, pde) --- other cases are uninteresting - return (c, ResOper pty' pde') - - ResOverload tysts -> chIn "overloading" $ do - tysts' <- mapM (uncurry $ flip check) tysts - let tysts2 = [(y,x) | (x,y) <- tysts'] - --- this can only be a partial guarantee, since matching - --- with value type is only possible if expected type is given - checkUniq $ - sort [t : map snd xs | (x,_) <- tysts2, Ok (xs,t) <- [typeFormCnc x]] - return (c,ResOverload tysts2) - - ResParam (Yes (pcs,_)) -> chIn "parameter type" $ do ----- mapM ((mapM (computeLType gr . snd)) . snd) pcs - mapM_ ((mapM_ (checkIfParType gr . snd)) . snd) pcs - ts <- checkErr $ lookupParamValues gr mo c - return (c,ResParam (Yes (pcs, Just ts))) - - _ -> return (c,info) - where - infer = inferLType gr - check = checkLType gr - chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") - comp = computeLType gr - - checkUniq xss = case xss of - x:y:xs - | x == y -> raise $ "ambiguous for argument list" +++ - unwords (map (prtType gr) x) - | otherwise -> checkUniq $ y:xs - _ -> return () - - -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 - checkErr $ lookupCatContextSrc gr a c - 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) - - _ -> checkResInfo gr m (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 -{- ---- should check that not fun type - 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 cannot be" typ --} - return typ - - where - checkInh (label,typ) = checkIfParType st typ - checkLin (label,typ) = return () ---- 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 - - App (Q (IC "Predef") (IC "Ints")) _ -> return ty ---- shouldn't be needed - Q (IC "Predef") (IC "Int") -> return ty ---- shouldn't be needed - Q (IC "Predef") (IC "Float") -> return ty ---- shouldn't be needed - Q (IC "Predef") (IC "Error") -> return ty ---- shouldn't be needed - - Q m c | elem c [cPredef,cPredefAbs] -> return ty - Q m c | elem c [zIdent "Int"] -> - return $ linTypeInt - Q m c | elem c [zIdent "Float",zIdent "String"] -> return defLinType ---- - - Q m ident -> checkIn ("module" +++ prt m) $ 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) -> checkErr (plusRecType r' s') >>= comp - _ -> return $ ExtR r' s' - - RecType fs -> do - let fs' = sortBy (\x y -> compare (fst x) (fst y)) fs - liftM RecType $ mapPairsM comp fs' - - _ | ty == typeTok -> return typeStr - _ | 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 () - --- to normalize records and record types -labelIndex :: Type -> Label -> Int -labelIndex ty lab = case ty of - RecType ts -> maybe (error ("label index" +++ prt lab)) id $ lookup lab $ labs ts - _ -> error $ "label index" +++ prt ty - where - labs ts = zip (map fst (sortBy (\ x y -> compare (fst x) (fst y)) ts)) [0..] - --- the underlying algorithms - -inferLType :: SourceGrammar -> Term -> Check (Term, Type) -inferLType gr trm = case trm of - - Q m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident) - - Q m ident -> checks [ - termWith trm $ checkErr (lookupResType gr m ident) >>= comp - , - checkErr (lookupResDef gr m ident) >>= infer - , -{- - do - over <- getOverload gr Nothing trm - case over of - Just trty -> return trty - _ -> prtFail "not overloaded" trm - , --} - prtFail "cannot infer type of constant" trm - ] - - QC m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident) - - QC m ident -> checks [ - termWith trm $ checkErr (lookupResType gr m ident) >>= comp - , - checkErr (lookupResDef gr m ident) >>= infer - , - prtFail "cannot infer type of canonical constant" trm - ] - - Val ty i -> termWith trm $ return ty - - Vr ident -> termWith trm $ checkLookup ident - - Typed e t -> do - t' <- comp t - check e t' - return (e,t') - - App f a -> do - over <- getOverload gr Nothing trm - case over of - Just trty -> return trty - _ -> 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) - _ -> raise ("function type expected for"+++ - prt f +++"instead of" +++ prtType env 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 ------ let tr2 = PI t' i (labelIndex ty' i) - let tr2 = P t' i - termWith tr2 $ checkErr $ case ty' of - RecType ts -> maybeErr ("unknown label" +++ prt i +++ "in" +++ prt ty') $ - lookup i ts - _ -> prtBad ("record type expected for" +++ prt t +++ "instead of") ty' - PI t i _ -> infer $ P t i - - 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] - case pts' of - [] -> prtFail "cannot infer table type of" trm ----- PInt k : _ -> return $ Ints $ max [i | PInt i <- pts'] - _ -> do - (arg,val) <- checks $ map (inferCase Nothing) pts' - check trm (Table arg val) - V arg pts -> do - (_,val) <- checks $ map infer pts - return (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, typeStr) - - EInt i -> return (trm, typeInt) - - EFloat i -> return (trm, typeFloat) - - Empty -> return (trm, typeStr) - - C s1 s2 -> - check2 (flip justCheck typeStr) C s1 s2 typeStr - - Glue s1 s2 -> - check2 (flip justCheck typeStr) Glue s1 s2 typeStr ---- typeTok - ----- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007 - Strs (Cn (IC "#conflict") : ts) -> do - trace ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) (infer $ head ts) --- checkWarn ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) --- infer $ head ts - - 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' - ---- trm' <- checkErr $ plusRecord r' s' - case (rT', sT') of - (RecType rs, RecType ss) -> do - rt <- checkErr $ plusRecType rT' sT' - check trm' rt ---- return (trm', rt) - _ | 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 - - EPattType ty -> do - ty' <- justCheck ty typeType - return (ty',typeType) - EPatt p -> do - ty <- inferPatt p - return (trm, EPattType ty) - - _ -> prtFail "cannot infer lintype of" trm - - where - env = gr - infer = inferLType env - comp = computeLType env - - check = checkLType env - - isPredef m = elem m [cPredef,cPredefAbs] - - 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 - PString _ -> True - PInt _ -> True - PFloat _ -> True - PChar -> True - PChars _ -> True - PSeq p q -> isConstPatt p && isConstPatt q - PAlt p q -> isConstPatt p && isConstPatt q - PRep p -> isConstPatt p - PNeg p -> isConstPatt p - PAs _ p -> isConstPatt p - _ -> False - - inferPatt p = case p of - PP q c ps | q /= cPredef -> checkErr $ lookupResType gr q c >>= valTypeCnc - PAs _ p -> inferPatt p - PNeg p -> inferPatt p - PAlt p q -> checks [inferPatt p, inferPatt q] - PSeq _ _ -> return $ typeStr - PRep _ -> return $ typeStr - PChar -> return $ typeStr - PChars _ -> return $ typeStr - _ -> infer (patt2term p) >>= return . snd - - --- type inference: Nothing, type checking: Just t --- the latter permits matching with value type -getOverload :: SourceGrammar -> Maybe Type -> Term -> Check (Maybe (Term,Type)) -getOverload env@gr mt t = case appForm t of - (f@(Q m c), ts) -> case lookupOverload gr m c of - Ok typs -> do - ttys <- mapM infer ts - v <- matchOverload f typs ttys - return $ Just v - _ -> return Nothing - _ -> return Nothing - where - infer = inferLType env - matchOverload f typs ttys = do - let (tts,tys) = unzip ttys - let vfs = lookupOverloadInstance tys typs - - case [vf | vf@(v,f) <- vfs, matchVal mt v] of - [(val,fun)] -> return (mkApp fun tts, val) - [] -> raise $ "no overload instance of" +++ prt f +++ - "for" +++ unwords (map (prtType env) tys) +++ "among" ++++ - unlines [" " ++ unwords (map (prtType env) ty) | (ty,_) <- typs] ++ - maybe [] (("with value type" +++) . prtType env) mt - - ---- ++++ "DEBUG" +++ unwords (map show tys) +++ ";" - ---- ++++ unlines (map (show . fst) typs) ---- - - vfs' -> case [(v,f) | (v,f) <- vfs', noProd v] of - [(val,fun)] -> do - checkWarn $ "WARNING: overloading of" +++ prt f +++ - "resolved by excluding partial applications:" ++++ - unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)] - return (mkApp fun tts, val) - - _ -> raise $ "ambiguous overloading of" +++ prt f +++ - "for" +++ unwords (map (prtType env) tys) ++++ "with alternatives" ++++ - unlines [prtType env ty | (ty,_) <- vfs'] - - matchVal mt v = elem mt ([Nothing,Just v] ++ unlocked) where - unlocked = case v of - RecType fs -> [Just $ RecType $ filter (not . isLockLabel . fst) fs] - _ -> [] - ---- TODO: accept subtypes - ---- TODO: use a trie - lookupOverloadInstance tys typs = - [(mkFunType rest val, t) | - let lt = length tys, - (ty,(val,t)) <- typs, length ty >= lt, - let (pre,rest) = splitAt lt ty, - pre == tys - ] - - noProd ty = case ty of - Prod _ _ _ -> False - _ -> True - -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') - _ -> raise $ "product expected instead of" +++ prtType env typ - - App f a -> do - over <- getOverload env (Just typ) trm - case over of - Just trty -> return trty - _ -> do - (trm',ty') <- infer trm - termWith trm' $ checkEq typ ty' trm' - - Q _ _ -> do - over <- getOverload env (Just typ) trm - case over of - Just trty -> return trty - _ -> do - (trm',ty') <- infer trm - termWith trm' $ checkEq typ ty' trm' - - 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) - _ -> raise $ "table type expected for table instead of" +++ prtType env 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 - ExtR (Vr _) (RecType _) -> termWith trm $ return typeType - -- ext t = t ** ... - _ -> prtFail "invalid record type extension" trm - RecType rr -> do - (r',ty,s') <- checks [ - do (r',ty) <- infer r - return (r',ty,s) - , - do (s',ty) <- infer s - return (s',ty,r) - ] - case ty of - RecType rr1 -> do - let (rr0,rr2) = recParts rr rr1 - r2 <- justCheck r' rr0 - s2 <- justCheck s' rr2 - return $ (ExtR r2 s2, typ) - _ -> raise ("record type expected in extension of" +++ prt r +++ - "but found" +++ prt ty) - - ExtR ty ex -> do - r' <- justCheck r ty - s' <- justCheck s ex - return $ (ExtR r' s', typ) --- is this all? - - _ -> 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 -> checks [ 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) - _ -> raise $ "table type expected for applied table instead of" +++ - prtType env ty' - , do - (arg',ty) <- infer arg - ty' <- comp ty - (tab',_) <- check tab (Table ty' typ) - return (S tab' arg', typ) - ] - 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 - - recParts rr t = (RecType rr1,RecType rr2) where - (rr1,rr2) = partition (flip elem (map fst t) . fst) rr - - 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 | not (isWildIdent x) -> return [(x,typ)] - PP q c ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006 - 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]] - ----- checkWarn $ prt p ++++ show pts ----- debug - 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' - - PAs x p -> do - g <- pattContext env typ p - return $ (x,typ):g - - PAlt p' q -> do - g1 <- pattContext env typ p' - g2 <- pattContext env typ q - let pts = [pt | pt <- g1, notElem pt g2] ++ [pt | pt <- g2, notElem pt g1] - checkCond - ("incompatible bindings of" +++ - unwords (nub (map (prt . fst) pts))+++ - "in pattern alterantives" +++ prt p) (null pts) - return g1 -- must be g1 == g2 - PSeq p q -> do - g1 <- pattContext env typ p - g2 <- pattContext env typ q - return $ g1 ++ g2 - PRep p' -> noBind typeStr p' - PNeg p' -> noBind typ p' - - _ -> return [] ---- check types! - where - cnc = env - noBind typ p' = do - co <- pattContext env typ p' - if not (null co) - then checkWarn ("no variable bound inside pattern" +++ prt p) - >> return [] - else return [] - --- 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 - (b,t',u',s) <- checkIfEqLType env t u trm - case b of - True -> return t' - False -> raise $ s +++ "type of" +++ prt trm +++ - ": expected:" +++ prtType env t ++++ - "inferred:" +++ prtType env u - -checkIfEqLType :: LTEnv -> Type -> Type -> Term -> Check (Bool,Type,Type,String) -checkIfEqLType env t u trm = do - t' <- comp t - u' <- comp u - case t' == u' || alpha [] t' u' of - True -> return (True,t',u',[]) - -- forgive missing lock fields by only generating a warning. - --- better: use a flag to forgive? (AR 31/1/2006) - _ -> case missingLock [] t' u' of - Ok lo -> do - checkWarn $ "WARNING: missing lock field" +++ unwords (map prt lo) - return (True,t',u',[]) - Bad s -> return (False,t',u',s) - - where - - -- t is a subtype of u - --- quick hack version of TC.eqVal - alpha g t u = case (t,u) of - - -- error (the empty type!) is subtype of any other type - (_,Q (IC "Predef") (IC "Error")) -> True - - -- contravariance - (Prod x a b, Prod y c d) -> alpha g c a && alpha ((x,y):g) b d - - -- record subtyping - (RecType rs, RecType ts) -> all (\ (l,a) -> - any (\ (k,b) -> alpha g a b && l == k) ts) rs - (ExtR r s, ExtR r' s') -> alpha g r r' && alpha g s s' - (ExtR r s, t) -> alpha g r t || alpha g s t - - -- the following say that Ints n is a subset of Int and of Ints m >= n - (App (Q (IC "Predef") (IC "Ints")) (EInt n), - App (Q (IC "Predef") (IC "Ints")) (EInt m)) -> m >= n - (App (Q (IC "Predef") (IC "Ints")) (EInt n), - Q (IC "Predef") (IC "Int")) -> True ---- check size! - - (Q (IC "Predef") (IC "Int"), ---- why this ???? AR 11/12/2005 - App (Q (IC "Predef") (IC "Ints")) (EInt n)) -> True - - ---- this should be made in Rename - (Q m a, Q n b) | a == b -> elem m (allExtendsPlus env n) - || elem n (allExtendsPlus env m) - || m == n --- for Predef - (QC m a, QC n b) | a == b -> elem m (allExtendsPlus env n) - || elem n (allExtendsPlus env m) - (QC m a, Q n b) | a == b -> elem m (allExtendsPlus env n) - || elem n (allExtendsPlus env m) - (Q m a, QC n b) | a == b -> elem m (allExtendsPlus env n) - || elem n (allExtendsPlus env m) - - (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) - - missingLock g t u = case (t,u) of - (RecType rs, RecType ts) -> - let - ls = [l | (l,a) <- rs, - not (any (\ (k,b) -> alpha g a b && l == k) ts)] - (locks,others) = partition isLockLabel ls - in case others of - _:_ -> Bad $ "missing record fields" +++ unwords (map prt others) - _ -> return locks - -- contravariance - (Prod x a b, Prod y c d) -> do - ls1 <- missingLock g c a - ls2 <- missingLock g b d - return $ ls1 ++ ls2 - - _ -> Bad "" - - sTypes = [typeStr, typeTok, typeString] - comp = computeLType env - --- printing a type with a lock field lock_C as C -prtType :: LTEnv -> Type -> String -prtType env ty = case ty of - RecType fs -> case filter isLockLabel $ map fst fs of - [lock] -> (drop 5 $ prt lock) --- ++++ "Full form" +++ prt ty - _ -> prtt ty - Prod x a b -> prtType env a +++ "->" +++ prtType env b - _ -> prtt ty - where - prtt t = prt t - ---- use computeLType gr to check if really equal to the cat with lock - - --- | 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 <- if n==0 then return val else - 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 - ] - --- | dependency check, detecting circularities and returning topo-sorted list - -allOperDependencies :: Ident -> BinTree Ident Info -> [(Ident,[Ident])] -allOperDependencies m = allDependencies (==m) - -allDependencies :: (Ident -> Bool) -> BinTree Ident Info -> [(Ident,[Ident])] -allDependencies ism b = - [(f, nub (concatMap opty (pts i))) | (f,i) <- tree2list b] - where - opersIn t = case t of - Q n c | ism n -> [c] - QC n c | ism n -> [c] - _ -> collectOp opersIn t - opty (Yes ty) = opersIn ty - opty _ = [] - pts i = case i of - ResOper pty pt -> [pty,pt] - ResParam (Yes (ps,_)) -> [Yes t | (_,cont) <- ps, (_,t) <- cont] - CncCat pty _ _ -> [pty] - CncFun _ pt _ -> [pt] ---- (Maybe (Ident,(Context,Type)) - AbsFun pty ptr -> [pty] --- ptr is def, which can be mutual - AbsCat (Yes co) _ -> [Yes ty | (_,ty) <- co] - _ -> [] - -topoSortOpers :: [(Ident,[Ident])] -> Err [Ident] -topoSortOpers st = do - let eops = topoTest st - either - return - (\ops -> Bad ("circular definitions:" +++ unwords (map prt (head ops)))) - eops diff --git a/src/GF/Devel/CheckM.hs b/src/GF/Devel/CheckM.hs deleted file mode 100644 index d26dbc07c..000000000 --- a/src/GF/Devel/CheckM.hs +++ /dev/null @@ -1,89 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CheckM --- Maintainer : (Maintainer) --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:33 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.5 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Devel.CheckM (Check, - checkError, checkCond, checkWarn, checkUpdate, checkInContext, - checkUpdates, checkReset, checkResets, checkGetContext, - checkLookup, checkStart, checkErr, checkVal, checkIn, - prtFail - ) where - -import GF.Data.Operations -import GF.Devel.Grammar.Grammar -import GF.Infra.Ident -import GF.Devel.Grammar.PrGF - --- | 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/Devel/Compile.hs b/src/GF/Devel/Compile.hs deleted file mode 100644 index 0655913e1..000000000 --- a/src/GF/Devel/Compile.hs +++ /dev/null @@ -1,203 +0,0 @@ -module GF.Devel.Compile (batchCompile) where - --- the main compiler passes -import GF.Devel.GetGrammar -import GF.Compile.Extend -import GF.Compile.Rebuild -import GF.Compile.Rename -import GF.Grammar.Refresh -import GF.Devel.CheckGrammar -import GF.Devel.Optimize ---import GF.Compile.Evaluate ---- -import GF.Devel.OptimizeGF ---import GF.Canon.Share ---import GF.Canon.Subexpressions (elimSubtermsMod,unSubelimModule) - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Option -import GF.Infra.CompactPrint -import GF.Devel.PrGrammar -import GF.Compile.Update -import GF.Grammar.Lookup -import GF.Infra.Modules -import GF.Devel.ReadFiles - -import GF.Source.GrammarToSource -import qualified GF.Source.AbsGF as A -import qualified GF.Source.PrintGF as P - -import GF.Data.Operations -import GF.Devel.UseIO -import GF.Devel.Arch - -import Control.Monad -import System.Directory -import System.FilePath -import System.Time -import qualified Data.Map as Map - -batchCompile :: Options -> [FilePath] -> IOE SourceGrammar -batchCompile opts files = do - (_,gr,_) <- foldM (compileModule defOpts) emptyCompileEnv files - return gr - where - defOpts = addOptions opts (options [emitCode]) - --- to output an intermediate stage -intermOut :: Options -> Option -> String -> IOE () -intermOut opts opt s = if oElem opt opts then - ioeIO (putStrLn ("\n\n--#" +++ prOpt opt) >> putStrLn s) - else return () - -prMod :: SourceModule -> String -prMod = compactPrint . prModule - - --- | the environment -type CompileEnv = (Int,SourceGrammar,ModEnv) - --- | compile with one module as starting point --- command-line options override options (marked by --#) in the file --- As for path: if it is read from file, the file path is prepended to each name. --- If from command line, it is used as it is. - -compileModule :: Options -> CompileEnv -> FilePath -> IOE CompileEnv -compileModule opts1 env file = do - opts0 <- ioeIO $ getOptionsFromFile file - let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList - let useLineOpt = maybe False (const True) $ getOptVal opts1 pathList - let opts = addOptions opts1 opts0 - let fpath = dropFileName file - ps0 <- ioeIO $ pathListOpts opts fpath - - let ps1 = if (useFileOpt && not useLineOpt) - then (ps0 ++ map (combine fpath) ps0) - else ps0 - ps <- ioeIO $ extendPathEnv ps1 - let ioeIOIf = if oElem beVerbose opts then ioeIO else (const (return ())) - ioeIOIf $ putStrLn $ "module search path:" +++ show ps ---- - let (_,sgr,rfs) = env - let file' = if useFileOpt then takeFileName file else file -- to find file itself - files <- getAllFiles opts ps rfs file' - ioeIOIf $ putStrLn $ "files to read:" +++ show files ---- - let names = map justModuleName files - ioeIOIf $ putStrLn $ "modules to include:" +++ show names ---- - foldM (compileOne opts) (0,sgr,rfs) files - - -compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv -compileOne opts env@(_,srcgr,_) file = do - - let putp s = putPointE opts s - let putpp = putPointEsil opts - let putpOpt v m act - | oElem beVerbose opts = putp v act - | oElem beSilent opts = putpp v act - | otherwise = ioeIO (putStrFlush m) >> act - - let gf = takeExtensions file - let path = dropFileName file - let name = dropExtension file - let mos = modules srcgr - - case gf of - - -- for compiled gf, read the file and update environment - -- also undo common subexp optimization, to enable normal computations - ".gfo" -> do - sm0 <- putp ("+ reading" +++ file) $ getSourceModule opts file - let sm1 = unsubexpModule sm0 - sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm1 - - extendCompileEnv env file sm - - -- for gf source, do full compilation and generate code - _ -> do - - let gfo = gfoFile (dropExtension file) - b1 <- ioeIO $ doesFileExist file - if not b1 - then compileOne opts env $ gfo - else do - - sm0 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ - getSourceModule opts file - (k',sm) <- compileSourceModule opts env sm0 - let sm1 = if isConcr sm then shareModule sm else sm -- cannot expand Str - cm <- putpp " generating code... " $ generateModuleCode opts gfo sm1 - -- sm is optimized before generation, but not in the env - extendCompileEnvInt env k' gfo sm1 - where - isConcr (_,mi) = case mi of - ModMod m -> isModCnc m && mstatus m /= MSIncomplete - _ -> False - - -compileSourceModule :: Options -> CompileEnv -> - SourceModule -> IOE (Int,SourceModule) -compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do - - let putp = putPointE opts - putpp = putPointEsil opts - mos = modules gr - - mo1 <- ioeErr $ rebuildModule mos mo - intermOut opts (iOpt "show_rebuild") (prMod mo1) - - mo1b <- ioeErr $ extendModule mos mo1 - intermOut opts (iOpt "show_extend") (prMod mo1b) - - case mo1b of - (_,ModMod n) | not (isCompleteModule n) -> do - return (k,mo1b) -- refresh would fail, since not renamed - _ -> do - mo2:_ <- putpp " renaming " $ ioeErr $ renameModule mos mo1b - intermOut opts (iOpt "show_rename") (prMod mo2) - - (mo3:_,warnings) <- putpp " type checking" $ ioeErr $ showCheckModule mos mo2 - if null warnings then return () else putp warnings $ return () - intermOut opts (iOpt "show_typecheck") (prMod mo3) - - - (k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3 - intermOut opts (iOpt "show_refresh") (prMod mo3r) - - let eenv = () --- emptyEEnv - (mo4,eenv') <- - ---- if oElem "check_only" opts - putpp " optimizing " $ ioeErr $ optimizeModule opts (mos,eenv) mo3r - return (k',mo4) - where - ---- prDebug mo = ioeIO $ putStrLn $ prGrammar $ MGrammar [mo] ---- debug - prDebug mo = ioeIO $ print $ length $ lines $ prGrammar $ MGrammar [mo] - -generateModuleCode :: Options -> FilePath -> SourceModule -> IOE SourceModule -generateModuleCode opts file minfo = do - let minfo1 = subexpModule minfo - out = prGrammar (MGrammar [minfo1]) - putp (" wrote file" +++ file) $ ioeIO $ writeFile file $ compactPrint out - return minfo1 - where - putp = putPointE opts - putpp = putPointEsil opts - - --- auxiliaries - -pathListOpts :: Options -> FileName -> IO [InitPath] -pathListOpts opts file = return $ maybe [file] splitInModuleSearchPath $ getOptVal opts pathList - -reverseModules (MGrammar ms) = MGrammar $ reverse ms - -emptyCompileEnv :: CompileEnv -emptyCompileEnv = (0,emptyMGrammar,Map.empty) - -extendCompileEnvInt (_,MGrammar ss,menv) k file sm = do - let (mod,imps) = importsOfModule (trModule sm) - t <- ioeIO $ getModificationTime file - return (k,MGrammar (sm:ss),Map.insert mod (t,imps) menv) --- reverse later - -extendCompileEnv e@(k,_,_) file sm = extendCompileEnvInt e k file sm - - diff --git a/src/GF/Devel/Compile/AbsGF.hs b/src/GF/Devel/Compile/AbsGF.hs deleted file mode 100644 index d053a3fa1..000000000 --- a/src/GF/Devel/Compile/AbsGF.hs +++ /dev/null @@ -1,274 +0,0 @@ -module GF.Devel.Compile.AbsGF where - --- Haskell module generated by the BNF converter - -newtype PIdent = PIdent ((Int,Int),String) deriving (Eq,Ord,Show) -newtype LString = LString String deriving (Eq,Ord,Show) -data Grammar = - Gr [ModDef] - deriving (Eq,Ord,Show) - -data ModDef = - MModule ComplMod ModType ModBody - deriving (Eq,Ord,Show) - -data ModType = - MAbstract PIdent - | MResource PIdent - | MGrammar PIdent - | MInterface PIdent - | MConcrete PIdent PIdent - | MInstance PIdent PIdent - deriving (Eq,Ord,Show) - -data ModBody = - MBody Extend Opens [TopDef] - | MNoBody [Included] - | MWith Included [Open] - | MWithBody Included [Open] Opens [TopDef] - | MWithE [Included] Included [Open] - | MWithEBody [Included] Included [Open] Opens [TopDef] - | MReuse PIdent - | MUnion [Included] - deriving (Eq,Ord,Show) - -data Extend = - Ext [Included] - | NoExt - deriving (Eq,Ord,Show) - -data Opens = - NoOpens - | OpenIn [Open] - deriving (Eq,Ord,Show) - -data Open = - OName PIdent - | OQual PIdent PIdent - deriving (Eq,Ord,Show) - -data ComplMod = - CMCompl - | CMIncompl - deriving (Eq,Ord,Show) - -data Included = - IAll PIdent - | ISome PIdent [PIdent] - | IMinus PIdent [PIdent] - deriving (Eq,Ord,Show) - -data TopDef = - DefCat [CatDef] - | DefFun [FunDef] - | DefFunData [FunDef] - | DefDef [Def] - | DefData [DataDef] - | DefPar [ParDef] - | DefOper [Def] - | DefLincat [Def] - | DefLindef [Def] - | DefLin [Def] - | DefPrintCat [Def] - | DefPrintFun [Def] - | DefFlag [Def] - | DefPrintOld [Def] - | DefLintype [Def] - | DefPattern [Def] - | DefPackage PIdent [TopDef] - | DefVars [Def] - | DefTokenizer PIdent - deriving (Eq,Ord,Show) - -data Def = - DDecl [Name] Exp - | DDef [Name] Exp - | DPatt Name [Patt] Exp - | DFull [Name] Exp Exp - deriving (Eq,Ord,Show) - -data FunDef = - FDecl [Name] Exp - deriving (Eq,Ord,Show) - -data CatDef = - SimpleCatDef PIdent [DDecl] - | ListCatDef PIdent [DDecl] - | ListSizeCatDef PIdent [DDecl] Integer - deriving (Eq,Ord,Show) - -data DataDef = - DataDef Name [DataConstr] - deriving (Eq,Ord,Show) - -data DataConstr = - DataId PIdent - | DataQId PIdent PIdent - deriving (Eq,Ord,Show) - -data ParDef = - ParDefDir PIdent [ParConstr] - | ParDefAbs PIdent - deriving (Eq,Ord,Show) - -data ParConstr = - ParConstr PIdent [DDecl] - deriving (Eq,Ord,Show) - -data Name = - PIdentName PIdent - | ListName PIdent - deriving (Eq,Ord,Show) - -data LocDef = - LDDecl [PIdent] Exp - | LDDef [PIdent] Exp - | LDFull [PIdent] Exp Exp - deriving (Eq,Ord,Show) - -data Exp = - EPIdent PIdent - | EConstr PIdent - | ECons PIdent - | ESort Sort - | EString String - | EInt Integer - | EFloat Double - | EMeta - | EEmpty - | EData - | EList PIdent Exps - | EStrings String - | ERecord [LocDef] - | ETuple [TupleComp] - | EIndir PIdent - | ETyped Exp Exp - | EProj Exp Label - | EQConstr PIdent PIdent - | EQCons PIdent PIdent - | EApp Exp Exp - | ETable [Case] - | ETTable Exp [Case] - | EVTable Exp [Exp] - | ECase Exp [Case] - | EVariants [Exp] - | EPre Exp [Altern] - | EStrs [Exp] - | EPatt Patt - | EPattType Exp - | ESelect Exp Exp - | ETupTyp Exp Exp - | EExtend Exp Exp - | EGlue Exp Exp - | EConcat Exp Exp - | EAbstr [Bind] Exp - | ECTable [Bind] Exp - | EProd Decl Exp - | ETType Exp Exp - | ELet [LocDef] Exp - | ELetb [LocDef] Exp - | EWhere Exp [LocDef] - | EEqs [Equation] - | EExample Exp String - | ELString LString - | ELin PIdent - deriving (Eq,Ord,Show) - -data Exps = - NilExp - | ConsExp Exp Exps - deriving (Eq,Ord,Show) - -data Patt = - PChar - | PChars String - | PMacro PIdent - | PM PIdent PIdent - | PW - | PV PIdent - | PCon PIdent - | PQ PIdent PIdent - | PInt Integer - | PFloat Double - | PStr String - | PR [PattAss] - | PTup [PattTupleComp] - | PC PIdent [Patt] - | PQC PIdent PIdent [Patt] - | PDisj Patt Patt - | PSeq Patt Patt - | PRep Patt - | PAs PIdent Patt - | PNeg Patt - deriving (Eq,Ord,Show) - -data PattAss = - PA [PIdent] Patt - deriving (Eq,Ord,Show) - -data Label = - LPIdent PIdent - | LVar Integer - deriving (Eq,Ord,Show) - -data Sort = - Sort_Type - | Sort_PType - | Sort_Tok - | Sort_Str - | Sort_Strs - deriving (Eq,Ord,Show) - -data Bind = - BPIdent PIdent - | 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 Patt 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 - | FPIdent PIdent - | FSlash FileName - | FDot FileName - | FMinus FileName - | FAddId PIdent FileName - deriving (Eq,Ord,Show) - diff --git a/src/GF/Devel/Compile/CheckGrammar.hs b/src/GF/Devel/Compile/CheckGrammar.hs deleted file mode 100644 index 30ea0a70e..000000000 --- a/src/GF/Devel/Compile/CheckGrammar.hs +++ /dev/null @@ -1,1089 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CheckGrammar --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 23:24:33 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.31 $ --- --- AR 4\/12\/1999 -- 1\/4\/2000 -- 8\/9\/2001 -- 15\/5\/2002 -- 27\/11\/2002 -- 18\/6\/2003 -- 6/12/2007 --- --- 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 --- --- - overloading is resolved ------------------------------------------------------------------------------ - -module GF.Devel.Compile.CheckGrammar ( - showCheckModule, - justCheckLTerm, - allOperDependencies, - topoSortOpers - ) where - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Devel.Grammar.Macros -import GF.Devel.Grammar.PrGF -import GF.Devel.Grammar.Lookup - -import GF.Infra.Ident - ---import GF.Grammar.Refresh ---- - ---import GF.Grammar.TypeCheck ---import GF.Grammar.Values (cPredefAbs) --- - - ---import GF.Grammar.LookAbs ---import GF.Grammar.ReservedWords ---- -import GF.Devel.Grammar.PatternMatch (testOvershadow) -import GF.Devel.Grammar.AppPredefined ---import GF.Grammar.Lockfield (isLockLabel) - -import GF.Devel.CheckM - -import GF.Data.Operations - -import Data.List -import qualified Data.Set as Set -import qualified Data.Map as Map -import Control.Monad -import Debug.Trace --- - - -showCheckModule :: GF -> SourceModule -> Err (SourceModule,String) -showCheckModule mos m = do - (st,(_,msg)) <- checkStart $ checkModule mos m - return (st, unlines $ reverse msg) - -checkModule :: GF -> SourceModule -> Check SourceModule -checkModule gf0 (name,mo) = checkIn ("checking module" +++ prt name) $ do - let gr = gf0 {gfmodules = Map.insert name mo (gfmodules gf0)} - ---- checkRestrictedInheritance gr (name, mo) - mo1 <- case mtype mo of - MTAbstract -> judgementOpModule (checkAbsInfo gr name) mo - MTGrammar -> entryOpModule (checkResInfo gr name) mo - - MTConcrete aname -> do - checkErr $ topoSortOpers $ allOperDependencies name $ mjments mo - abs <- checkErr $ lookupModule gr aname - mo1 <- checkCompleteGrammar abs mo - entryOpModule (checkCncInfo gr name (aname,abs)) mo1 - - MTInterface -> entryOpModule (checkResInfo gr name) mo - - MTInstance iname -> do - intf <- checkErr $ lookupModule gr iname - entryOpModule (checkResInfo gr name) mo - - return $ (name, mo1) - -{- ---- --- check if restricted inheritance modules are still coherent --- i.e. that the defs of remaining names don't depend on omitted names ----checkRestrictedInheritance :: [SourceModule] -> SourceModule -> Check () -checkRestrictedInheritance mos (name,mo) = do - let irs = [ii | ii@(_,mi) <- extend mo, mi /= MIAll] -- names with restr. inh. - let mrs = [((i,m),mi) | (i,ModMod m) <- mos, Just mi <- [lookup i irs]] - -- the restr. modules themself, with restr. infos - mapM_ checkRem mrs - where - checkRem ((i,m),mi) = do - let (incl,excl) = partition (isInherited mi) (map fst (tree2list (jments m))) - let incld c = Set.member c (Set.fromList incl) - let illegal c = Set.member c (Set.fromList excl) - let illegals = [(f,is) | - (f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)] - case illegals of - [] -> return () - cs -> fail $ "In inherited module" +++ prt i ++ - ", dependence of excluded constants:" ++++ - unlines [" " ++ prt f +++ "on" +++ unwords (map prt is) | - (f,is) <- cs] - allDeps = ---- transClosure $ Map.fromList $ - concatMap (allDependencies (const True)) - [jments m | (_,ModMod m) <- mos] - transClosure ds = ds ---- TODO: check in deeper modules --} - - --- | check if a term is typable -justCheckLTerm :: GF -> Term -> Err Term -justCheckLTerm src t = do - ((t',_),_) <- checkStart (inferLType src t) - return t' - -checkAbsInfo :: GF -> Ident -> Judgement -> Check Judgement -checkAbsInfo st m info = return info ---- - -{- -checkAbsInfo st m (c,info) = do ----- checkReservedId c - case info of - AbsCat (Yes cont) _ -> mkCheck "category" $ - checkContext st cont ---- also cstrs - AbsFun (Yes typ0) md -> do - typ <- compAbsTyp [] typ0 -- to calculate let definitions - mkCheck "type of function" $ checkTyp st typ - md' <- case md of - Yes d -> do - let d' = elimTables d - mkCheckWarn "definition of function" $ checkEquation st (m,c) d' - return $ Yes d' - _ -> return md - return $ (c,AbsFun (Yes typ) md') - _ -> return (c,info) - where - mkCheck cat ss = case ss of - [] -> return (c,info) - ["[]"] -> return (c,info) ---- - _ -> checkErr $ prtBad (unlines ss ++++ "in" +++ cat) c - ---- temporary solution when tc of defs is incomplete - mkCheckWarn cat ss = case ss of - [] -> return (c,info) - ["[]"] -> return (c,info) ---- - _ -> checkWarn (unlines ss ++++ "in" +++ cat +++ prt c) >> return (c,info) - compAbsTyp g t = case t of - Vr x -> maybe (fail ("no value given to variable" +++ prt x)) return $ lookup x g - Let (x,(_,a)) b -> do - a' <- compAbsTyp g a - compAbsTyp ((x, a'):g) b - Prod x a b -> do - a' <- compAbsTyp g a - b' <- compAbsTyp ((x,Vr x):g) b - return $ Prod x a' b' - Abs _ _ -> return t - _ -> composOp (compAbsTyp g) t - - elimTables e = case e of - S t a -> elimSel (elimTables t) (elimTables a) - T _ cs -> Eqs [(elimPatt p, elimTables t) | (p,t) <- cs] - _ -> composSafeOp elimTables e - elimPatt p = case p of - PR lps -> map snd lps - _ -> [p] - elimSel t a = case a of - R fs -> mkApp t (map (snd . snd) fs) - _ -> mkApp t [a] --} - - -checkCompleteGrammar :: Module -> Module -> Check Module -checkCompleteGrammar abs cnc = do - let js = mjments cnc - let fs = Map.assocs $ mjments abs - js' <- foldM checkOne js fs - return $ cnc {mjments = js'} - where - checkOne js i@(c, ju) = case jform ju of - JFun -> case Map.lookup c js of - Just j | jform j == JLin -> return js - _ -> do - checkWarn $ "WARNING: no linearization of" +++ prt c - return js - JCat -> case Map.lookup c js of - Just j | jform ju == JLincat -> return js - _ -> do ---- TODO: other things to check here - checkWarn $ - "Warning: no linearization type for" +++ prt c ++ - ", inserting default {s : Str}" - return $ Map.insert c (cncCat defLinType) js - _ -> return js - -checkResInfo :: GF -> Ident -> Ident -> Judgement -> Check Judgement -checkResInfo gr mo c info = do - ---- checkReservedId c - trace (show info) (return ()) - case jform info of - JOper -> chIn "operation" $ case (jtype info, jdef info) of - _ | isConstructor info -> return info - (_,Meta _) -> do - checkWarn "No definition given to oper" - return info - (Meta _,de) -> do - (de',ty') <- infer de - ---- trace ("inferred" +++ prt de' +++ ":" +++ prt ty') $ - return (resOper ty' de') - (ty, de) -> do - ty' <- check ty typeType >>= comp . fst - (de',_) <- check de ty' - return (resOper ty' de') -{- ---- - ResOverload tysts -> chIn "overloading" $ do - tysts' <- mapM (uncurry $ flip check) tysts - let tysts2 = [(y,x) | (x,y) <- tysts'] - --- this can only be a partial guarantee, since matching - --- with value type is only possible if expected type is given - checkUniq $ - sort [t : map snd xs | (x,_) <- tysts2, let (xs,t) = prodForm x] - return (c,ResOverload tysts2) --} -{- ---- - ResParam (Yes (pcs,_)) -> chIn "parameter type" $ do ----- mapM ((mapM (computeLType gr . snd)) . snd) pcs - mapM_ ((mapM_ (checkIfParType gr . snd)) . snd) pcs - ts <- checkErr $ lookupParamValues gr mo c - return (c,ResParam (Yes (pcs, Just ts))) --} - _ -> return info - where - infer = inferLType gr - check = checkLType gr - chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") - comp = computeLType gr - - checkUniq xss = case xss of - x:y:xs - | x == y -> raise $ "ambiguous for argument list" +++ - unwords (map (prtType gr) x) - | otherwise -> checkUniq $ y:xs - _ -> return () - - -checkCncInfo :: GF -> Ident -> SourceModule -> - Ident -> Judgement -> Check Judgement -checkCncInfo gr cnc (a,abs) c info = do - ---- checkReservedId c - case jform info of - JFun -> chIn "linearization of" $ do - typ <- checkErr $ lookupFunType gr a c - cat0 <- checkErr $ valCat typ - (cont,val) <- linTypeOfType gr cnc typ -- creates arg vars - let lintyp = mkFunType (map snd cont) val - (trm',_) <- check (jdef info) lintyp -- erases arg vars - checkPrintname gr (jprintname info) - cat <- return $ snd cat0 - return (info {jdef = trm'}) - ---- return (c, CncFun (Just (cat,(cont,val))) (Yes trm') mpr) - -- cat for cf, typ for pe - - JCat -> chIn "linearization type of" $ do - checkErr $ lookupCatContext gr a c - typ' <- checkIfLinType gr (jtype info) - {- ---- - mdef' <- case mdef of - Yes def -> do - (def',_) <- checkLType gr def (mkFunType [typeStr] typ) - return $ Yes def' - _ -> return mdef - -} - checkPrintname gr (jprintname info) - return (info {jtype = typ'}) - - _ -> checkResInfo gr cnc c info - - where - env = gr - infer = inferLType gr - comp = computeLType gr - check = checkLType gr - chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") - - -checkIfParType :: GF -> 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 :: GF -> Type -> Check Type -checkIfLinType st typ0 = do - typ <- computeLType st typ0 - case typ of - RecType r -> return () - _ -> prtFail "a linearization type must be a record type instead of" typ - return typ - -computeLType :: GF -> 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 - - App (Q (IC "Predef") (IC "Ints")) _ -> return ty ---- shouldn't be needed - Q (IC "Predef") (IC "Int") -> return ty ---- shouldn't be needed - Q (IC "Predef") (IC "Float") -> return ty ---- shouldn't be needed - Q (IC "Predef") (IC "Error") -> return ty ---- shouldn't be needed - - Q m c | elem c [cPredef,cPredefAbs] -> return ty - Q m c | elem c [identC "Int"] -> - return $ defLinType ----- let ints k = App (Q (IC "Predef") (IC "Ints")) (EInt k) in ----- RecType [ ----- (LIdent "last",ints 9),(LIdent "s", typeStr), (LIdent "size",ints 1)] - Q m c | elem c [identC "Float",identC "String"] -> return defLinType ---- - - Q m ident -> checkIn ("module" +++ prt m) $ do - ty' <- checkErr (lookupOperDef 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) -> checkErr (plusRecType r' s') >>= comp - _ -> return $ ExtR r' s' - - RecType fs -> do - let fs' = sortBy (\x y -> compare (fst x) (fst y)) fs - liftM RecType $ mapPairsM comp fs' - - _ | ty == typeTok -> return typeStr ---- deprecated - _ | isPredefConstant ty -> return ty - - _ -> composOp comp ty - -checkPrintname :: GF -> 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 () --} - --- to normalize records and record types -labelIndex :: Type -> Label -> Int -labelIndex ty lab = case ty of - RecType ts -> maybe (error ("label index"+++ prt lab)) id $ lookup lab $ labs ts - _ -> error $ "label index" +++ prt ty - where - labs ts = zip (map fst (sortBy (\ x y -> compare (fst x) (fst y)) ts)) [0..] - --- the underlying algorithms - -inferLType :: GF -> Term -> Check (Term, Type) -inferLType gr trm = case trm of - - Q m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident) - - Q m ident -> checks [ - termWith trm $ checkErr (lookupOperType gr m ident) >>= comp - , - checkErr (lookupOperDef gr m ident) >>= infer - , -{- - do - over <- getOverload gr Nothing trm - case over of - Just trty -> return trty - _ -> prtFail "not overloaded" trm - , --} - prtFail "cannot infer type of constant" trm - ] - - QC m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident) - - QC m ident -> checks [ - termWith trm $ checkErr (lookupOperType gr m ident) >>= comp --- ,checkErr (lookupOperDef gr m ident) >>= infer --- ,prtFail "cannot infer type of canonical constant" trm - ] - - Val ty i -> termWith trm $ return ty - - Vr ident -> termWith trm $ checkLookup ident - - Typed e t -> do - t' <- comp t - check e t' - return (e,t') - - App f a -> do - over <- getOverload gr Nothing trm - case over of - Just trty -> return trty - _ -> 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) - _ -> raise ("function type expected for"+++ - prt f +++"instead of" +++ prtType env 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 ------ let tr2 = PI t' i (labelIndex ty' i) - let tr2 = P t' i - termWith tr2 $ checkErr $ case ty' of - RecType ts -> maybeErr ("unknown label" +++ prt i +++ "in" +++ prt ty') $ - lookup i ts - _ -> prtBad ("record type expected for" +++ prt t +++ "instead of") ty' - PI t i _ -> infer $ P t i - - 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] - case pts' of - [] -> prtFail "cannot infer table type of" trm ----- PInt k : _ -> return $ Ints $ max [i | PInt i <- pts'] - _ -> do - (arg,val) <- checks $ map (inferCase Nothing) pts' - check trm (Table arg val) - V arg pts -> do - (_,val) <- checks $ map infer pts - return (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, typeStr) - - EInt i -> return (trm, typeInt) - - EFloat i -> return (trm, typeFloat) - - Empty -> return (trm, typeStr) - - EParam _ cos -> return (trm, typePType) ---- check cos - - C s1 s2 -> - check2 (flip justCheck typeStr) C s1 s2 typeStr - - Glue s1 s2 -> - check2 (flip justCheck typeStr) Glue s1 s2 typeStr - ----- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007 ----- Strs (Cn (IC "#conflict") : ts) -> do ----- trace ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) (infer $ head ts) --- checkWarn ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) --- infer $ head ts - - - Alts (t,aa) -> do - t' <- justCheck t typeStr - aa' <- flip mapM aa (\ (c,v) -> do - c' <- justCheck c typeStr - v' <- justCheck v typeStr - 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' - ---- trm' <- checkErr $ plusRecord r' s' - case (rT', sT') of - (RecType rs, RecType ss) -> do - rt <- checkErr $ plusRecType rT' sT' - check trm' rt ---- return (trm', rt) - _ | 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 - - EPattType ty -> do - ty' <- justCheck ty typeType - return (ty',typeType) - EPatt p -> do - ty <- inferPatt p - return (trm, EPattType ty) - _ -> prtFail "cannot infer lintype of" trm - - where - env = gr - infer = inferLType env - comp = computeLType env - - check = checkLType env - - isPredef m = elem m [cPredef,cPredefAbs] - - 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 - PString _ -> True - PInt _ -> True - PFloat _ -> True - PSeq p q -> isConstPatt p || isConstPatt q - PAlt p q -> isConstPatt p || isConstPatt q - PRep p -> isConstPatt p - PNeg p -> isConstPatt p - PAs _ p -> isConstPatt p - PChar -> True - PChars _ -> True - _ -> False - - inferPatt p = case p of - PP q c ps | q /= cPredef -> - checkErr $ lookupOperType gr q c >>= return . snd . prodForm - PAs _ p -> inferPatt p - PNeg p -> inferPatt p - PAlt p q -> checks [inferPatt p, inferPatt q] - PSeq _ _ -> return $ typeStr - PRep _ -> return $ typeStr - PChar -> return $ typeStr - PChars _ -> return $ typeStr - _ -> infer (patt2term p) >>= return . snd - - --- type inference: Nothing, type checking: Just t --- the latter permits matching with value type -getOverload :: GF -> Maybe Type -> Term -> Check (Maybe (Term,Type)) -getOverload env@gr mt t = case appForm t of - (f@(Q m c), ts) -> case lookupOverload gr m c of - Ok typs -> do - ttys <- mapM infer ts - v <- matchOverload f typs ttys - return $ Just v - _ -> return Nothing - _ -> return Nothing - where - infer = inferLType env - matchOverload f typs ttys = do - let (tts,tys) = unzip ttys - let vfs = lookupOverloadInstance tys typs - - case [vf | vf@(v,f) <- vfs, matchVal mt v] of - [(val,fun)] -> return (mkApp fun tts, val) - [] -> raise $ "no overload instance of" +++ prt f +++ - "for" +++ unwords (map (prtType env) tys) +++ "among" ++++ - unlines [" " ++ unwords (map (prtType env) ty) | (ty,_) <- typs] ++ - maybe [] (("with value type" +++) . prtType env) mt - - ---- ++++ "DEBUG" +++ unwords (map show tys) +++ ";" - ---- ++++ unlines (map (show . fst) typs) ---- - - vfs' -> case [(v,f) | (v,f) <- vfs', noProd v] of - [(val,fun)] -> do - checkWarn $ "WARNING: overloading of" +++ prt f +++ - "resolved by excluding partial applications:" ++++ - unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)] - return (mkApp fun tts, val) - - _ -> raise $ "ambiguous overloading of" +++ prt f +++ - "for" +++ unwords (map (prtType env) tys) ++++ "with alternatives" ++++ - unlines [prtType env ty | (ty,_) <- vfs'] - - matchVal mt v = elem mt ([Nothing,Just v] ++ unlocked) where - unlocked = case v of - RecType fs -> [Just $ RecType $ fs] ---- filter (not . isLockLabel . fst) fs] - _ -> [] - ---- TODO: accept subtypes - ---- TODO: use a trie - lookupOverloadInstance tys typs = - [(mkFunType rest val, t) | - let lt = length tys, - (ty,(val,t)) <- typs, length ty >= lt, - let (pre,rest) = splitAt lt ty, - pre == tys - ] - - noProd ty = case ty of - Prod _ _ _ -> False - _ -> True - -checkLType :: GF -> Term -> Type -> Check (Term, Type) -checkLType env trm typ0 = do - trace (show trm) (return ()) - - 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') - _ -> raise $ "product expected instead of" +++ prtType env typ - - App f a -> do - over <- getOverload env (Just typ) trm - case over of - Just trty -> return trty - _ -> do - (trm',ty') <- infer trm - termWith trm' $ checkEq typ ty' trm' - - Q _ _ -> do - over <- getOverload env (Just typ) trm - case over of - Just trty -> return trty - _ -> do - (trm',ty') <- infer trm - termWith trm' $ checkEq typ ty' trm' - - EData -> return (trm,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 <- return [] ---- 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) - _ -> raise $ "table type expected for table instead of" +++ prtType env 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 - ExtR (Vr _) (RecType _) -> termWith trm $ return typeType - -- ext t = t ** ... - _ -> prtFail "invalid record type extension" trm - RecType rr -> do - (r',ty,s') <- checks [ - do (r',ty) <- infer r - return (r',ty,s) - , - do (s',ty) <- infer s - return (s',ty,r) - ] - case ty of - RecType rr1 -> do - let (rr0,rr2) = recParts rr rr1 - r2 <- justCheck r' rr0 - s2 <- justCheck s' rr2 - return $ (ExtR r2 s2, typ) - _ -> raise ("record type expected in extension of" +++ prt r +++ - "but found" +++ prt ty) - - ExtR ty ex -> do - r' <- justCheck r ty - s' <- justCheck s ex - return $ (ExtR r' s', typ) --- is this all? - - _ -> 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 -> checks [ 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) - _ -> raise $ "table type expected for applied table instead of" +++ - prtType env ty' - , do - (arg',ty) <- infer arg - ty' <- comp ty - (tab',_) <- check tab (Table ty' typ) - return (S tab' arg', typ) - ] - 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 - - recParts rr t = (RecType rr1,RecType rr2) where - (rr1,rr2) = partition (flip elem (map fst t) . fst) rr - - 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 | not (isWildIdent x) -> return [(x,typ)] - PP q c ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006 - t <- checkErr $ lookupOperType cnc q c - let (cont,v) = prodForm 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]] - ----- checkWarn $ prt p ++++ show pts ----- debug - 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' - - PAs x p -> do - g <- pattContext env typ p - return $ (x,typ):g - - PAlt p' q -> do - g1 <- pattContext env typ p' - g2 <- pattContext env typ q - let pts = [pt | pt <- g1, notElem pt g2] ++ [pt | pt <- g2, notElem pt g1] - checkCond - ("incompatible bindings of" +++ - unwords (nub (map (prt . fst) pts))+++ - "in pattern alterantives" +++ prt p) (null pts) - return g1 -- must be g1 == g2 - PSeq p q -> do - g1 <- pattContext env typ p - g2 <- pattContext env typ q - return $ g1 ++ g2 - PRep p' -> noBind typeStr p' - PNeg p' -> noBind typ p' - - _ -> return [] ---- check types! - where - cnc = env - noBind typ p' = do - co <- pattContext env typ p' - if not (null co) - then checkWarn ("no variable bound inside pattern" +++ prt p) - >> return [] - else return [] - --- auxiliaries - -type LTEnv = GF - -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 - (b,t',u',s) <- checkIfEqLType env t u trm - case b of - True -> return t' - False -> raise $ s +++ "type of" +++ prt trm +++ - ": expected:" +++ prtType env t ++++ - "inferred:" +++ prtType env u - -checkIfEqLType :: LTEnv -> Type -> Type -> Term -> Check (Bool,Type,Type,String) -checkIfEqLType env t u trm = do - t' <- comp t - u' <- comp u - case t' == u' || alpha [] t' u' of - True -> return (True,t',u',[]) - -- forgive missing lock fields by only generating a warning. - --- better: use a flag to forgive? (AR 31/1/2006) - _ -> case missingLock [] t' u' of - Ok lo -> do - checkWarn $ "WARNING: missing lock field" +++ unwords (map prt lo) - return (True,t',u',[]) - Bad s -> return (False,t',u',s) - - where - - -- t is a subtype of u - --- quick hack version of TC.eqVal - alpha g t u = case (t,u) of - - -- error (the empty type!) is subtype of any other type - (_,Q (IC "Predef") (IC "Error")) -> True - - -- unknown type unifies with any type ---- - (_,Meta _) -> True - - -- contravariance - (Prod x a b, Prod y c d) -> alpha g c a && alpha ((x,y):g) b d - - -- record subtyping - (RecType rs, RecType ts) -> all (\ (l,a) -> - any (\ (k,b) -> alpha g a b && l == k) ts) rs - (ExtR r s, ExtR r' s') -> alpha g r r' && alpha g s s' - (ExtR r s, t) -> alpha g r t || alpha g s t - - -- the following say that Ints n is a subset of Int and of Ints m >= n - (App (Q (IC "Predef") (IC "Ints")) (EInt n), - App (Q (IC "Predef") (IC "Ints")) (EInt m)) -> m >= n - (App (Q (IC "Predef") (IC "Ints")) (EInt n), - Q (IC "Predef") (IC "Int")) -> True ---- check size! - - (Q (IC "Predef") (IC "Int"), ---- why this ???? AR 11/12/2005 - App (Q (IC "Predef") (IC "Ints")) (EInt n)) -> True - - ---- this should be made in Rename - (Q m a, Q n b) | a == b -> elem m (allExtendsPlus env n) - || elem n (allExtendsPlus env m) - || m == n --- for Predef - (QC m a, QC n b) | a == b -> elem m (allExtendsPlus env n) - || elem n (allExtendsPlus env m) - (QC m a, Q n b) | a == b -> elem m (allExtendsPlus env n) - || elem n (allExtendsPlus env m) - (Q m a, QC n b) | a == b -> elem m (allExtendsPlus env n) - || elem n (allExtendsPlus env m) - - (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) - - missingLock g t u = case (t,u) of - (RecType rs, RecType ts) -> - let - ls = [l | (l,a) <- rs, - not (any (\ (k,b) -> alpha g a b && l == k) ts)] - (locks,others) = partition (const False) ls ---- isLockLabel ls - in case others of - _:_ -> Bad $ "missing record fields" +++ unwords (map prt others) - _ -> return locks - -- contravariance - (Prod x a b, Prod y c d) -> do - ls1 <- missingLock g c a - ls2 <- missingLock g b d - return $ ls1 ++ ls2 - - _ -> Bad "" - - ---- to revise - allExtendsPlus _ n = [n] - - sTypes = [typeStr, typeString, typeTok] ---- Tok deprecated - comp = computeLType env - --- printing a type with a lock field lock_C as C -prtType :: LTEnv -> Type -> String -prtType env ty = case ty of - RecType fs -> ---- case filter isLockLabel $ map fst fs of - ---- [lock] -> (drop 5 $ prt lock) --- ++++ "Full form" +++ prt ty - ---- _ -> - prtt ty - Prod x a b -> prtType env a +++ "->" +++ prtType env b - _ -> prtt ty - where - prtt t = prt t - ---- use computeLType gr to check if really equal to the cat with lock - - --- | linearization types and defaults -linTypeOfType :: GF -> 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 - ] - --- | dependency check, detecting circularities and returning topo-sorted list - -allOperDependencies :: Ident -> Map.Map Ident Judgement -> [(Ident,[Ident])] -allOperDependencies m = allDependencies (==m) - -allDependencies :: (Ident -> Bool) -> Map.Map Ident Judgement -> [(Ident,[Ident])] -allDependencies ism b = - [(f, nub (concatMap opersIn (pts i))) | (f,i) <- Map.assocs b] - where - opersIn t = case t of - Q n c | ism n -> [c] - QC n c | ism n -> [c] - _ -> collectOp opersIn t - pts i = [jtype i, jdef i] - ---- AbsFun pty ptr -> [pty] --- ptr is def, which can be mutual - -topoSortOpers :: [(Ident,[Ident])] -> Err [Ident] -topoSortOpers st = do - let eops = topoTest st - either - return - (\ops -> Bad ("circular definitions:" +++ unwords (map prt (head ops)))) - eops diff --git a/src/GF/Devel/Compile/Compile.hs b/src/GF/Devel/Compile/Compile.hs deleted file mode 100644 index 07e059ed4..000000000 --- a/src/GF/Devel/Compile/Compile.hs +++ /dev/null @@ -1,205 +0,0 @@ -module GF.Devel.Compile.Compile (batchCompile) where - --- the main compiler passes -import GF.Devel.Compile.GetGrammar -import GF.Devel.Compile.Extend -import GF.Devel.Compile.Rename -import GF.Devel.Compile.CheckGrammar -import GF.Devel.Compile.Refresh -import GF.Devel.Compile.Optimize -import GF.Devel.Compile.Factorize - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Infra.Ident -import GF.Devel.Grammar.PrGF -----import GF.Devel.Grammar.Lookup -import GF.Devel.Infra.ReadFiles - -import GF.Infra.Option ---- -import GF.Data.Operations -import GF.Devel.UseIO -import GF.Devel.Arch - -import Control.Monad -import System.Directory - -batchCompile :: Options -> [FilePath] -> IO GF -batchCompile opts files = do - let defOpts = addOptions opts (options [emitCode]) - egr <- appIOE $ foldM (compileModule defOpts) emptyCompileEnv files - case egr of - Ok (_,gr) -> return gr - Bad s -> error s - --- to output an intermediate stage -intermOut :: Options -> Option -> String -> IOE () -intermOut opts opt s = - if oElem opt opts || oElem (iOpt "show_all") opts - then - ioeIO (putStrLn ("\n\n--#" +++ prOpt opt) >> putStrLn s) - else - return () - -prMod :: SourceModule -> String -prMod = prModule - --- | the environment -type CompileEnv = (Int,GF) - --- | compile with one module as starting point --- command-line options override options (marked by --#) in the file --- As for path: if it is read from file, the file path is prepended to each name. --- If from command line, it is used as it is. - -compileModule :: Options -> CompileEnv -> FilePath -> IOE CompileEnv -compileModule opts1 env file = do - opts0 <- ioeIO $ getOptionsFromFile file - let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList - let useLineOpt = maybe False (const True) $ getOptVal opts1 pathList - let opts = addOptions opts1 opts0 - let fpath = dropFileName file - ps0 <- ioeIO $ pathListOpts opts fpath - - let ps1 = if (useFileOpt && not useLineOpt) - then (ps0 ++ map (combine fpath) ps0) - else ps0 - ps <- ioeIO $ extendPathEnv ps1 - let ioeIOIf = if oElem beVerbose opts then ioeIO else (const (return ())) - ioeIOIf $ putStrLn $ "module search path:" +++ show ps ---- - let sgr = snd env - let rfs = [] ---- files already in memory and their read times - let file' = if useFileOpt then takeFileName file else file -- find file itself - files <- getAllFiles opts ps rfs file' - ioeIOIf $ putStrLn $ "files to read:" +++ show files ---- - let names = map justModuleName files - ioeIOIf $ putStrLn $ "modules to include:" +++ show names ---- - let sgr2 = sgr ----MGrammar [m | m@(i,_) <- modules sgr, - ---- notElem (prt i) $ map dropExtension names] - let env0 = (0,sgr2) - (e,mm) <- foldIOE (compileOne opts) env0 files - maybe (return ()) putStrLnE mm - return e - - -compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv -compileOne opts env@(_,srcgr) file = do - - let putp s = putPointE opts ("\n" ++ s) - let putpp = putPointEsil opts - let putpOpt v m act - | oElem beVerbose opts = putp v act - | oElem beSilent opts = putpp v act - | otherwise = ioeIO (putStrFlush ("\n" ++ m)) >> act - - let gf = takeExtensions file - let path = dropFileName file - let name = dropExtension file - let mos = gfmodules srcgr - - case gf of - - -- for compiled gf, read the file and update environment - -- also undo common subexp optimization, to enable normal computations - - ".gfn" -> do - sm0 <- putp ("+ reading" +++ file) $ getSourceModule opts file - let sm1 = unsubexpModule sm0 - sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule srcgr sm1 - extendCompileEnv env sm - - -- for gf source, do full compilation and generate code - _ -> do - - let modu = dropExtension file - b1 <- ioeIO $ doesFileExist file - if not b1 - then compileOne opts env $ gfoFile $ modu - else do - - sm0 <- - putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ - getSourceModule opts file - (k',sm) <- compileSourceModule opts env sm0 - let sm1 = sm ---- ----- if isConcr sm then shareModule sm else sm -- cannot expand Str - if oElem (iOpt "doemit") opts - then putpp " generating code... " $ generateModuleCode opts path sm1 - else return () ----- -- sm is optimized before generation, but not in the env ----- let cm2 = unsubexpModule cm - extendCompileEnvInt env (k',sm) ---- sm1 - where - isConcr (_,mi) = case mi of ----- ModMod m -> isModCnc m && mstatus m /= MSIncomplete - _ -> False - - - -compileSourceModule :: Options -> CompileEnv -> - SourceModule -> IOE (Int,SourceModule) -compileSourceModule opts env@(k,gr) mo@(i,mi) = do - - intermOut opts (iOpt "show_gf") (prMod mo) - - let putp = putPointE opts - putpp = putPointEsil opts - stopIf n comp m = - if any (\k -> oElem (iOpt (show k)) opts) [1..n] then return m else comp m - stopIfV v n comp m = - if any (\k -> oElem (iOpt (show k)) opts) [1..n] then return (m,v) else comp m - - moe <- stopIf 1 (putpp " extending" . ioeErr . extendModule gr) mo - intermOut opts (iOpt "show_extend") (prMod moe) - - mor <- stopIf 2 (putpp " renaming" . ioeErr . renameModule gr) moe - intermOut opts (iOpt "show_rename") (prMod mor) - - (moc,warnings) <- - stopIfV [] 3 (putpp " type checking" . ioeErr . showCheckModule gr) mor - if null warnings then return () else putp warnings $ return () - intermOut opts (iOpt "show_typecheck") (prMod moc) - - (mox,k') <- stopIfV k 4 (putpp " refreshing " . ioeErr . refreshModule k) moc - intermOut opts (iOpt "show_refresh") (prMod mox) - - moo <- stopIf 5 (putpp " optimizing " . ioeErr . optimizeModule opts gr) mox - intermOut opts (iOpt "show_optimize") (prMod moo) - - mof <- stopIf 6 (putpp " factorizing " . ioeErr . optimizeModule opts gr) moo - intermOut opts (iOpt "show_factorize") (prMod mof) - - return (k',moo) ---- - - -generateModuleCode :: Options -> InitPath -> SourceModule -> IOE () -generateModuleCode opts path minfo@(name,info) = do - - let pname = combine path (prt name) - let minfo0 = minfo - let minfo1 = subexpModule minfo0 - let minfo2 = minfo1 - - let (file,out) = (gfoFile pname, prGF (gfModules [minfo2])) - putp (" wrote file" +++ file) $ ioeIO $ writeFile file $ out - - return () ----- minfo2 - where - putp = putPointE opts - putpp = putPointEsil opts - --- auxiliaries - -pathListOpts :: Options -> FileName -> IO [InitPath] -pathListOpts opts file = return $ maybe [file] splitInModuleSearchPath $ getOptVal opts pathList - -----reverseModules (MGrammar ms) = MGrammar $ reverse ms - -emptyCompileEnv :: CompileEnv -emptyCompileEnv = (0,emptyGF) - -extendCompileEnvInt (_,gf) (k,(s,m)) = return (k, addModule s m gf) - -extendCompileEnv e@(k,_) sm = extendCompileEnvInt e (k,sm) - - diff --git a/src/GF/Devel/Compile/ErrM.hs b/src/GF/Devel/Compile/ErrM.hs deleted file mode 100644 index 9cad4e252..000000000 --- a/src/GF/Devel/Compile/ErrM.hs +++ /dev/null @@ -1,26 +0,0 @@ --- BNF Converter: Error Monad --- Copyright (C) 2004 Author: Aarne Ranta - --- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE. -module GF.Devel.Compile.ErrM where - --- the Error monad: like Maybe type with error msgs - -import Control.Monad (MonadPlus(..), liftM) - -data Err a = Ok a | Bad String - deriving (Read, Show, Eq, Ord) - -instance Monad Err where - return = Ok - fail = Bad - Ok a >>= f = f a - Bad s >>= f = Bad s - -instance Functor Err where - fmap = liftM - -instance MonadPlus Err where - mzero = Bad "Err.mzero" - mplus (Bad _) y = y - mplus x _ = x diff --git a/src/GF/Devel/Compile/Extend.hs b/src/GF/Devel/Compile/Extend.hs deleted file mode 100644 index 2f1aae65b..000000000 --- a/src/GF/Devel/Compile/Extend.hs +++ /dev/null @@ -1,154 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Extend --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/30 21:08:14 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.18 $ --- --- AR 14\/5\/2003 -- 11\/11 --- 4/12/2007 this module is still very very messy... ---- --- --- The top-level function 'extendModule' --- extends a module symbol table by indirections to the module it extends ------------------------------------------------------------------------------ - -module GF.Devel.Compile.Extend ( - extendModule - ) where - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Devel.Grammar.PrGF -import GF.Devel.Grammar.Lookup -import GF.Devel.Grammar.Macros - -import GF.Infra.Ident - -import GF.Data.Operations - -import Data.List (nub) -import Data.Map -import Control.Monad - -extendModule :: GF -> SourceModule -> Err SourceModule -extendModule gf nmo0 = do - (name,mo) <- rebuildModule gf nmo0 - case mtype mo of - - ---- Just to allow inheritance in incomplete concrete (which are not - ---- compiled anyway), extensions are not built for them. - ---- Should be replaced by real control. AR 4/2/2005 - MTConcrete _ | not (isCompleteModule mo) -> return (name,mo) - _ -> do - mo' <- foldM (extOne name) mo (mextends mo) - return (name, mo') - where - extOne name mo (n,cond) = do - mo0 <- lookupModule gf n - - -- test that the module types match - testErr True ---- (legalExtension mo mo0) - ("illegal extension type to module" +++ prt name) - - -- find out if the old is complete - let isCompl = isCompleteModule mo0 - - -- if incomplete, remove it from extension list --- because?? - let me' = (if isCompl then id else (Prelude.filter ((/=n) . fst))) - (mextends mo) - - -- build extension depending on whether the old module is complete - js0 <- extendMod isCompl n (isInherited cond) name (mjments mo0) (mjments mo) - - return $ mo {mextends = me', mjments = js0} - --- | When extending a complete module: new information is inserted, --- and the process is interrupted if unification fails. --- If the extended module is incomplete, its judgements are just copied. -extendMod :: Bool -> Ident -> (Ident -> Bool) -> Ident -> - Map Ident Judgement -> Map Ident Judgement -> - Err (Map Ident Judgement) -extendMod isCompl name cond base old new = foldM try new $ assocs old where - try t i@(c,_) | not (cond c) = return t - try t i@(c,_) = errIn ("constant" +++ prt c) $ - tryInsert (extendAnyInfo isCompl name base) indirIf t i - indirIf = if isCompl then indirInfo name else id - -indirInfo :: Ident -> Judgement -> Judgement -indirInfo n ju = case jform ju of - JLink -> ju -- original link is passed - _ -> linkInherited (isConstructor ju) n - -extendAnyInfo :: Bool -> Ident -> Ident -> Judgement -> Judgement -> Err Judgement -extendAnyInfo isc n o i j = - errIn ("building extension for" +++ prt n +++ "in" +++ prt o) $ - unifyJudgement i j - -tryInsert :: Ord a => (b -> b -> Err b) -> (b -> b) -> - Map a b -> (a,b) -> Err (Map a b) -tryInsert unif indir tree z@(x, info) = case Data.Map.lookup x tree of - Just info0 -> do - info1 <- unif info info0 - return $ insert x info1 tree - _ -> return $ insert x (indir info) tree - --- | rebuilding instance + interface, and "with" modules, prior to renaming. --- AR 24/10/2003 -rebuildModule :: GF -> SourceModule -> Err SourceModule -rebuildModule gr mo@(i,mi) = case mtype mi of - - -- copy interface contents to instance - MTInstance i0 -> do - m0 <- lookupModule gr i0 - testErr (isInterface m0) ("not an interface:" +++ prt i0) - js1 <- extendMod False i0 (const True) i (mjments m0) (mjments mi) - - --- to avoid double inclusions, in instance J of I0 = J0 ** ... - case mextends mi of - [] -> return $ (i,mi {mjments = js1}) - es -> do - mes <- mapM (lookupModule gr . fst) es ---- restricted?? 12/2007 - let notInExts c _ = all (notMember c . mjments) mes - let js2 = filterWithKey notInExts js1 - return $ (i,mi { - mjments = js2 - }) - - -- copy functor contents to instantiation, and also add opens - _ -> case minstances mi of - [((ext,incl),ops)] -> do - let interfs = Prelude.map fst ops - - -- test that all interfaces are instantiated - let isCompl = Prelude.null [i | (_,i) <- minterfaces mi, notElem i interfs] - testErr isCompl ("module" +++ prt i +++ "remains incomplete") - - -- look up the functor and build new opens set - mi0 <- lookupModule gr ext - let - ops1 = nub $ - mopens mi -- own opens; N.B. mi0 has been name-resolved already - ++ ops -- instantiating opens - ++ [(n,o) | - (n,o) <- mopens mi0, notElem o interfs] -- ftor's non-if opens - ++ [(i,i) | i <- Prelude.map snd ops] ---- -- insts w. real names - - -- combine flags; new flags have priority - let fs1 = union (mflags mi) (mflags mi0) - - -- copy inherited functor judgements - let js0 = [ci | ci@(c,_) <- assocs (mjments mi0), isInherited incl c] - let js1 = fromList (assocs (mjments mi) ++ js0) - - return $ (i,mi { - mflags = fs1, - mextends = mextends mi, -- extends of instantiation - mopens = ops1, - mjments = js1 - }) - _ -> return (i,mi) - diff --git a/src/GF/Devel/Compile/Factorize.hs b/src/GF/Devel/Compile/Factorize.hs deleted file mode 100644 index 7386f3ed5..000000000 --- a/src/GF/Devel/Compile/Factorize.hs +++ /dev/null @@ -1,251 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : OptimizeGF --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:21:33 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- Optimizations on GF source code: sharing, parametrization, value sets. --- --- optimization: sharing branches in tables. AR 25\/4\/2003. --- following advice of Josef Svenningsson ------------------------------------------------------------------------------ - -module GF.Devel.Compile.Factorize ( - optModule, - unshareModule, - unsubexpModule, - unoptModule, - subexpModule, - shareModule - ) where - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Devel.Grammar.PrGF (prt) -import qualified GF.Devel.Grammar.Macros as C - -import GF.Devel.Grammar.Lookup -import GF.Infra.Ident - -import GF.Data.Operations - -import Control.Monad -import Data.Map (Map) -import qualified Data.Map as Map -import Data.List - -optModule :: SourceModule -> SourceModule -optModule = subexpModule . shareModule - -shareModule = processModule optim - -unoptModule :: GF -> SourceModule -> SourceModule -unoptModule gr = unshareModule gr . unsubexpModule - -unshareModule :: GF -> SourceModule -> SourceModule -unshareModule gr = processModule (const (unoptim gr)) - -processModule :: (Ident -> Term -> Term) -> SourceModule -> SourceModule -processModule opt (i,mo) = - (i, mo {mjments = Map.map (shareInfo (opt i)) (mjments mo)}) - -shareInfo :: (Term -> Term) -> Judgement -> Judgement -shareInfo opt ju = ju {jdef = opt (jdef ju)} - --- the function putting together optimizations -optim :: Ident -> Term -> Term -optim c = values . factor c 0 - --- we need no counter to create new variable names, since variables are --- local to tables ---- --- factor parametric branches - -factor :: Ident -> Int -> Term -> Term -factor c i t = case t of - T _ [_] -> t - T _ [] -> t - T (TComp ty) cs -> - T (TTyped ty) $ factors i [(p, factor c (i+1) v) | (p, v) <- cs] - _ -> C.composSafeOp (factor c i) t - where - - factors i psvs = -- we know psvs has at least 2 elements - let p = qqIdent c i - vs' = map (mkFun p) psvs - in if allEqs vs' - then mkCase p vs' - else psvs - - mkFun p (patt, val) = replace (C.patt2term patt) (Vr p) val - - allEqs (v:vs) = all (==v) vs - - mkCase p (v:_) = [(PV p, v)] - ---- we hope this will be fresh and don't check... - -qqIdent c i = identC ("_q_" ++ prt c ++ "__" ++ show i) - - --- we need to replace subterms - -replace :: Term -> Term -> Term -> Term -replace old new trm = case trm of - - -- these are the important cases, since they can correspond to patterns - QC _ _ | trm == old -> new - App t ts | trm == old -> new - App t ts -> App (repl t) (repl ts) - R _ | isRec && trm == old -> new - _ -> C.composSafeOp repl trm - where - repl = replace old new - isRec = case trm of - R _ -> True - _ -> False - --- It is very important that this is performed only after case --- expansion since otherwise the order and number of values can --- be incorrect. Guaranteed by the TComp flag. - -values :: Term -> Term -values t = case t of - T ty [(ps,t)] -> T ty [(ps,values t)] -- don't destroy parametrization - T (TComp ty) cs -> V ty [values t | (_, t) <- cs] - T (TTyped ty) cs -> V ty [values t | (_, t) <- cs] - ---- why are these left? - ---- printing with GrammarToSource does not preserve the distinction - _ -> C.composSafeOp values t - - --- to undo the effect of factorization - -unoptim :: GF -> Term -> Term -unoptim gr = unfactor gr - -unfactor :: GF -> Term -> Term -unfactor gr t = case t of - T (TTyped ty) [(PV x,u)] -> V ty [restore x v (unfac u) | v <- vals ty] - _ -> C.composSafeOp unfac t - where - unfac = unfactor gr - vals = err error id . allParamValues gr - restore x u t = case t of - Vr y | y == x -> u - _ -> C.composSafeOp (restore x u) t - - ----------------------------------------------------------------------- - -{- -This module implements a simple common subexpression elimination - for gfc grammars, to factor out shared subterms in lin rules. -It works in three phases: - - (1) collectSubterms collects recursively all subterms of forms table and (P x..y) - from lin definitions (experience shows that only these forms - tend to get shared) and counts how many times they occur - (2) addSubexpConsts takes those subterms t that occur more than once - and creates definitions of form "oper A''n = t" where n is a - fresh number; notice that we assume no ids of this form are in - scope otherwise - (3) elimSubtermsMod goes through lins and the created opers by replacing largest - possible subterms by the newly created identifiers - -The optimization is invoked in gf by the flag i -subs. - -If an application does not support GFC opers, the effect of this -optimization can be undone by the function unSubelimCanon. - -The function unSubelimCanon can be used to diagnostisize how much -cse is possible in the grammar. It is used by the flag pg -printer=subs. - --} - -subexpModule :: SourceModule -> SourceModule -subexpModule (m,mo) = errVal (m,mo) $ case mtype mo of - MTAbstract -> return (m,mo) - _ -> do - let js = listJudgements mo - (tree,_) <- appSTM (getSubtermsMod m js) (Map.empty,0) - js2 <- addSubexpConsts m tree js - return (m, mo{mjments = Map.fromList js2}) - -unsubexpModule :: SourceModule -> SourceModule -unsubexpModule (m,mo) = (m, mo{mjments = rebuild (mjments mo)}) - where - unparInfo (c, ju) = case jtype ju of - EInt 8 -> [] -- subexp-generated opers - _ -> [(c, ju {jdef = unparTerm (jdef ju)})] - unparTerm t = case t of - Q _ c@(IC ('_':'A':_)) -> --- name convention of subexp opers - maybe t (unparTerm . jdef) $ Map.lookup c (mjments mo) - _ -> C.composSafeOp unparTerm t - rebuild = Map.fromList . concat . map unparInfo . Map.assocs - --- implementation - -type TermList = Map Term (Int,Int) -- number of occs, id -type TermM a = STM (TermList,Int) a - -addSubexpConsts :: - Ident -> Map Term (Int,Int) -> [(Ident,Judgement)] -> Err [(Ident,Judgement)] -addSubexpConsts mo tree lins = do - let opers = [oper id trm | (trm,(_,id)) <- list] - mapM mkOne $ opers ++ lins - where - - mkOne (f, def) = return (f, def {jdef = recomp f (jdef def)}) - recomp f t = case Map.lookup t tree of - Just (_,id) | ident id /= f -> Q mo (ident id) - _ -> C.composSafeOp (recomp f) t - - list = Map.toList tree - - oper id trm = (ident id, resOper (EInt 8) trm) - --- impossible type encoding generated opers - -getSubtermsMod :: Ident -> [(Ident,Judgement)] -> TermM (Map Term (Int,Int)) -getSubtermsMod mo js = do - mapM (getInfo (collectSubterms mo)) js - (tree0,_) <- readSTM - return $ Map.filter (\ (nu,_) -> nu > 1) tree0 - where - getInfo get fi@(_,i) = do - get (jdef i) - return $ fi - -collectSubterms :: Ident -> Term -> TermM Term -collectSubterms mo t = case t of - App f a -> do - collect f - collect a - add t - T ty cs -> do - let (_,ts) = unzip cs - mapM collect ts - add t - V ty ts -> do - mapM collect ts - add t ----- K (KP _ _) -> add t - _ -> C.composOp (collectSubterms mo) t - where - collect = collectSubterms mo - add t = do - (ts,i) <- readSTM - let - ((count,id),next) = case Map.lookup t ts of - Just (nu,id) -> ((nu+1,id), i) - _ -> ((1, i ), i+1) - writeSTM (Map.insert t (count,id) ts, next) - return t --- only because of composOp - -ident :: Int -> Ident -ident i = identC ("_A" ++ show i) --- - diff --git a/src/GF/Devel/Compile/GF.cf b/src/GF/Devel/Compile/GF.cf deleted file mode 100644 index 3edbdf347..000000000 --- a/src/GF/Devel/Compile/GF.cf +++ /dev/null @@ -1,326 +0,0 @@ --- AR 2/5/2003, 14-16 o'clock, Torino - --- 17/6/2007: marked with suffix --% those lines that are obsolete and --- should not be included in documentation - -entrypoints Grammar, ModDef, - OldGrammar, --% - Exp ; -- let's see if more are needed - -comment "--" ; -comment "{-" "-}" ; - - --- identifiers - -position token PIdent ('_' | letter) (letter | digit | '_' | '\'')* ; - --- the top-level grammar - -Gr. Grammar ::= [ModDef] ; - --- semicolon after module is permitted but not obligatory - -terminator ModDef "" ; -_. ModDef ::= ModDef ";" ; - --- the individual modules - -MModule. ModDef ::= ComplMod ModType "=" ModBody ; - -MAbstract. ModType ::= "abstract" PIdent ; -MResource. ModType ::= "resource" PIdent ; -MGrammar. ModType ::= "grammar" PIdent ; -MInterface. ModType ::= "interface" PIdent ; -MConcrete. ModType ::= "concrete" PIdent "of" PIdent ; -MInstance. ModType ::= "instance" PIdent "of" PIdent ; - -MBody. ModBody ::= Extend Opens "{" [TopDef] "}" ; -MNoBody. ModBody ::= [Included] ; -MWith. ModBody ::= Included "with" [Open] ; -MWithBody. ModBody ::= Included "with" [Open] "**" Opens "{" [TopDef] "}" ; -MWithE. ModBody ::= [Included] "**" Included "with" [Open] ; -MWithEBody. ModBody ::= [Included] "**" Included "with" [Open] "**" Opens "{" [TopDef] "}" ; - -MReuse. ModBody ::= "reuse" PIdent ; --% -MUnion. ModBody ::= "union" [Included] ;--% - -separator TopDef "" ; - -Ext. Extend ::= [Included] "**" ; -NoExt. Extend ::= ; - -separator Open "," ; -NoOpens. Opens ::= ; -OpenIn. Opens ::= "open" [Open] "in" ; - -OName. Open ::= PIdent ; --- OQualQO. Open ::= "(" PIdent ")" ; --% -OQual. Open ::= "(" PIdent "=" PIdent ")" ; - -CMCompl. ComplMod ::= ; -CMIncompl. ComplMod ::= "incomplete" ; - -separator Included "," ; - -IAll. Included ::= PIdent ; -ISome. Included ::= PIdent "[" [PIdent] "]" ; -IMinus. Included ::= PIdent "-" "[" [PIdent] "]" ; - --- top-level definitions - -DefCat. TopDef ::= "cat" [CatDef] ; -DefFun. TopDef ::= "fun" [FunDef] ; -DefFunData.TopDef ::= "data" [FunDef] ; -DefDef. TopDef ::= "def" [Def] ; -DefData. TopDef ::= "data" [DataDef] ; - -DefPar. TopDef ::= "param" [ParDef] ; -DefOper. TopDef ::= "oper" [Def] ; - -DefLincat. TopDef ::= "lincat" [Def] ; -DefLindef. TopDef ::= "lindef" [Def] ; -DefLin. TopDef ::= "lin" [Def] ; - -DefPrintCat. TopDef ::= "printname" "cat" [Def] ; -DefPrintFun. TopDef ::= "printname" "fun" [Def] ; -DefFlag. TopDef ::= "flags" [Def] ; - --- definitions after most keywords - -DDecl. Def ::= [Name] ":" Exp ; -DDef. Def ::= [Name] "=" Exp ; -DPatt. Def ::= Name [Patt] "=" Exp ; -- non-empty pattern list -DFull. Def ::= [Name] ":" Exp "=" Exp ; - -FDecl. FunDef ::= [Name] ":" Exp ; - -SimpleCatDef. CatDef ::= PIdent [DDecl] ; -ListCatDef. CatDef ::= "[" PIdent [DDecl] "]" ; -ListSizeCatDef. CatDef ::= "[" PIdent [DDecl] "]" "{" Integer "}" ; - -DataDef. DataDef ::= Name "=" [DataConstr] ; -DataId. DataConstr ::= PIdent ; -DataQId. DataConstr ::= PIdent "." PIdent ; -separator DataConstr "|" ; - -ParDefDir. ParDef ::= PIdent "=" [ParConstr] ; -ParDefAbs. ParDef ::= PIdent ; - -ParConstr. ParConstr ::= PIdent [DDecl] ; - -terminator nonempty Def ";" ; -terminator nonempty FunDef ";" ; -terminator nonempty CatDef ";" ; -terminator nonempty DataDef ";" ; -terminator nonempty ParDef ";" ; - -separator ParConstr "|" ; - -separator nonempty PIdent "," ; - --- names of categories and functions in definition LHS - -PIdentName. Name ::= PIdent ; -ListName. Name ::= "[" PIdent "]" ; - -separator nonempty Name "," ; - --- definitions in records and $let$ expressions - -LDDecl. LocDef ::= [PIdent] ":" Exp ; -LDDef. LocDef ::= [PIdent] "=" Exp ; -LDFull. LocDef ::= [PIdent] ":" Exp "=" Exp ; - -separator LocDef ";" ; - --- terms and types - -EPIdent. Exp6 ::= PIdent ; -EConstr. Exp6 ::= "{" PIdent "}" ;--% -ECons. Exp6 ::= "%" PIdent "%" ;--% -ESort. Exp6 ::= Sort ; -EString. Exp6 ::= String ; -EInt. Exp6 ::= Integer ; -EFloat. Exp6 ::= Double ; -EMeta. Exp6 ::= "?" ; -EEmpty. Exp6 ::= "[" "]" ; -EData. Exp6 ::= "data" ; -EList. Exp6 ::= "[" PIdent Exps "]" ; -EStrings. Exp6 ::= "[" String "]" ; -ERecord. Exp6 ::= "{" [LocDef] "}" ; -- ! -ETuple. Exp6 ::= "<" [TupleComp] ">" ; --- needed for separator "," -EIndir. Exp6 ::= "(" "in" PIdent ")" ; -- indirection, used in judgements --% -ETyped. Exp6 ::= "<" Exp ":" Exp ">" ; -- typing, used for annotations - -EProj. Exp5 ::= Exp5 "." Label ; -EQConstr. Exp5 ::= "{" PIdent "." PIdent "}" ; -- qualified constructor --% -EQCons. Exp5 ::= "%" PIdent "." PIdent ; -- qualified constant --% - -EApp. Exp4 ::= Exp4 Exp5 ; -ETable. Exp4 ::= "table" "{" [Case] "}" ; -ETTable. Exp4 ::= "table" Exp6 "{" [Case] "}" ; -EVTable. Exp4 ::= "table" Exp6 "[" [Exp] "]" ; -ECase. Exp4 ::= "case" Exp "of" "{" [Case] "}" ; -EVariants. Exp4 ::= "variants" "{" [Exp] "}" ; -EPre. Exp4 ::= "pre" "{" Exp ";" [Altern] "}" ; -EStrs. Exp4 ::= "strs" "{" [Exp] "}" ; --% - -EPatt. Exp4 ::= "pattern" Patt2 ; -EPattType. Exp4 ::= "pattern" "type" Exp5 ; - -ESelect. Exp3 ::= Exp3 "!" Exp4 ; -ETupTyp. Exp3 ::= Exp3 "*" Exp4 ; -EExtend. Exp3 ::= Exp3 "**" Exp4 ; - -EGlue. Exp1 ::= Exp2 "+" Exp1 ; - -EConcat. Exp ::= Exp1 "++" Exp ; - -EAbstr. Exp ::= "\\" [Bind] "->" Exp ; -ECTable. Exp ::= "\\""\\" [Bind] "=>" Exp ; -EProd. Exp ::= Decl "->" Exp ; -ETType. Exp ::= Exp3 "=>" Exp ; -- these are thus right associative -ELet. Exp ::= "let" "{" [LocDef] "}" "in" Exp ; -ELetb. Exp ::= "let" [LocDef] "in" Exp ; -EWhere. Exp ::= Exp3 "where" "{" [LocDef] "}" ; -EEqs. Exp ::= "fn" "{" [Equation] "}" ; --% - -EExample. Exp ::= "in" Exp5 String ; - -coercions Exp 6 ; - -separator Exp ";" ; -- in variants - --- list of arguments to category -NilExp. Exps ::= ; -ConsExp. Exps ::= Exp6 Exps ; -- Exp6 to force parantheses - --- patterns - -PChar. Patt2 ::= "?" ; -PChars. Patt2 ::= "[" String "]" ; -PMacro. Patt2 ::= "#" PIdent ; -PM. Patt2 ::= "#" PIdent "." PIdent ; -PW. Patt2 ::= "_" ; -PV. Patt2 ::= PIdent ; -PCon. Patt2 ::= "{" PIdent "}" ; --% -PQ. Patt2 ::= PIdent "." PIdent ; -PInt. Patt2 ::= Integer ; -PFloat. Patt2 ::= Double ; -PStr. Patt2 ::= String ; -PR. Patt2 ::= "{" [PattAss] "}" ; -PTup. Patt2 ::= "<" [PattTupleComp] ">" ; -PC. Patt1 ::= PIdent [Patt] ; -PQC. Patt1 ::= PIdent "." PIdent [Patt] ; -PDisj. Patt ::= Patt "|" Patt1 ; -PSeq. Patt ::= Patt "+" Patt1 ; -PRep. Patt1 ::= Patt2 "*" ; -PAs. Patt1 ::= PIdent "@" Patt2 ; -PNeg. Patt1 ::= "-" Patt2 ; - -coercions Patt 2 ; - -PA. PattAss ::= [PIdent] "=" Patt ; - --- labels - -LPIdent. Label ::= PIdent ; -LVar. Label ::= "$" Integer ; - --- basic types - -rules Sort ::= - "Type" - | "PType" - | "Tok" --% - | "Str" - | "Strs" ; - -separator PattAss ";" ; - --- this is explicit to force higher precedence level on rhs -(:[]). [Patt] ::= Patt2 ; -(:). [Patt] ::= Patt2 [Patt] ; - - --- binds in lambdas and lin rules - -BPIdent. Bind ::= PIdent ; -BWild. Bind ::= "_" ; - -separator Bind "," ; - - --- declarations in function types - -DDec. Decl ::= "(" [Bind] ":" Exp ")" ; -DExp. Decl ::= Exp4 ; -- can thus be an application - --- tuple component (term or pattern) - -TComp. TupleComp ::= Exp ; -PTComp. PattTupleComp ::= Patt ; - -separator TupleComp "," ; -separator PattTupleComp "," ; - --- case branches - -Case. Case ::= Patt "=>" Exp ; - -separator nonempty Case ";" ; - --- cases in abstract syntax --% - -Equ. Equation ::= [Patt] "->" Exp ; --% - -separator Equation ";" ; --% - --- prefix alternatives - -Alt. Altern ::= Exp "/" Exp ; - -separator Altern ";" ; - --- in a context, higher precedence is required than in function types - -DDDec. DDecl ::= "(" [Bind] ":" Exp ")" ; -DDExp. DDecl ::= Exp6 ; -- can thus *not* be an application - -separator DDecl "" ; - - --------------------------------------- --% - --- for backward compatibility --% - -OldGr. OldGrammar ::= Include [TopDef] ; --% - -NoIncl. Include ::= ; --% -Incl. Include ::= "include" [FileName] ; --% - -FString. FileName ::= String ; --% - -terminator nonempty FileName ";" ; --% - -FPIdent. FileName ::= PIdent ; --% -FSlash. FileName ::= "/" FileName ; --% -FDot. FileName ::= "." FileName ; --% -FMinus. FileName ::= "-" FileName ; --% -FAddId. FileName ::= PIdent FileName ; --% - -token LString '\'' (char - '\'')* '\'' ; --% -ELString. Exp6 ::= LString ; --% -ELin. Exp4 ::= "Lin" PIdent ; --% - -DefPrintOld. TopDef ::= "printname" [Def] ; --% -DefLintype. TopDef ::= "lintype" [Def] ; --% -DefPattern. TopDef ::= "pattern" [Def] ; --% - --- deprecated packages are attempted to be interpreted --% -DefPackage. TopDef ::= "package" PIdent "=" "{" [TopDef] "}" ";" ; --% - --- these two are just ignored after parsing --% -DefVars. TopDef ::= "var" [Def] ; --% -DefTokenizer. TopDef ::= "tokenizer" PIdent ";" ; --% diff --git a/src/GF/Devel/Compile/GFC.hs b/src/GF/Devel/Compile/GFC.hs deleted file mode 100644 index f60ec9380..000000000 --- a/src/GF/Devel/Compile/GFC.hs +++ /dev/null @@ -1,72 +0,0 @@ -module GF.Devel.Compile.GFC (mainGFC) where --- module Main where - -import GF.Devel.Compile.Compile -import GF.Devel.Compile.GFtoGFCC -import GF.Devel.PrintGFCC -import GF.GFCC.OptimizeGFCC -import GF.GFCC.CheckGFCC -import GF.GFCC.DataGFCC -import GF.GFCC.Raw.ParGFCCRaw -import GF.GFCC.Raw.ConvertGFCC -import GF.Devel.UseIO -import GF.Infra.Option -import GF.GFCC.API -import GF.Data.ErrM - -mainGFC :: [String] -> IO () -mainGFC xx = do - let (opts,fs) = getOptions "-" xx - case opts of - _ | oElem (iOpt "help") opts -> putStrLn usageMsg - _ | oElem (iOpt "-make") opts -> do - gr <- batchCompile opts fs - let name = justModuleName (last fs) - let (abs,gc0) = mkCanon2gfcc opts name gr - gc1 <- checkGFCCio gc0 - let gc = if oElem (iOpt "noopt") opts then gc1 else optGFCC gc1 - let target = targetName opts abs - let gfccFile = target ++ ".gfcc" - writeFile gfccFile (printGFCC gc) - putStrLn $ "wrote file " ++ gfccFile - mapM_ (alsoPrint opts target gc) printOptions - - -- gfc -o target.gfcc source_1.gfcc ... source_n.gfcc - _ | all ((==".gfcc") . takeExtensions) fs -> do - gfccs <- mapM file2gfcc fs - let gfcc = foldl1 unionGFCC gfccs - let abs = printCId $ absname gfcc - let target = targetName opts abs - let gfccFile = target ++ ".gfcc" - writeFile gfccFile (printGFCC gfcc) - putStrLn $ "wrote file " ++ gfccFile - mapM_ (alsoPrint opts target gfcc) printOptions - - _ -> do - mapM_ (batchCompile opts) (map return fs) - putStrLn "Done." - -targetName opts abs = case getOptVal opts (aOpt "target") of - Just n -> n - _ -> abs - ----- TODO: nicer and richer print options - -alsoPrint opts abs gr (opt,name) = do - if oElem (iOpt opt) opts - then do - let outfile = name - let output = prGFCC opt gr - writeFile outfile output - putStrLn $ "wrote file " ++ outfile - else return () - -printOptions = [ - ("haskell","GSyntax.hs"), - ("haskell_gadt","GSyntax.hs"), - ("js","grammar.js"), - ("jsref","grammarReference.js") - ] - -usageMsg = - "usage: gfc (-h | --make (-noopt) (-target=PREFIX) (-js | -jsref | -haskell | -haskell_gadt)) (-src) FILES" diff --git a/src/GF/Devel/Compile/GFtoGFCC.hs b/src/GF/Devel/Compile/GFtoGFCC.hs deleted file mode 100644 index 81f33e11a..000000000 --- a/src/GF/Devel/Compile/GFtoGFCC.hs +++ /dev/null @@ -1,542 +0,0 @@ -module GF.Devel.Compile.GFtoGFCC (prGrammar2gfcc,mkCanon2gfcc) where - -import GF.Devel.Compile.Factorize (unshareModule) - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import qualified GF.Devel.Grammar.Lookup as Look - -import qualified GF.Devel.Grammar.Grammar as A ---- -import qualified GF.Devel.Grammar.Grammar as M ---- -import qualified GF.Devel.Grammar.Macros as GM ---import qualified GF.Grammar.Compute as Compute - -import GF.Devel.Grammar.PrGF ---import GF.Devel.ModDeps -import GF.Infra.Ident - -import GF.Devel.PrintGFCC -import qualified GF.GFCC.Macros as CM -import qualified GF.GFCC.DataGFCC as C -import qualified GF.GFCC.DataGFCC as D -import GF.GFCC.CId -import GF.Infra.Option ---- -import GF.Data.Operations -import GF.Text.UTF8 - -import Data.List -import Data.Char (isDigit,isSpace) -import qualified Data.Map as Map -import Debug.Trace ---- - --- the main function: generate GFCC from GF. - -prGrammar2gfcc :: Options -> String -> GF -> (String,String) -prGrammar2gfcc opts cnc gr = (abs, printGFCC gc) where - (abs,gc) = mkCanon2gfcc opts cnc gr - -mkCanon2gfcc :: Options -> String -> GF -> (String,D.GFCC) -mkCanon2gfcc opts cnc gr = - (prIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon abs) gr) - where - abs = err error id $ Look.abstractOfConcrete gr (identC cnc) - pars = mkParamLincat gr - --- Generate GFCC from GFCM. --- this assumes a grammar translated by canon2canon - -canon2gfcc :: Options -> (Ident -> Ident -> C.Term) -> GF -> D.GFCC -canon2gfcc opts pars cgr = - (if (oElem (iOpt "show_canon") opts) then trace (prt cgr) else id) $ - D.GFCC an cns gflags abs cncs - where - -- recognize abstract and concretes - ([(a,abm)],cms) = - partition ((== MTAbstract) . mtype . snd) (Map.toList (gfmodules cgr)) - - -- abstract - an = (i2i a) - cns = map (i2i . fst) cms - abs = D.Abstr aflags funs cats catfuns - gflags = Map.fromList [(CId fg,x) | Just x <- [getOptVal opts (aOpt fg)]] - where fg = "firstlang" - aflags = Map.fromList [(CId f,x) | (IC f,x) <- Map.toList (M.mflags abm)] - mkDef pty = case pty of - Meta _ -> CM.primNotion - t -> mkExp t - - funs = Map.fromAscList lfuns - cats = Map.fromAscList lcats - - lfuns = [(i2i f, (mkType (jtype ju), mkDef (jdef ju))) | - (f,ju) <- listJudgements abm, jform ju == JFun] - lcats = [(i2i c, mkContext (GM.contextOfType (jtype ju))) | - (c,ju) <- listJudgements abm, jform ju == JCat] - catfuns = Map.fromList - [(cat,[f | (f, (C.DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats] - - -- concretes - cncs = Map.fromList [mkConcr lang (i2i lang) mo | (lang,mo) <- cms] - mkConcr lang0 lang mo = - (lang,D.Concr flags lins opers lincats lindefs printnames params fcfg) - where - js = listJudgements mo - flags = Map.fromList [(CId f,x) | (IC f,x) <- Map.toList (M.mflags mo)] - opers = Map.fromAscList [] -- opers will be created as optimization - utf = if elem (IC "coding","utf8") (Map.assocs (M.mflags mo)) ---- - then D.convertStringsInTerm decodeUTF8 else id - lins = Map.fromAscList - [(i2i f, utf (mkTerm (jdef ju))) | (f,ju) <- js, jform ju == JLin] - lincats = Map.fromAscList - [(i2i c, utf (mkTerm (jtype ju))) | (c,ju) <- js, jform ju == JLincat] - lindefs = Map.fromAscList - [(i2i c, utf (mkTerm (jdef ju))) | (c,ju) <- js, jform ju == JLincat] - printnames = Map.fromAscList - [(i2i c, utf (mkTerm (jprintname ju))) | - (c,ju) <- js, elem (jform ju) [JLincat,JLin]] - params = Map.fromAscList - [(i2i c, pars lang0 c) | (c,ju) <- js, jform ju == JLincat] ---- c ?? - fcfg = Nothing - -i2i :: Ident -> CId -i2i = CId . prIdent - -mkType :: A.Type -> C.Type -mkType t = case GM.typeForm t of - (hyps,(Q _ cat),args) -> C.DTyp (mkContext hyps) (i2i cat) (map mkExp args) - -mkExp :: A.Term -> C.Exp -mkExp t = case t of - A.Eqs eqs -> C.EEq [C.Equ (map mkPatt ps) (mkExp e) | (ps,e) <- eqs] - _ -> case GM.termForm t of - (xx,c,args) -> C.DTr [i2i x | x <- xx] (mkAt c) (map mkExp args) - where - mkAt c = case c of - Q _ c -> C.AC $ i2i c - QC _ c -> C.AC $ i2i c - Vr x -> C.AV $ i2i x - EInt i -> C.AI i - EFloat f -> C.AF f - K s -> C.AS s - Meta i -> C.AM $ toInteger i - _ -> C.AM 0 - mkPatt p = uncurry CM.tree $ case p of - A.PP _ c ps -> (C.AC (i2i c), map mkPatt ps) - A.PV x -> (C.AV (i2i x), []) - A.PW -> (C.AV CM.wildCId, []) - A.PInt i -> (C.AI i, []) - -mkContext :: A.Context -> [C.Hypo] -mkContext hyps = [C.Hyp (i2i x) (mkType ty) | (x,ty) <- hyps] - -mkTerm :: Term -> C.Term -mkTerm tr = case tr of - Vr (IA (_,i)) -> C.V i - Vr (IC s) | isDigit (last s) -> - C.V (read (reverse (takeWhile (/='_') (reverse s)))) - ---- from gf parser of gfc - EInt i -> C.C $ fromInteger i - R rs -> C.R [mkTerm t | (_, (_,t)) <- rs] - P t l -> C.P (mkTerm t) (C.C (mkLab l)) - T _ cs -> C.R [mkTerm t | (_,t) <- cs] ------ - V _ cs -> C.R [mkTerm t | t <- cs] - S t p -> C.P (mkTerm t) (mkTerm p) - C s t -> C.S $ concatMap flats [mkTerm x | x <- [s,t]] - FV ts -> C.FV [mkTerm t | t <- ts] - K s -> C.K (C.KS s) ------ K (KP ss _) -> C.K (C.KP ss []) ---- TODO: prefix variants - Empty -> C.S [] - App _ _ -> prtTrace tr $ C.C 66661 ---- for debugging - Abs _ t -> mkTerm t ---- only on toplevel - Alts (td,tvs) -> - C.K (C.KP (strings td) [C.Var (strings u) (strings v) | (u,v) <- tvs]) - _ -> prtTrace tr $ C.S [C.K (C.KS (prt tr +++ "66662"))] ---- for debugging - where - mkLab (LIdent l) = case l of - '_':ds -> (read ds) :: Int - _ -> prtTrace tr $ 66663 - strings t = case t of - K s -> [s] - C u v -> strings u ++ strings v - FV ss -> concatMap strings ss - _ -> prtTrace tr $ ["66660"] - flats t = case t of - C.S ts -> concatMap flats ts - _ -> [t] - --- encoding GFCC-internal lincats as terms -mkCType :: Type -> C.Term -mkCType t = case t of - EInt i -> C.C $ fromInteger i - RecType rs -> C.R [mkCType t | (_, t) <- rs] - Table pt vt -> case pt of - EInt i -> C.R $ replicate (1 + fromInteger i) $ mkCType vt - RecType rs -> mkCType $ foldr Table vt (map snd rs) - Sort "Str" -> C.S [] --- Str only - App (Q (IC "Predef") (IC "Ints")) (EInt i) -> C.C $ fromInteger i - _ -> error $ "mkCType " ++ show t - --- encoding showable lincats (as in source gf) as terms -mkParamLincat :: GF -> Ident -> Ident -> C.Term -mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do - typ <- Look.lookupLincat sgr lang cat - mkPType typ - where - mkPType typ = case typ of - RecType lts -> do - ts <- mapM (mkPType . snd) lts - return $ C.R [ C.P (kks $ prt_ l) t | ((l,_),t) <- zip lts ts] - Table (RecType lts) v -> do - ps <- mapM (mkPType . snd) lts - v' <- mkPType v - return $ foldr (\p v -> C.S [p,v]) v' ps - Table p v -> do - p' <- mkPType p - v' <- mkPType v - return $ C.S [p',v'] - Sort "Str" -> return $ C.S [] - _ -> return $ - C.FV $ map (kks . filter showable . prt_) $ - errVal [] $ Look.allParamValues sgr typ - showable c = not (isSpace c) ---- || (c == ' ') -- to eliminate \n in records - kks = C.K . C.KS - --- return just one module per language - -reorder :: Ident -> GF -> GF -reorder abs cg = emptyGF { - gfabsname = Just abs, - gfcncnames = (map fst cncs), - gfmodules = Map.fromList ((abs,absm) : map mkCnc cncs) - } - where - absm = emptyModule { - mtype = MTAbstract, - mflags = aflags, - mjments = adefs - } - mkCnc (c,cnc) = (c,emptyModule { - mtype = MTConcrete abs, - mflags = fst cnc, - mjments = snd cnc - }) - - mos = Map.toList $ gfmodules cg - - adefs = Map.fromAscList $ sortIds $ - predefADefs ++ Look.allOrigJudgements cg abs - predefADefs = - [(IC c, absCat []) | c <- ["Float","Int","String"]] - aflags = Map.fromList $ nubByFst $ concat - [Map.toList (M.mflags mo) | (_,mo) <- mos, mtype mo == MTAbstract] ----toom - - cncs = sortIds [(lang, concr lang) | lang <- Look.allConcretes cg abs] - concr la = ( - Map.fromList (nubByFst flags), - Map.fromList (sortIds (predefCDefs ++ jments)) - ) where - jments = Look.allOrigJudgements cg la - flags = Look.lookupFlags cg la - ----concat [M.mflags mo | - ---- (i,mo) <- mos, M.isModCnc mo, - ---- Just r <- [lookup i (M.allExtendSpecs cg la)]] - - predefCDefs = [(IC c, cncCat GM.defLinType) | - ---- lindef,printname - c <- ["Float","Int","String"]] - - sortIds = sortBy (\ (f,_) (g,_) -> compare f g) - -nubByFst = nubBy (\ (f,_) (g,_) -> f == g) - - --- one grammar per language - needed for symtab generation -repartition :: Ident -> GF -> [GF] -repartition abs cg = [Look.partOfGrammar cg (lang,mo) | - let mos = gfmodules cg, - lang <- Look.allConcretes cg abs, - let mo = errVal - (error ("no module found for " ++ prt lang)) $ Look.lookupModule cg lang - ] - - --- translate tables and records to arrays, parameters and labels to indices - -canon2canon :: Ident -> GF -> GF -canon2canon abs gf = errVal gf $ GM.termOpGF t2t gf where - t2t = return . term2term gf pv - ty2ty = type2type gf pv - pv@(labels,untyps,typs) = paramValues gf - ---- should be done lang for lang - ---- ty2ty should be used for types, t2t only in concrete - -{- ---- - gfModules . nubModules . map cl2cl . repartition abs . purgeGrammar abs - where - nubModules = Map.fromList . nubByFst . concatMap (Map.toList . gfmodules) - - cl2cl gf = errVal gf $ GM.moduleOpGF (js2js . map (GM.judgementOpModule p2p)) gf - - js2js ms = map (GM.judgementOpModule (j2j (gfModules ms))) ms - - j2j cg (f,j) = case jform j of - JLin -> (f, j{jdef = t2t (jdef j)}) - JLincat -> (f, j{jdef = t2t (jdef j), jtype = ty2ty (jtype j)}) - _ -> (f,j) - where - t2t = term2term cg pv - ty2ty = type2type cg pv - pv@(labels,untyps,typs) = paramValues cg ---trs $ paramValues cg - - -- flatten record arguments of param constructors - p2p (f,j) = case jform j of - ---- JParam -> - ----ResParam (Yes (ps,v)) -> - ----(f,ResParam (Yes ([(c,concatMap unRec cont) | (c,cont) <- ps],Nothing))) - _ -> (f,j) - unRec (x,ty) = case ty of - RecType fs -> [ity | (_,typ) <- fs, ity <- unRec (identW,typ)] - _ -> [(x,ty)] - ----- - trs v = trace (tr v) v - - tr (labels,untyps,typs) = - ("labels:" ++++ - unlines [prt c ++ "." ++ unwords (map prt l) +++ "=" +++ show i | - ((c,l),i) <- Map.toList labels]) ++ - ("untyps:" ++++ unlines [prt t +++ "=" +++ show i | - (t,i) <- Map.toList untyps]) ++ - ("typs:" ++++ unlines [prt t | - (t,_) <- Map.toList typs]) ----- --} - -purgeGrammar :: Ident -> GF -> GF -purgeGrammar abstr gr = gr { - gfmodules = treat gr - } - where - treat = - Map.fromList . map unopt . filter complete . purge . Map.toList . gfmodules - purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst) - needed = - nub $ concatMap (Look.allDepsModule gr) $ - ---- (requiredCanModules True gr) $ - [mo | m <- abstr : Look.allConcretes gr abstr, - Ok mo <- [Look.lookupModule gr m]] - - complete (i,mo) = isCompleteModule mo - unopt = unshareModule gr -- subexp elim undone when compiled - -type ParamEnv = - (Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels - Map.Map Term Integer, -- untyped terms to values - Map.Map Type (Map.Map Term Integer)) -- types to their terms to values - ---- gathers those param types that are actually used in lincats and lin terms -paramValues :: GF -> ParamEnv -paramValues cgr = (labels,untyps,typs) where - - jments = [(m,j) | - (m,mo) <- Map.toList (gfmodules cgr), - j <- Map.toList (mjments mo)] - - partyps = nub $ [ty | - (_,(_,ju)) <- jments, - jform ju == JLincat, - RecType ls <- [jtype ju], - ty0 <- [ty | (_, ty) <- unlockTyp ls], - ty <- typsFrom ty0 - ] ++ [Q m ty | - (m,(ty,ju)) <- jments, - jform ju == JParam - ] ++ [ty | - (_,(_,ju)) <- jments, - jform ju == JLin, - ty <- err (const []) snd $ appSTM (typsFromTrm (jdef ju)) [] - ] - params = [(ty, errVal [] $ Look.allParamValues cgr ty) | ty <- partyps] - typsFrom ty = case ty of - Table p t -> typsFrom p ++ typsFrom t - RecType ls -> RecType (sort (unlockTyp ls)) : concat [typsFrom t | (_, t) <- ls] - _ -> [ty] - - typsFromTrm :: Term -> STM [Type] Term - typsFromTrm tr = case tr of - R fs -> mapM_ (typsFromField . snd) fs >> return tr - where - typsFromField (mty, t) = case mty of - Just x -> updateSTM (x:) >> typsFromTrm t - _ -> typsFromTrm t - V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr - T (TTyped ty) cs -> - updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr - T (TComp ty) cs -> - updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr - _ -> GM.composOp typsFromTrm tr - - typs = - Map.fromList [(ci,Map.fromList (zip vs [0..])) | (ci,vs) <- params] - untyps = - Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs] - lincats = - [(IC cat,[(LIdent "s",typeStr)]) | cat <- ["Int", "Float", "String"]] ++ - reverse ---- TODO: really those lincats that are reached - ---- reverse is enough to expel overshadowed ones... - [(cat,(unlockTyp ls)) | - (_,(cat,ju)) <- jments, - jform ju == JLincat, - RecType ls <- [jtype ju] - ] - labels = Map.fromList $ concat - [((cat,[lab]),(typ,i)): - [((cat,[lab,lab2]),(ty,j)) | - rs <- getRec typ, ((lab2, ty),j) <- zip rs [0..]] - | - (cat,ls) <- lincats, ((lab, typ),i) <- zip ls [0..]] - -- go to tables recursively - ---- TODO: even go to deeper records - where - getRec typ = case typ of - RecType rs -> [rs] - Table _ t -> getRec t - _ -> [] - -type2type :: GF -> ParamEnv -> Type -> Type -type2type cgr env@(labels,untyps,typs) ty = case ty of - RecType rs -> - RecType [(mkLab i, t2t t) | (i,(l, t)) <- zip [0..] (unlockTyp rs)] - Table pt vt -> Table (t2t pt) (t2t vt) - QC _ _ -> look ty - _ -> ty - where - t2t = type2type cgr env - look ty = EInt $ (+ (-1)) $ toInteger $ case Map.lookup ty typs of - Just vs -> length $ Map.assocs vs - _ -> trace ("unknown partype " ++ show ty) 66669 - -term2term :: GF -> ParamEnv -> Term -> Term -term2term cgr env@(labels,untyps,typs) tr = case tr of - App _ _ -> mkValCase (unrec tr) - QC _ _ -> mkValCase tr - R rs -> R [(mkLab i, (Nothing, t2t t)) | - (i,(l,(_,t))) <- zip [0..] (sort (unlock rs))] - P t l -> r2r tr - PI t l i -> EInt $ toInteger i - T (TComp ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc - T (TTyped ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc - V ty ts -> mkCurry $ V ty [t2t t | t <- ts] - S t p -> mkCurrySel (t2t t) (t2t p) - _ -> GM.composSafeOp t2t tr - where - t2t = term2term cgr env - - unrec t = case t of - App f (R fs) -> GM.mkApp (unrec f) [unrec u | (_,(_,u)) <- fs] - _ -> GM.composSafeOp unrec t - - mkValCase tr = case appSTM (doVar tr) [] of - Ok (tr', st@(_:_)) -> t2t $ comp $ foldr mkCase tr' st - _ -> valNum $ comp tr - - --- this is mainly needed for parameter record projections - ---- was: errVal t $ Compute.computeConcreteRec cgr t - comp t = case t of - T (TComp typ) ts -> comp $ V typ (map (comp . snd) ts) ---- should... - T (TTyped typ) ts -> comp $ V typ (map (comp . snd) ts) ---- should - V typ ts -> V typ (map comp ts) - S (V typ ts) v0 -> err error id $ do - let v = comp v0 - return $ maybe t (comp . (ts !!) . fromInteger) $ Map.lookup v untyps - R r -> R [(l,(ty,comp t)) | (l,(ty,t)) <- r] - P (R r) l -> maybe t (comp . snd) $ lookup l r - _ -> GM.composSafeOp comp t - - doVar :: Term -> STM [((Type,[Term]),(Term,Term))] Term - doVar tr = case getLab tr of - Ok (cat, lab) -> do - k <- readSTM >>= return . length - let tr' = Vr $ identC $ show k ----- - - let tyvs = case Map.lookup (cat,lab) labels of - Just (ty,_) -> case Map.lookup ty typs of - Just vs -> (ty,[t | - (t,_) <- sortBy (\x y -> compare (snd x) (snd y)) - (Map.assocs vs)]) - _ -> error $ prt ty - _ -> error $ prt tr - updateSTM ((tyvs, (tr', tr)):) - return tr' - _ -> GM.composOp doVar tr - - r2r tr@(P (S (V ty ts) v) l) = t2t $ S (V ty [comp (P t l) | t <- ts]) v - - r2r tr@(P p _) = case getLab tr of - Ok (cat,labs) -> P (t2t p) . mkLab $ maybe (prtTrace tr $ 66664) snd $ - Map.lookup (cat,labs) labels - _ -> K ((prt tr +++ prtTrace tr "66665")) - - -- this goes recursively into tables (ignored) and records (accumulated) - getLab tr = case tr of - Vr (IA (cat, _)) -> return (identC cat,[]) - Vr (IC s) -> return (identC cat,[]) where - cat = init (reverse (dropWhile (/='_') (reverse s))) ---- from gf parser ----- Vr _ -> error $ "getLab " ++ show tr - P p lab2 -> do - (cat,labs) <- getLab p - return (cat,labs++[lab2]) - S p _ -> getLab p - _ -> Bad "getLab" - - - mkCase ((ty,vs),(x,p)) tr = - S (V ty [mkBranch x v tr | v <- vs]) p - mkBranch x t tr = case tr of - _ | tr == x -> t - _ -> GM.composSafeOp (mkBranch x t) tr - - valNum tr = maybe (valNumFV $ tryFV tr) EInt $ Map.lookup tr untyps - where - tryFV tr = case GM.appForm tr of - (c@(QC _ _), ts) -> [GM.mkApp c ts' | ts' <- combinations (map tryFV ts)] - (FV ts,_) -> ts - _ -> [tr] - valNumFV ts = case ts of - [tr] -> trace (unwords (map prt (Map.keys typs))) $ - prtTrace tr $ K "66667" - _ -> FV $ map valNum ts - - mkCurry trm = case trm of - V (RecType [(_,ty)]) ts -> V ty ts - V (RecType ((_,ty):ltys)) ts -> - V ty [mkCurry (V (RecType ltys) cs) | - cs <- chop (product (map (lengthtyp . snd) ltys)) ts] - _ -> trm - lengthtyp ty = case Map.lookup ty typs of - Just m -> length (Map.assocs m) - _ -> error $ "length of type " ++ show ty - chop i xs = case splitAt i xs of - (xs1,[]) -> [xs1] - (xs1,xs2) -> xs1:chop i xs2 - - - mkCurrySel t p = S t p -- done properly in CheckGFCC - - -mkLab k = LIdent (("_" ++ show k)) - --- remove lock fields; in fact, any empty records and record types -unlock = filter notlock where - notlock (l,(_, t)) = case t of --- need not look at l - R [] -> False - _ -> True -unlockTyp = filter notlock where - notlock (l, t) = case t of --- need not look at l - RecType [] -> False - _ -> True - -prtTrace tr n = - trace ("-- INTERNAL COMPILER ERROR" +++ prt tr ++++ show n) n -prTrace tr n = trace ("-- OBSERVE" +++ prt tr +++ show n +++ show tr) n - diff --git a/src/GF/Devel/Compile/GetGrammar.hs b/src/GF/Devel/Compile/GetGrammar.hs deleted file mode 100644 index b90bd912c..000000000 --- a/src/GF/Devel/Compile/GetGrammar.hs +++ /dev/null @@ -1,56 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GetGrammar --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/15 17:56:13 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.16 $ --- --- this module builds the internal GF grammar that is sent to the type checker ------------------------------------------------------------------------------ - -module GF.Devel.Compile.GetGrammar where - -import GF.Devel.UseIO -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -----import GF.Devel.PrGrammar -import GF.Devel.Compile.SourceToGF ----- import Macros ----- import Rename ---- import Custom -import GF.Devel.Compile.ParGF -import qualified GF.Devel.Compile.LexGF as L - -import GF.Data.Operations -import qualified GF.Devel.Compile.ErrM as E ---- -import GF.Infra.Option ---- -import GF.Devel.ReadFiles ---- - -import Data.Char (toUpper) -import Data.List (nub) -import Control.Monad (foldM) -import System (system) - -getSourceModule :: Options -> FilePath -> IOE SourceModule -getSourceModule opts file0 = do - file <- case getOptVal opts usePreprocessor of - Just p -> do - let tmp = "_gf_preproc.tmp" - cmd = p +++ file0 ++ ">" ++ tmp - ioeIO $ system cmd - -- ioeIO $ putStrLn $ "preproc" +++ cmd - return tmp - _ -> return file0 - string <- readFileIOE file - let tokens = myLexer string - mo1 <- ioeErr $ err2err $ pModDef tokens - ioeErr $ transModDef mo1 - -err2err e = case e of - E.Ok v -> Ok v - E.Bad s -> Bad s - diff --git a/src/GF/Devel/Compile/LexGF.hs b/src/GF/Devel/Compile/LexGF.hs deleted file mode 100644 index ff8386f49..000000000 --- a/src/GF/Devel/Compile/LexGF.hs +++ /dev/null @@ -1,343 +0,0 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} -{-# LINE 3 "GF/Devel/Compile/LexGF.x" #-} -{-# OPTIONS -fno-warn-incomplete-patterns #-} -module GF.Devel.Compile.LexGF where - - - -#if __GLASGOW_HASKELL__ >= 603 -#include "ghcconfig.h" -#else -#include "config.h" -#endif -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array -import Data.Char (ord) -import Data.Array.Base (unsafeAt) -#else -import Array -import Char (ord) -#endif -#if __GLASGOW_HASKELL__ >= 503 -import GHC.Exts -#else -import GlaExts -#endif -alex_base :: AlexAddr -alex_base = AlexA# "\x01\x00\x00\x00\x15\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x18\x00\x00\x00\x19\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x45\x00\x00\x00\x1b\x00\x00\x00\x1c\x00\x00\x00\x1d\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x26\x00\x00\x00\x27\x00\x00\x00\x13\x00\x00\x00\x9c\x00\x00\x00\x6c\x01\x00\x00\x3c\x02\x00\x00\x0c\x03\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x17\x01\x00\x00\xe7\x01\x00\x00\xd5\x00\x00\x00\x35\x00\x00\x00\xe7\x00\x00\x00\xf2\x00\x00\x00\x1d\x01\x00\x00\xc2\x01\x00\x00\xcc\x01\x00\x00"# - -alex_table :: AlexAddr -alex_table = AlexA# "\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0e\x00\x1a\x00\x0e\x00\x0e\x00\x0e\x00\xff\xff\x17\x00\x0e\x00\x0e\x00\x0f\x00\x10\x00\x0e\x00\x05\x00\x0e\x00\x0e\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x0e\x00\x0e\x00\x0e\x00\x11\x00\x0e\x00\x0e\x00\x0e\x00\x04\x00\xff\xff\xff\xff\x02\x00\x02\x00\x09\x00\x09\x00\x09\x00\x0a\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0e\x00\x0e\x00\x0e\x00\x16\x00\x16\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0e\x00\x0e\x00\xff\xff\x12\x00\xff\xff\x0d\x00\x20\x00\x00\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x00\x00\x00\x00\x09\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x0e\x00\x0e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x06\x00\x07\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x1b\x00\xff\xff\x00\x00\x00\x00\x14\x00\x1b\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\xff\xff\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x21\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x1c\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x15\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\xff\xff\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x1c\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x14\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x15\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00"# - -alex_check :: AlexAddr -alex_check = AlexA# "\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x2d\x00\x0a\x00\x0a\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2a\x00\x3e\x00\x2b\x00\x27\x00\x27\x00\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x20\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x2d\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x7d\x00\x7d\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x22\x00\xf7\x00\xff\xff\xff\xff\x5f\x00\x27\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\x65\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00"# - -alex_deflt :: AlexAddr -alex_deflt = AlexA# "\x13\x00\xff\xff\x03\x00\x03\x00\xff\xff\xff\xff\x0b\x00\xff\xff\x0b\x00\x0b\x00\x0b\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x18\x00\x18\x00\xff\xff\x1b\x00\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_accept = listArray (0::Int,34) [[],[],[(AlexAccSkip)],[(AlexAccSkip)],[],[(AlexAcc (alex_action_3))],[(AlexAccSkip)],[(AlexAccSkip)],[],[],[],[],[(AlexAcc (alex_action_3))],[(AlexAccSkip)],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[],[],[(AlexAcc (alex_action_7))],[],[],[],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_9))],[(AlexAcc (alex_action_9))],[],[],[]] -{-# LINE 36 "GF/Devel/Compile/LexGF.x" #-} - -tok f p s = f p s - -share :: String -> String -share = id - -data Tok = - TS !String -- reserved words and symbols - | TL !String -- string literals - | TI !String -- integer literals - | TV !String -- identifiers - | TD !String -- double precision float literals - | TC !String -- character literals - | T_PIdent !String - | T_LString !String - - deriving (Eq,Show,Ord) - -data Token = - PT Posn Tok - | Err Posn - deriving (Eq,Show,Ord) - -tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l -tokenPos (Err (Pn _ l _) :_) = "line " ++ show l -tokenPos _ = "end of file" - -posLineCol (Pn _ l c) = (l,c) -mkPosToken t@(PT p _) = (posLineCol p, prToken t) - -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 - PT _ (T_PIdent s) -> s - PT _ (T_LString s) -> s - - _ -> show t - -data BTree = N | B String Tok BTree BTree deriving (Show) - -eitherResIdent :: (String -> Tok) -> String -> Tok -eitherResIdent tv s = treeFind resWords - where - treeFind N = tv s - treeFind (B a t left right) | s < a = treeFind left - | s > a = treeFind right - | s == a = t - -resWords = b "lin" (b "def" (b "Type" (b "Str" (b "PType" (b "Lin" N N) N) (b "Tok" (b "Strs" N N) N)) (b "cat" (b "case" (b "abstract" N N) N) (b "data" (b "concrete" N N) N))) (b "include" (b "fun" (b "fn" (b "flags" N N) N) (b "in" (b "grammar" N N) N)) (b "interface" (b "instance" (b "incomplete" N N) N) (b "let" N N)))) (b "resource" (b "oper" (b "lintype" (b "lindef" (b "lincat" N N) N) (b "open" (b "of" N N) N)) (b "pattern" (b "param" (b "package" N N) N) (b "printname" (b "pre" N N) N))) (b "union" (b "table" (b "strs" (b "reuse" N N) N) (b "type" (b "tokenizer" N N) N)) (b "where" (b "variants" (b "var" N N) N) (b "with" N N)))) - where b s = B s (TS s) - -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 - _ -> [] - -------------------------------------------------------------------- --- Alex wrapper code. --- A modified "posn" wrapper. -------------------------------------------------------------------- - -data Posn = Pn !Int !Int !Int - deriving (Eq, Show,Ord) - -alexStartPos :: Posn -alexStartPos = Pn 0 1 1 - -alexMove :: Posn -> Char -> Posn -alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) -alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 -alexMove (Pn a l c) _ = Pn (a+1) l (c+1) - -type AlexInput = (Posn, -- current position, - Char, -- previous char - String) -- current input string - -tokens :: String -> [Token] -tokens str = go (alexStartPos, '\n', str) - where - go :: (Posn, Char, String) -> [Token] - go inp@(pos, _, str) = - case alexScan inp 0 of - AlexEOF -> [] - AlexError (pos, _, _) -> [Err pos] - AlexSkip inp' len -> go inp' - AlexToken inp' len act -> act pos (take len str) : (go inp') - -alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar (p, c, []) = Nothing -alexGetChar (p, _, (c:s)) = - let p' = alexMove p c - in p' `seq` Just (c, (p', c, s)) - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (p, c, s) = c - -alex_action_3 = tok (\p s -> PT p (TS $ share s)) -alex_action_4 = tok (\p s -> PT p (eitherResIdent (T_PIdent . share) s)) -alex_action_5 = tok (\p s -> PT p (eitherResIdent (T_LString . share) s)) -alex_action_6 = tok (\p s -> PT p (eitherResIdent (TV . share) s)) -alex_action_7 = tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) -alex_action_8 = tok (\p s -> PT p (TI $ share s)) -alex_action_9 = tok (\p s -> PT p (TD $ share s)) -{-# LINE 1 "GenericTemplate.hs" #-} -{-# LINE 1 "<built-in>" #-} -{-# LINE 1 "<command line>" #-} -{-# LINE 1 "GenericTemplate.hs" #-} --- ----------------------------------------------------------------------------- --- ALEX TEMPLATE --- --- This code is in the PUBLIC DOMAIN; you may copy it freely and use --- it for any purpose whatsoever. - --- ----------------------------------------------------------------------------- --- INTERNALS and main scanner engine - -{-# LINE 35 "GenericTemplate.hs" #-} - -{-# LINE 45 "GenericTemplate.hs" #-} - - -data AlexAddr = AlexA# Addr# - -#if __GLASGOW_HASKELL__ < 503 -uncheckedShiftL# = shiftL# -#endif - -{-# INLINE alexIndexInt16OffAddr #-} -alexIndexInt16OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow16Int# i - where - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# -#else - indexInt16OffAddr# arr off -#endif - - - - - -{-# INLINE alexIndexInt32OffAddr #-} -alexIndexInt32OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow32Int# i - where - i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` - (b2 `uncheckedShiftL#` 16#) `or#` - (b1 `uncheckedShiftL#` 8#) `or#` b0) - b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) - b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) - b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - b0 = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 4# -#else - indexInt32OffAddr# arr off -#endif - - - - - -#if __GLASGOW_HASKELL__ < 503 -quickIndex arr i = arr ! i -#else --- GHC >= 503, unsafeAt is available from Data.Array.Base. -quickIndex = unsafeAt -#endif - - - - --- ----------------------------------------------------------------------------- --- Main lexing routines - -data AlexReturn a - = AlexEOF - | AlexError !AlexInput - | AlexSkip !AlexInput !Int - | AlexToken !AlexInput !Int a - --- alexScan :: AlexInput -> StartCode -> AlexReturn a -alexScan input (I# (sc)) - = alexScanUser undefined input (I# (sc)) - -alexScanUser user input (I# (sc)) - = case alex_scan_tkn user input 0# input sc AlexNone of - (AlexNone, input') -> - case alexGetChar input of - Nothing -> - - - - AlexEOF - Just _ -> - - - - AlexError input' - - (AlexLastSkip input len, _) -> - - - - AlexSkip input len - - (AlexLastAcc k input len, _) -> - - - - AlexToken input len k - - --- Push the input through the DFA, remembering the most recent accepting --- state it encountered. - -alex_scan_tkn user orig_input len input s last_acc = - input `seq` -- strict in the input - let - new_acc = check_accs (alex_accept `quickIndex` (I# (s))) - in - new_acc `seq` - case alexGetChar input of - Nothing -> (new_acc, input) - Just (c, new_input) -> - - - - let - base = alexIndexInt32OffAddr alex_base s - (I# (ord_c)) = ord c - offset = (base +# ord_c) - check = alexIndexInt16OffAddr alex_check offset - - new_s = if (offset >=# 0#) && (check ==# ord_c) - then alexIndexInt16OffAddr alex_table offset - else alexIndexInt16OffAddr alex_deflt s - in - case new_s of - -1# -> (new_acc, input) - -- on an error, we want to keep the input *before* the - -- character that failed, not after. - _ -> alex_scan_tkn user orig_input (len +# 1#) - new_input new_s new_acc - - where - check_accs [] = last_acc - check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len)) - check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len)) - check_accs (AlexAccPred a pred : rest) - | pred user orig_input (I# (len)) input - = AlexLastAcc a input (I# (len)) - check_accs (AlexAccSkipPred pred : rest) - | pred user orig_input (I# (len)) input - = AlexLastSkip input (I# (len)) - check_accs (_ : rest) = check_accs rest - -data AlexLastAcc a - = AlexNone - | AlexLastAcc a !AlexInput !Int - | AlexLastSkip !AlexInput !Int - -data AlexAcc a user - = AlexAcc a - | AlexAccSkip - | AlexAccPred a (AlexAccPred user) - | AlexAccSkipPred (AlexAccPred user) - -type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool - --- ----------------------------------------------------------------------------- --- Predicates on a rule - -alexAndPred p1 p2 user in1 len in2 - = p1 user in1 len in2 && p2 user in1 len in2 - ---alexPrevCharIsPred :: Char -> AlexAccPred _ -alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input - ---alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ -alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input - ---alexRightContext :: Int -> AlexAccPred _ -alexRightContext (I# (sc)) user _ _ input = - case alex_scan_tkn user input 0# input sc AlexNone of - (AlexNone, _) -> False - _ -> True - -- TODO: there's no need to find the longest - -- match when checking the right context, just - -- the first match will do. - --- used by wrappers -iUnbox (I# (i)) = i diff --git a/src/GF/Devel/Compile/Optimize.hs b/src/GF/Devel/Compile/Optimize.hs deleted file mode 100644 index 746b47b90..000000000 --- a/src/GF/Devel/Compile/Optimize.hs +++ /dev/null @@ -1,333 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Optimize --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/09/16 13:56:13 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.18 $ --- --- Top-level partial evaluation for GF source modules. ------------------------------------------------------------------------------ - -module GF.Devel.Compile.Optimize (optimizeModule) where - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Devel.Grammar.Macros ---import GF.Devel.Grammar.PrGF -import GF.Devel.Grammar.Compute - ---import GF.Infra.Ident - -import GF.Devel.Grammar.Lookup ---import GF.Grammar.Refresh - ---import GF.Compile.BackOpt -import GF.Devel.Compile.CheckGrammar ---import GF.Compile.Update - - ---import GF.Infra.CheckM -import GF.Infra.Option ---- - -import GF.Data.Operations - -import Control.Monad -import Data.List -import qualified Data.Map as Map - -import Debug.Trace - - -optimizeModule :: Options -> GF -> SourceModule -> Err SourceModule -optimizeModule opts gf0 sm@(m,mo) = case mtype mo of - MTConcrete _ -> opt sm - MTInstance _ -> optr sm - MTGrammar -> optr sm - _ -> return sm - where - gf = gf0 {gfmodules = Map.insert m mo (gfmodules gf0)} - opt (m,mo) = do - mo' <- termOpModule (computeTerm gf) mo - return (m,mo') - - optr (m,mo)= do - let deps = allOperDependencies m $ mjments mo - ids <- topoSortOpers deps - gf' <- foldM evalOp gf ids - mo' <- lookupModule gf' m - return $ (m,mo') - where - evalOp gf i = do - ju <- lookupJudgement gf m i - def' <- computeTerm gf (jdef ju) - updateJudgement m i (ju {jdef = def'}) gf - - - - -{- - --- conditional trace - -prtIf :: (Print a) => Bool -> a -> a -prtIf b t = if b then trace (" " ++ prt t) t else t - --- | partial evaluation of concrete syntax. --- AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005 -- 7/12/2007 - -type EEnv = () --- not used - --- only do this for resource: concrete is optimized in gfc form - - - - =mse@(ms,eenv) mo@(_,mi) = case mi of - ModMod m0@(Module mt st fs me ops js) | - st == MSComplete && isModRes m0 && not (oElem oEval oopts)-> do - (mo1,_) <- evalModule oopts mse mo - let - mo2 = case optim of - "parametrize" -> shareModule paramOpt mo1 -- parametrization and sharing - "values" -> shareModule valOpt mo1 -- tables as courses-of-values - "share" -> shareModule shareOpt mo1 -- sharing of branches - "all" -> shareModule allOpt mo1 -- first parametrize then values - "none" -> mo1 -- no optimization - _ -> mo1 -- none; default for src - return (mo2,eenv) - _ -> evalModule oopts mse mo - where - oopts = addOptions opts (iOpts (flagsModule mo)) - optim = maybe "all" id $ getOptVal oopts useOptimizer - -evalModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> (Ident,SourceModInfo) -> - Err ((Ident,SourceModInfo),EEnv) -evalModule oopts (ms,eenv) mo@(name,mod) = case mod of - - ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of - _ | isModRes m0 && not (oElem oEval oopts) -> do - let deps = allOperDependencies name js - ids <- topoSortOpers deps - MGrammar (mod' : _) <- foldM evalOp gr ids - return $ (mod',eenv) - - MTConcrete a -> do - js' <- mapMTree (evalCncInfo oopts gr name a) js ---- <- gr0 6/12/2005 - return $ ((name, ModMod (Module mt st fs me ops js')),eenv) - - _ -> return $ ((name,mod),eenv) - _ -> return $ ((name,mod),eenv) - where - gr0 = MGrammar $ ms - gr = MGrammar $ (name,mod) : ms - - evalOp g@(MGrammar ((_, ModMod m) : _)) i = do - info <- lookupTree prt i $ jments m - info' <- evalResInfo oopts 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 :: Options -> SourceGrammar -> (Ident,Info) -> Err Info -evalResInfo oopts gr (c,info) = case info of - - ResOper pty pde -> eIn "operation" $ do - pde' <- case pde of - Yes de | optres -> liftM yes $ comp de - _ -> return pde - return $ ResOper pty pde' - - _ -> return info - where - comp = if optres then computeConcrete gr else computeConcreteRec gr - eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":") - optim = maybe "all" id $ getOptVal oopts useOptimizer - optres = case optim of - "noexpand" -> False - _ -> True - - -evalCncInfo :: - Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info) -evalCncInfo opts gr cnc abs (c,info) = do - - seq (prtIf (oElem beVerbose opts) c) $ return () - - errIn ("optimizing" +++ prt c) $ 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 >>= partEval noOptions gr ([(strVar, typeStr)],typ) - (May b, Nope) -> - return $ May b - _ -> return pde -- indirection - - ppr' <- liftM yes $ evalPrintname gr c ppr (yes $ K $ prt c) - - return (c, CncCat ptyp pde' ppr') - - CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr -> - eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do - pde' <- case pde of - Yes de | notNewEval -> do - liftM yes $ pEval ty de - - _ -> return pde - ppr' <- liftM yes $ evalPrintname gr c ppr pde' - return $ (c, CncFun mt pde' ppr') -- only cat in type actually needed - - _ -> return (c,info) - where - pEval = partEval opts gr - eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":") - notNewEval = not (oElem oEval opts) - --- | the main function for compiling linearizations -partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term -partEval opts gr (context, val) trm = errIn ("parteval" +++ prt_ trm) $ do - let vars = map fst context - args = map Vr vars - subst = [(v, Vr v) | v <- vars] - trm1 = mkApp trm args - trm3 <- if globalTable - then etaExpand subst trm1 >>= outCase subst - else etaExpand subst trm1 - return $ mkAbs vars trm3 - - where - - globalTable = oElem showAll opts --- i -all - - comp g t = ---- refreshTerm t >>= - computeTerm gr g t - - etaExpand su t = do - t' <- comp su t - case t' of - R _ | rightType t' -> comp su t' --- return t' wo noexpand... - _ -> recordExpand val t' >>= comp su - -- don't eta expand records of right length (correct by type checking) - rightType t = case (t,val) of - (R rs, RecType ts) -> length rs == length ts - _ -> False - - outCase subst t = do - pts <- getParams context - let (args,ptyps) = unzip $ filter (flip occur t . fst) pts - if null args - then return t - else do - let argtyp = RecType $ tuple2recordType ptyps - let pvars = map (Vr . zIdent . prt) args -- gets eliminated - patt <- term2patt $ R $ tuple2record $ pvars - let t' = replace (zip args pvars) t - t1 <- comp subst $ T (TTyped argtyp) [(patt, t')] - return $ S t1 $ R $ tuple2record args - - --- notice: this assumes that all lin types follow the "old JFP style" - getParams = liftM concat . mapM getParam - getParam (argv,RecType rs) = return - [(P (Vr argv) lab, ptyp) | (lab,ptyp) <- rs, not (isLinLabel lab)] - ---getParam (_,ty) | ty==typeStr = return [] --- in lindef - getParam (av,ty) = - Bad ("record type expected not" +++ prt ty +++ "for" +++ prt av) - --- all lin types are rec types - - replace :: [(Term,Term)] -> Term -> Term - replace reps trm = case trm of - -- this is the important case - P _ _ -> maybe trm id $ lookup trm reps - _ -> composSafeOp (replace reps) trm - - occur t trm = case trm of - - -- this is the important case - P _ _ -> t == trm - S x y -> occur t y || occur t x - App f x -> occur t x || occur t f - Abs _ f -> occur t f - R rs -> any (occur t) (map (snd . snd) rs) - T _ cs -> any (occur t) (map snd cs) - C x y -> occur t x || occur t y - Glue x y -> occur t x || occur t y - ExtR x y -> occur t x || occur t y - FV ts -> any (occur t) ts - V _ ts -> any (occur t) ts - Let (_,(_,x)) y -> occur t x || occur t y - _ -> False - - --- 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 - -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'] - _ | isTypeInts typ -> return $ EInt 0 -- exists in all as first val - _ -> prtBad "linearization type field cannot be" typ - --- | Form the printname: if given, compute. If not, use the computed --- lin for functions, cat name for cats (dispatch made in evalCncDef above). ---- We cannot use linearization at this stage, since we do not know the ---- defaults we would need for question marks - and we're not yet in canon. -evalPrintname :: SourceGrammar -> Ident -> MPr -> Perh Term -> Err Term -evalPrintname gr c ppr lin = - case ppr of - Yes pr -> comp pr - _ -> case lin of - Yes t -> return $ K $ clean $ prt $ oneBranch t ---- stringFromTerm - _ -> return $ K $ prt c ---- - where - comp = computeConcrete gr - - oneBranch t = case t of - Abs _ b -> oneBranch b - R (r:_) -> oneBranch $ snd $ snd r - T _ (c:_) -> oneBranch $ snd c - V _ (c:_) -> oneBranch c - FV (t:_) -> oneBranch t - C x y -> C (oneBranch x) (oneBranch y) - S x _ -> oneBranch x - P x _ -> oneBranch x - Alts (d,_) -> oneBranch d - _ -> t - - --- very unclean cleaner - clean s = case s of - '+':'+':' ':cs -> clean cs - '"':cs -> clean cs - c:cs -> c: clean cs - _ -> s - --} diff --git a/src/GF/Devel/Compile/ParGF.hs b/src/GF/Devel/Compile/ParGF.hs deleted file mode 100644 index ce474e418..000000000 --- a/src/GF/Devel/Compile/ParGF.hs +++ /dev/null @@ -1,3210 +0,0 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} -{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} -module GF.Devel.Compile.ParGF where -import GF.Devel.Compile.AbsGF -import GF.Devel.Compile.LexGF -import GF.Devel.Compile.ErrM -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array -#else -import Array -#endif -#if __GLASGOW_HASKELL__ >= 503 -import GHC.Exts -#else -import GlaExts -#endif - --- parser produced by Happy Version 1.16 - -newtype HappyAbsSyn = HappyAbsSyn (() -> ()) -happyIn7 :: (Integer) -> (HappyAbsSyn ) -happyIn7 x = unsafeCoerce# x -{-# INLINE happyIn7 #-} -happyOut7 :: (HappyAbsSyn ) -> (Integer) -happyOut7 x = unsafeCoerce# x -{-# INLINE happyOut7 #-} -happyIn8 :: (String) -> (HappyAbsSyn ) -happyIn8 x = unsafeCoerce# x -{-# INLINE happyIn8 #-} -happyOut8 :: (HappyAbsSyn ) -> (String) -happyOut8 x = unsafeCoerce# x -{-# INLINE happyOut8 #-} -happyIn9 :: (Double) -> (HappyAbsSyn ) -happyIn9 x = unsafeCoerce# x -{-# INLINE happyIn9 #-} -happyOut9 :: (HappyAbsSyn ) -> (Double) -happyOut9 x = unsafeCoerce# x -{-# INLINE happyOut9 #-} -happyIn10 :: (PIdent) -> (HappyAbsSyn ) -happyIn10 x = unsafeCoerce# x -{-# INLINE happyIn10 #-} -happyOut10 :: (HappyAbsSyn ) -> (PIdent) -happyOut10 x = unsafeCoerce# x -{-# INLINE happyOut10 #-} -happyIn11 :: (LString) -> (HappyAbsSyn ) -happyIn11 x = unsafeCoerce# x -{-# INLINE happyIn11 #-} -happyOut11 :: (HappyAbsSyn ) -> (LString) -happyOut11 x = unsafeCoerce# x -{-# INLINE happyOut11 #-} -happyIn12 :: (Grammar) -> (HappyAbsSyn ) -happyIn12 x = unsafeCoerce# x -{-# INLINE happyIn12 #-} -happyOut12 :: (HappyAbsSyn ) -> (Grammar) -happyOut12 x = unsafeCoerce# x -{-# INLINE happyOut12 #-} -happyIn13 :: ([ModDef]) -> (HappyAbsSyn ) -happyIn13 x = unsafeCoerce# x -{-# INLINE happyIn13 #-} -happyOut13 :: (HappyAbsSyn ) -> ([ModDef]) -happyOut13 x = unsafeCoerce# x -{-# INLINE happyOut13 #-} -happyIn14 :: (ModDef) -> (HappyAbsSyn ) -happyIn14 x = unsafeCoerce# x -{-# INLINE happyIn14 #-} -happyOut14 :: (HappyAbsSyn ) -> (ModDef) -happyOut14 x = unsafeCoerce# x -{-# INLINE happyOut14 #-} -happyIn15 :: (ModType) -> (HappyAbsSyn ) -happyIn15 x = unsafeCoerce# x -{-# INLINE happyIn15 #-} -happyOut15 :: (HappyAbsSyn ) -> (ModType) -happyOut15 x = unsafeCoerce# x -{-# INLINE happyOut15 #-} -happyIn16 :: (ModBody) -> (HappyAbsSyn ) -happyIn16 x = unsafeCoerce# x -{-# INLINE happyIn16 #-} -happyOut16 :: (HappyAbsSyn ) -> (ModBody) -happyOut16 x = unsafeCoerce# x -{-# INLINE happyOut16 #-} -happyIn17 :: ([TopDef]) -> (HappyAbsSyn ) -happyIn17 x = unsafeCoerce# x -{-# INLINE happyIn17 #-} -happyOut17 :: (HappyAbsSyn ) -> ([TopDef]) -happyOut17 x = unsafeCoerce# x -{-# INLINE happyOut17 #-} -happyIn18 :: (Extend) -> (HappyAbsSyn ) -happyIn18 x = unsafeCoerce# x -{-# INLINE happyIn18 #-} -happyOut18 :: (HappyAbsSyn ) -> (Extend) -happyOut18 x = unsafeCoerce# x -{-# INLINE happyOut18 #-} -happyIn19 :: ([Open]) -> (HappyAbsSyn ) -happyIn19 x = unsafeCoerce# x -{-# INLINE happyIn19 #-} -happyOut19 :: (HappyAbsSyn ) -> ([Open]) -happyOut19 x = unsafeCoerce# x -{-# INLINE happyOut19 #-} -happyIn20 :: (Opens) -> (HappyAbsSyn ) -happyIn20 x = unsafeCoerce# x -{-# INLINE happyIn20 #-} -happyOut20 :: (HappyAbsSyn ) -> (Opens) -happyOut20 x = unsafeCoerce# x -{-# INLINE happyOut20 #-} -happyIn21 :: (Open) -> (HappyAbsSyn ) -happyIn21 x = unsafeCoerce# x -{-# INLINE happyIn21 #-} -happyOut21 :: (HappyAbsSyn ) -> (Open) -happyOut21 x = unsafeCoerce# x -{-# INLINE happyOut21 #-} -happyIn22 :: (ComplMod) -> (HappyAbsSyn ) -happyIn22 x = unsafeCoerce# x -{-# INLINE happyIn22 #-} -happyOut22 :: (HappyAbsSyn ) -> (ComplMod) -happyOut22 x = unsafeCoerce# x -{-# INLINE happyOut22 #-} -happyIn23 :: ([Included]) -> (HappyAbsSyn ) -happyIn23 x = unsafeCoerce# x -{-# INLINE happyIn23 #-} -happyOut23 :: (HappyAbsSyn ) -> ([Included]) -happyOut23 x = unsafeCoerce# x -{-# INLINE happyOut23 #-} -happyIn24 :: (Included) -> (HappyAbsSyn ) -happyIn24 x = unsafeCoerce# x -{-# INLINE happyIn24 #-} -happyOut24 :: (HappyAbsSyn ) -> (Included) -happyOut24 x = unsafeCoerce# x -{-# INLINE happyOut24 #-} -happyIn25 :: (TopDef) -> (HappyAbsSyn ) -happyIn25 x = unsafeCoerce# x -{-# INLINE happyIn25 #-} -happyOut25 :: (HappyAbsSyn ) -> (TopDef) -happyOut25 x = unsafeCoerce# x -{-# INLINE happyOut25 #-} -happyIn26 :: (Def) -> (HappyAbsSyn ) -happyIn26 x = unsafeCoerce# x -{-# INLINE happyIn26 #-} -happyOut26 :: (HappyAbsSyn ) -> (Def) -happyOut26 x = unsafeCoerce# x -{-# INLINE happyOut26 #-} -happyIn27 :: (FunDef) -> (HappyAbsSyn ) -happyIn27 x = unsafeCoerce# x -{-# INLINE happyIn27 #-} -happyOut27 :: (HappyAbsSyn ) -> (FunDef) -happyOut27 x = unsafeCoerce# x -{-# INLINE happyOut27 #-} -happyIn28 :: (CatDef) -> (HappyAbsSyn ) -happyIn28 x = unsafeCoerce# x -{-# INLINE happyIn28 #-} -happyOut28 :: (HappyAbsSyn ) -> (CatDef) -happyOut28 x = unsafeCoerce# x -{-# INLINE happyOut28 #-} -happyIn29 :: (DataDef) -> (HappyAbsSyn ) -happyIn29 x = unsafeCoerce# x -{-# INLINE happyIn29 #-} -happyOut29 :: (HappyAbsSyn ) -> (DataDef) -happyOut29 x = unsafeCoerce# x -{-# INLINE happyOut29 #-} -happyIn30 :: (DataConstr) -> (HappyAbsSyn ) -happyIn30 x = unsafeCoerce# x -{-# INLINE happyIn30 #-} -happyOut30 :: (HappyAbsSyn ) -> (DataConstr) -happyOut30 x = unsafeCoerce# x -{-# INLINE happyOut30 #-} -happyIn31 :: ([DataConstr]) -> (HappyAbsSyn ) -happyIn31 x = unsafeCoerce# x -{-# INLINE happyIn31 #-} -happyOut31 :: (HappyAbsSyn ) -> ([DataConstr]) -happyOut31 x = unsafeCoerce# x -{-# INLINE happyOut31 #-} -happyIn32 :: (ParDef) -> (HappyAbsSyn ) -happyIn32 x = unsafeCoerce# x -{-# INLINE happyIn32 #-} -happyOut32 :: (HappyAbsSyn ) -> (ParDef) -happyOut32 x = unsafeCoerce# x -{-# INLINE happyOut32 #-} -happyIn33 :: (ParConstr) -> (HappyAbsSyn ) -happyIn33 x = unsafeCoerce# x -{-# INLINE happyIn33 #-} -happyOut33 :: (HappyAbsSyn ) -> (ParConstr) -happyOut33 x = unsafeCoerce# x -{-# INLINE happyOut33 #-} -happyIn34 :: ([Def]) -> (HappyAbsSyn ) -happyIn34 x = unsafeCoerce# x -{-# INLINE happyIn34 #-} -happyOut34 :: (HappyAbsSyn ) -> ([Def]) -happyOut34 x = unsafeCoerce# x -{-# INLINE happyOut34 #-} -happyIn35 :: ([FunDef]) -> (HappyAbsSyn ) -happyIn35 x = unsafeCoerce# x -{-# INLINE happyIn35 #-} -happyOut35 :: (HappyAbsSyn ) -> ([FunDef]) -happyOut35 x = unsafeCoerce# x -{-# INLINE happyOut35 #-} -happyIn36 :: ([CatDef]) -> (HappyAbsSyn ) -happyIn36 x = unsafeCoerce# x -{-# INLINE happyIn36 #-} -happyOut36 :: (HappyAbsSyn ) -> ([CatDef]) -happyOut36 x = unsafeCoerce# x -{-# INLINE happyOut36 #-} -happyIn37 :: ([DataDef]) -> (HappyAbsSyn ) -happyIn37 x = unsafeCoerce# x -{-# INLINE happyIn37 #-} -happyOut37 :: (HappyAbsSyn ) -> ([DataDef]) -happyOut37 x = unsafeCoerce# x -{-# INLINE happyOut37 #-} -happyIn38 :: ([ParDef]) -> (HappyAbsSyn ) -happyIn38 x = unsafeCoerce# x -{-# INLINE happyIn38 #-} -happyOut38 :: (HappyAbsSyn ) -> ([ParDef]) -happyOut38 x = unsafeCoerce# x -{-# INLINE happyOut38 #-} -happyIn39 :: ([ParConstr]) -> (HappyAbsSyn ) -happyIn39 x = unsafeCoerce# x -{-# INLINE happyIn39 #-} -happyOut39 :: (HappyAbsSyn ) -> ([ParConstr]) -happyOut39 x = unsafeCoerce# x -{-# INLINE happyOut39 #-} -happyIn40 :: ([PIdent]) -> (HappyAbsSyn ) -happyIn40 x = unsafeCoerce# x -{-# INLINE happyIn40 #-} -happyOut40 :: (HappyAbsSyn ) -> ([PIdent]) -happyOut40 x = unsafeCoerce# x -{-# INLINE happyOut40 #-} -happyIn41 :: (Name) -> (HappyAbsSyn ) -happyIn41 x = unsafeCoerce# x -{-# INLINE happyIn41 #-} -happyOut41 :: (HappyAbsSyn ) -> (Name) -happyOut41 x = unsafeCoerce# x -{-# INLINE happyOut41 #-} -happyIn42 :: ([Name]) -> (HappyAbsSyn ) -happyIn42 x = unsafeCoerce# x -{-# INLINE happyIn42 #-} -happyOut42 :: (HappyAbsSyn ) -> ([Name]) -happyOut42 x = unsafeCoerce# x -{-# INLINE happyOut42 #-} -happyIn43 :: (LocDef) -> (HappyAbsSyn ) -happyIn43 x = unsafeCoerce# x -{-# INLINE happyIn43 #-} -happyOut43 :: (HappyAbsSyn ) -> (LocDef) -happyOut43 x = unsafeCoerce# x -{-# INLINE happyOut43 #-} -happyIn44 :: ([LocDef]) -> (HappyAbsSyn ) -happyIn44 x = unsafeCoerce# x -{-# INLINE happyIn44 #-} -happyOut44 :: (HappyAbsSyn ) -> ([LocDef]) -happyOut44 x = unsafeCoerce# x -{-# INLINE happyOut44 #-} -happyIn45 :: (Exp) -> (HappyAbsSyn ) -happyIn45 x = unsafeCoerce# x -{-# INLINE happyIn45 #-} -happyOut45 :: (HappyAbsSyn ) -> (Exp) -happyOut45 x = unsafeCoerce# x -{-# INLINE happyOut45 #-} -happyIn46 :: (Exp) -> (HappyAbsSyn ) -happyIn46 x = unsafeCoerce# x -{-# INLINE happyIn46 #-} -happyOut46 :: (HappyAbsSyn ) -> (Exp) -happyOut46 x = unsafeCoerce# x -{-# INLINE happyOut46 #-} -happyIn47 :: (Exp) -> (HappyAbsSyn ) -happyIn47 x = unsafeCoerce# x -{-# INLINE happyIn47 #-} -happyOut47 :: (HappyAbsSyn ) -> (Exp) -happyOut47 x = unsafeCoerce# x -{-# INLINE happyOut47 #-} -happyIn48 :: (Exp) -> (HappyAbsSyn ) -happyIn48 x = unsafeCoerce# x -{-# INLINE happyIn48 #-} -happyOut48 :: (HappyAbsSyn ) -> (Exp) -happyOut48 x = unsafeCoerce# x -{-# INLINE happyOut48 #-} -happyIn49 :: (Exp) -> (HappyAbsSyn ) -happyIn49 x = unsafeCoerce# x -{-# INLINE happyIn49 #-} -happyOut49 :: (HappyAbsSyn ) -> (Exp) -happyOut49 x = unsafeCoerce# x -{-# INLINE happyOut49 #-} -happyIn50 :: (Exp) -> (HappyAbsSyn ) -happyIn50 x = unsafeCoerce# x -{-# INLINE happyIn50 #-} -happyOut50 :: (HappyAbsSyn ) -> (Exp) -happyOut50 x = unsafeCoerce# x -{-# INLINE happyOut50 #-} -happyIn51 :: (Exp) -> (HappyAbsSyn ) -happyIn51 x = unsafeCoerce# x -{-# INLINE happyIn51 #-} -happyOut51 :: (HappyAbsSyn ) -> (Exp) -happyOut51 x = unsafeCoerce# x -{-# INLINE happyOut51 #-} -happyIn52 :: ([Exp]) -> (HappyAbsSyn ) -happyIn52 x = unsafeCoerce# x -{-# INLINE happyIn52 #-} -happyOut52 :: (HappyAbsSyn ) -> ([Exp]) -happyOut52 x = unsafeCoerce# x -{-# INLINE happyOut52 #-} -happyIn53 :: (Exps) -> (HappyAbsSyn ) -happyIn53 x = unsafeCoerce# x -{-# INLINE happyIn53 #-} -happyOut53 :: (HappyAbsSyn ) -> (Exps) -happyOut53 x = unsafeCoerce# x -{-# INLINE happyOut53 #-} -happyIn54 :: (Patt) -> (HappyAbsSyn ) -happyIn54 x = unsafeCoerce# x -{-# INLINE happyIn54 #-} -happyOut54 :: (HappyAbsSyn ) -> (Patt) -happyOut54 x = unsafeCoerce# x -{-# INLINE happyOut54 #-} -happyIn55 :: (Patt) -> (HappyAbsSyn ) -happyIn55 x = unsafeCoerce# x -{-# INLINE happyIn55 #-} -happyOut55 :: (HappyAbsSyn ) -> (Patt) -happyOut55 x = unsafeCoerce# x -{-# INLINE happyOut55 #-} -happyIn56 :: (Patt) -> (HappyAbsSyn ) -happyIn56 x = unsafeCoerce# x -{-# INLINE happyIn56 #-} -happyOut56 :: (HappyAbsSyn ) -> (Patt) -happyOut56 x = unsafeCoerce# x -{-# INLINE happyOut56 #-} -happyIn57 :: (PattAss) -> (HappyAbsSyn ) -happyIn57 x = unsafeCoerce# x -{-# INLINE happyIn57 #-} -happyOut57 :: (HappyAbsSyn ) -> (PattAss) -happyOut57 x = unsafeCoerce# x -{-# INLINE happyOut57 #-} -happyIn58 :: (Label) -> (HappyAbsSyn ) -happyIn58 x = unsafeCoerce# x -{-# INLINE happyIn58 #-} -happyOut58 :: (HappyAbsSyn ) -> (Label) -happyOut58 x = unsafeCoerce# x -{-# INLINE happyOut58 #-} -happyIn59 :: (Sort) -> (HappyAbsSyn ) -happyIn59 x = unsafeCoerce# x -{-# INLINE happyIn59 #-} -happyOut59 :: (HappyAbsSyn ) -> (Sort) -happyOut59 x = unsafeCoerce# x -{-# INLINE happyOut59 #-} -happyIn60 :: ([PattAss]) -> (HappyAbsSyn ) -happyIn60 x = unsafeCoerce# x -{-# INLINE happyIn60 #-} -happyOut60 :: (HappyAbsSyn ) -> ([PattAss]) -happyOut60 x = unsafeCoerce# x -{-# INLINE happyOut60 #-} -happyIn61 :: ([Patt]) -> (HappyAbsSyn ) -happyIn61 x = unsafeCoerce# x -{-# INLINE happyIn61 #-} -happyOut61 :: (HappyAbsSyn ) -> ([Patt]) -happyOut61 x = unsafeCoerce# x -{-# INLINE happyOut61 #-} -happyIn62 :: (Bind) -> (HappyAbsSyn ) -happyIn62 x = unsafeCoerce# x -{-# INLINE happyIn62 #-} -happyOut62 :: (HappyAbsSyn ) -> (Bind) -happyOut62 x = unsafeCoerce# x -{-# INLINE happyOut62 #-} -happyIn63 :: ([Bind]) -> (HappyAbsSyn ) -happyIn63 x = unsafeCoerce# x -{-# INLINE happyIn63 #-} -happyOut63 :: (HappyAbsSyn ) -> ([Bind]) -happyOut63 x = unsafeCoerce# x -{-# INLINE happyOut63 #-} -happyIn64 :: (Decl) -> (HappyAbsSyn ) -happyIn64 x = unsafeCoerce# x -{-# INLINE happyIn64 #-} -happyOut64 :: (HappyAbsSyn ) -> (Decl) -happyOut64 x = unsafeCoerce# x -{-# INLINE happyOut64 #-} -happyIn65 :: (TupleComp) -> (HappyAbsSyn ) -happyIn65 x = unsafeCoerce# x -{-# INLINE happyIn65 #-} -happyOut65 :: (HappyAbsSyn ) -> (TupleComp) -happyOut65 x = unsafeCoerce# x -{-# INLINE happyOut65 #-} -happyIn66 :: (PattTupleComp) -> (HappyAbsSyn ) -happyIn66 x = unsafeCoerce# x -{-# INLINE happyIn66 #-} -happyOut66 :: (HappyAbsSyn ) -> (PattTupleComp) -happyOut66 x = unsafeCoerce# x -{-# INLINE happyOut66 #-} -happyIn67 :: ([TupleComp]) -> (HappyAbsSyn ) -happyIn67 x = unsafeCoerce# x -{-# INLINE happyIn67 #-} -happyOut67 :: (HappyAbsSyn ) -> ([TupleComp]) -happyOut67 x = unsafeCoerce# x -{-# INLINE happyOut67 #-} -happyIn68 :: ([PattTupleComp]) -> (HappyAbsSyn ) -happyIn68 x = unsafeCoerce# x -{-# INLINE happyIn68 #-} -happyOut68 :: (HappyAbsSyn ) -> ([PattTupleComp]) -happyOut68 x = unsafeCoerce# x -{-# INLINE happyOut68 #-} -happyIn69 :: (Case) -> (HappyAbsSyn ) -happyIn69 x = unsafeCoerce# x -{-# INLINE happyIn69 #-} -happyOut69 :: (HappyAbsSyn ) -> (Case) -happyOut69 x = unsafeCoerce# x -{-# INLINE happyOut69 #-} -happyIn70 :: ([Case]) -> (HappyAbsSyn ) -happyIn70 x = unsafeCoerce# x -{-# INLINE happyIn70 #-} -happyOut70 :: (HappyAbsSyn ) -> ([Case]) -happyOut70 x = unsafeCoerce# x -{-# INLINE happyOut70 #-} -happyIn71 :: (Equation) -> (HappyAbsSyn ) -happyIn71 x = unsafeCoerce# x -{-# INLINE happyIn71 #-} -happyOut71 :: (HappyAbsSyn ) -> (Equation) -happyOut71 x = unsafeCoerce# x -{-# INLINE happyOut71 #-} -happyIn72 :: ([Equation]) -> (HappyAbsSyn ) -happyIn72 x = unsafeCoerce# x -{-# INLINE happyIn72 #-} -happyOut72 :: (HappyAbsSyn ) -> ([Equation]) -happyOut72 x = unsafeCoerce# x -{-# INLINE happyOut72 #-} -happyIn73 :: (Altern) -> (HappyAbsSyn ) -happyIn73 x = unsafeCoerce# x -{-# INLINE happyIn73 #-} -happyOut73 :: (HappyAbsSyn ) -> (Altern) -happyOut73 x = unsafeCoerce# x -{-# INLINE happyOut73 #-} -happyIn74 :: ([Altern]) -> (HappyAbsSyn ) -happyIn74 x = unsafeCoerce# x -{-# INLINE happyIn74 #-} -happyOut74 :: (HappyAbsSyn ) -> ([Altern]) -happyOut74 x = unsafeCoerce# x -{-# INLINE happyOut74 #-} -happyIn75 :: (DDecl) -> (HappyAbsSyn ) -happyIn75 x = unsafeCoerce# x -{-# INLINE happyIn75 #-} -happyOut75 :: (HappyAbsSyn ) -> (DDecl) -happyOut75 x = unsafeCoerce# x -{-# INLINE happyOut75 #-} -happyIn76 :: ([DDecl]) -> (HappyAbsSyn ) -happyIn76 x = unsafeCoerce# x -{-# INLINE happyIn76 #-} -happyOut76 :: (HappyAbsSyn ) -> ([DDecl]) -happyOut76 x = unsafeCoerce# x -{-# INLINE happyOut76 #-} -happyIn77 :: (OldGrammar) -> (HappyAbsSyn ) -happyIn77 x = unsafeCoerce# x -{-# INLINE happyIn77 #-} -happyOut77 :: (HappyAbsSyn ) -> (OldGrammar) -happyOut77 x = unsafeCoerce# x -{-# INLINE happyOut77 #-} -happyIn78 :: (Include) -> (HappyAbsSyn ) -happyIn78 x = unsafeCoerce# x -{-# INLINE happyIn78 #-} -happyOut78 :: (HappyAbsSyn ) -> (Include) -happyOut78 x = unsafeCoerce# x -{-# INLINE happyOut78 #-} -happyIn79 :: (FileName) -> (HappyAbsSyn ) -happyIn79 x = unsafeCoerce# x -{-# INLINE happyIn79 #-} -happyOut79 :: (HappyAbsSyn ) -> (FileName) -happyOut79 x = unsafeCoerce# x -{-# INLINE happyOut79 #-} -happyIn80 :: ([FileName]) -> (HappyAbsSyn ) -happyIn80 x = unsafeCoerce# x -{-# INLINE happyIn80 #-} -happyOut80 :: (HappyAbsSyn ) -> ([FileName]) -happyOut80 x = unsafeCoerce# x -{-# INLINE happyOut80 #-} -happyInTok :: Token -> (HappyAbsSyn ) -happyInTok x = unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn ) -> Token -happyOutTok x = unsafeCoerce# x -{-# INLINE happyOutTok #-} - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x00\x00\x34\x04\x2a\x04\xe9\x00\x0d\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x04\x90\x01\x6f\x00\x37\x04\xfa\x03\x35\x04\x00\x00\x31\x04\xe7\x03\xfe\xff\x1c\x00\xe7\x03\x00\x00\xe9\x00\x29\x00\xe7\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x30\x04\x63\x02\x06\x00\x00\x03\x2f\x04\x2e\x04\x58\x02\x2d\x04\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x03\x00\x00\xf9\xff\x01\x00\x6e\x08\x00\x00\xdc\x03\x4e\x00\x2c\x04\x1c\x04\xc6\x03\xc6\x03\xc6\x03\xc6\x03\xc6\x03\xc6\x03\x00\x00\x00\x00\xf9\xff\x13\x04\x00\x00\xf9\xff\xf9\xff\xf9\xff\xf6\x07\xe9\x00\x17\x01\xeb\x02\x9b\x00\xc4\x03\x4d\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x03\x04\x00\x00\xc3\x03\xeb\x02\xc1\x03\x00\x00\xeb\x02\xc0\x03\x00\x00\x0a\x02\x06\x04\x39\x00\x0a\x04\xdb\x03\xb1\x03\x1b\x00\x16\x03\xd4\x03\x00\x00\x00\x00\xf3\x03\xdf\x03\x77\x00\x00\x00\xee\x03\xf0\x03\xe2\x03\x43\x02\xeb\x03\xff\x01\x00\x00\xd6\x00\xea\x03\xe5\x03\xf4\x01\x8d\x02\xe8\x03\x4d\x00\x37\x01\x4d\x00\x37\x01\x37\x01\x37\x01\x4d\x00\xe1\x03\xd6\x03\xef\xff\x00\x00\x00\x00\x96\x03\x8d\x03\x00\x00\xf4\x01\xf4\x01\xf4\x01\x00\x00\xf4\x01\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x03\x8d\x03\xd3\x03\x4d\x00\x00\x00\xa6\x01\xd0\x03\x89\x03\x00\x00\x89\x03\x00\x00\x00\x00\x4d\x00\x4d\x00\xbe\x03\x4d\x00\x77\x00\xd2\x03\x16\x03\xbc\x03\xd1\x03\xcc\x03\x00\x00\xc7\x03\x4d\x00\x84\x03\x4d\x00\x4d\x00\xbd\x03\xa7\x03\xb1\x02\xa3\x03\x00\x00\xf9\x00\xad\x03\x99\x03\x16\x03\xa8\x03\x7a\x02\xe8\x01\xae\x03\xa9\x03\xa0\x03\x54\x03\xa1\x03\x9e\x03\x93\x03\x83\x03\x87\x02\x5f\x01\x8a\x03\x86\x03\xeb\x02\x4d\x00\x81\x03\x00\x00\x2b\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x34\x03\x34\x03\x28\x00\x02\x00\x34\x03\x28\x00\x00\x00\x00\x00\x00\x00\xf9\xff\x00\x00\x00\x00\x00\x00\x4b\x03\x00\x00\x49\x03\x00\x00\x18\x00\x2f\x02\x00\x00\x46\x03\x78\x03\x30\x00\x32\x03\x32\x03\x32\x03\x32\x03\x00\x00\x00\x00\x76\x03\x00\x00\xd6\x02\x33\x00\x25\x03\x72\x03\x00\x00\x28\x00\x28\x00\x00\x00\x6e\x03\x6a\x03\x00\x00\x57\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x03\x00\x00\x64\x03\x4a\x03\x00\x00\x00\x00\x53\x03\x00\x00\x00\x00\x87\x00\x00\x00\x4f\x03\x00\x00\xfc\x02\x00\x00\x40\x03\x44\x03\x00\x00\xc7\x02\xc7\x02\xc7\x02\x4d\x00\x00\x00\xf6\x02\x16\x03\x00\x00\x4d\x00\x4d\x00\x00\x00\x00\x00\xf6\x02\xc7\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x02\x00\x00\xf6\x02\x42\x03\x00\x00\x00\x00\x00\x00\x14\x03\x00\x00\x16\x03\x4d\x00\x00\x00\xc7\x02\x00\x00\x00\x00\x4d\x00\x24\x03\x00\x00\x00\x00\x00\x00\xb4\x01\x00\x00\x00\x00\x38\x03\x00\x00\x30\x03\x00\x00\x2e\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x03\x00\x00\x00\x00\x4d\x00\x4d\x00\x00\x00\x00\x00\xf9\x00\x00\x00\x0b\x03\x20\x03\x1a\x03\x00\x00\x00\x00\x16\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x9b\x01\xe4\x02\xfa\xff\xfa\xff\x4d\x00\xfa\xff\x19\x03\xd9\x02\xd9\x02\x00\x00\x00\x00\x00\x00\x0e\x03\x4d\x00\x4d\x00\x10\x03\xfa\xff\x00\x00\x00\x00\x00\x00\x11\x03\x00\x00\xbc\x02\x0a\x00\xbc\x02\x07\x03\x0a\x00\xb9\x02\xfb\x02\xb3\x02\xf7\x02\x00\x00\xcb\x02\xf3\x02\xa9\x02\x00\x00\xaa\x02\xee\x02\x00\x00\x00\x00\x4d\x00\xe3\x02\x00\x00\x00\x00\x00\x00\xda\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x02\x00\x00\xd7\x02\xd2\x02\x00\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x42\x01\x00\x00\x00\x00\x4d\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x02\xcf\x02\x82\x02\x82\x02\x91\x03\x82\x02\x9b\x01\x4d\x00\x00\x00\xa0\x02\x0a\x00\x71\x03\xcd\x02\x0a\x00\x00\x00\x00\x00\xbe\x02\x00\x00\x00\x00\x6e\x02\x00\x00\xc4\x02\xb8\x02\x00\x00\x00\x00\xb5\x02\x00\x00\x00\x00\x4d\x00\x69\x02\xa7\x02\xa2\x02\x00\x00\x00\x00\x6f\x02\x97\x02\x00\x00\x9a\x02\x51\x03\x00\x00\x00\x00\x00\x00\x00\x00\x31\x03\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x78\x00\x22\x02\x8b\x01\x9e\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x03\x54\x04\x3c\x01\x96\x02\x00\x00\x17\x04\xca\x00\x93\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x07\x00\x00\x00\x00\xf2\x07\x6f\x03\x3c\x02\x00\x00\x00\x00\xd3\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x02\x19\x00\x00\x00\x81\x02\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x6d\x02\x6b\x02\x6a\x02\x5f\x02\x5d\x02\x5b\x02\x00\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x22\x00\x13\x00\x07\x00\x4b\x02\xc8\x04\x00\x00\x4d\x01\x64\x07\x59\x02\xac\x04\x46\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\x01\x46\x02\x50\x02\x00\x00\x0c\x03\x47\x02\x00\x00\xe7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x03\x44\x02\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x07\x00\x00\x00\x00\x00\x00\x00\x00\x44\x04\x00\x00\x00\x00\x2a\x07\xc3\x02\x0c\x07\xbc\x07\xad\x07\x2b\x03\xf0\x06\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x1c\x02\x1d\x03\x00\x00\x28\x04\x28\x04\x28\x04\x00\x00\x28\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\x08\x02\x00\x00\xd2\x06\x00\x00\xcb\x07\x00\x00\x9b\x02\x00\x00\x07\x02\x00\x00\x00\x00\xfb\x03\xb6\x06\x00\x00\x98\x06\x5d\x00\x00\x00\xcb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x06\x00\x01\x5e\x06\x42\x06\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x01\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\xc0\x01\x8e\x04\x00\x00\x00\x00\x91\x01\xf4\x07\x77\x08\x75\x08\x69\x08\x64\x08\x5e\x08\x53\x08\x50\x08\x47\x08\xea\x01\x69\x01\x42\x08\x3d\x08\xdf\x01\x39\x08\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x01\x00\x00\x00\x00\xd4\x01\x00\x00\x00\x00\xd5\x01\x8a\x01\xc2\x01\xa0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x41\x01\x00\x00\x95\x01\x00\x00\x00\x00\x2c\x08\xa0\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x01\x00\x00\x00\x00\x87\x01\x00\x00\x00\x00\x00\x00\x00\x00\xd5\x00\xed\x03\x7d\x02\x24\x06\x00\x00\x7c\x01\x37\x00\x00\x00\x72\x04\xdd\x03\x00\x00\x00\x00\xd7\x01\x24\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x02\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x08\x06\x00\x00\x84\x00\x00\x00\x00\x00\xea\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x05\xb0\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x01\x6c\x01\xad\x00\x47\x01\xa6\x00\x0d\x01\x94\x05\x26\x08\x00\x00\xb3\x00\x59\x01\x00\x00\x00\x00\x00\x00\x00\x00\x76\x05\x5a\x05\x00\x00\xa2\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x01\xab\x02\x90\x00\x00\x00\x2d\x02\xcd\x00\x00\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x01\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x05\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\x00\x00\x00\x00\x11\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x04\x00\x00\xad\x00\x00\x00\x00\x00\xbf\x03\x20\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\xf4\x00\xdb\x00\xfc\x00\xad\x00\x02\x05\x00\x00\xd3\x00\xcd\x01\xbc\x00\x00\x00\x99\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x04\xcb\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x7d\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x53\x00\x00\x00\x00\x00"# - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\xf5\xff\xd8\xff\x17\xff\x00\x00\x00\x00\xfb\xff\x8e\xff\x8f\xff\x8d\xff\x93\xff\x82\xff\x7e\xff\x73\xff\x6e\xff\x60\xff\x61\xff\x00\x00\x6c\xff\x90\xff\x00\x00\x96\xff\x34\xff\x00\x00\x00\x00\x8c\xff\x2d\xff\x34\xff\x00\x00\x3f\xff\x3d\xff\x3c\xff\x3e\xff\x40\xff\x00\x00\x8a\xff\x00\x00\x00\x00\x96\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\xff\xf9\xff\xf8\xff\xf7\xff\x00\x00\xe3\xff\x00\x00\x00\x00\x00\x00\xd7\xff\x00\x00\xd8\xff\xf4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\xff\x15\xff\x14\xff\x00\x00\x16\xff\x00\x00\x00\x00\x00\x00\x18\xff\x5f\xff\x00\x00\x96\xff\x00\x00\x00\x00\x5f\xff\x00\x00\x52\xff\x50\xff\x51\xff\x55\xff\x75\xff\x3b\xff\x00\x00\x00\x00\x5a\xff\x2a\xff\x00\x00\x56\xff\x00\x00\x9f\xff\x00\x00\x95\xff\x00\x00\x96\xff\x00\x00\x23\xff\x00\x00\x72\xff\x36\xff\x33\xff\x00\x00\x34\xff\x35\xff\x2f\xff\x2c\xff\x00\x00\x00\x00\x00\x00\x5c\xff\x8b\xff\x93\xff\x00\x00\x00\x00\x00\x00\x9f\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xff\x00\x00\x42\xff\x81\xff\x00\x00\x96\xff\x67\xff\x70\xff\x71\xff\x6f\xff\x6b\xff\x6e\xff\x60\xff\x6d\xff\x68\xff\x87\xff\x92\xff\x00\x00\x00\x00\x93\xff\x00\x00\x83\xff\x5c\xff\x00\x00\x96\xff\x88\xff\x00\x00\x91\xff\x86\xff\x2d\xff\x00\x00\x00\x00\x00\x00\x34\xff\x00\x00\x38\xff\x00\x00\x22\xff\x00\x00\x62\xff\x00\x00\x00\x00\x96\xff\x00\x00\x00\x00\x74\xff\x58\xff\x55\xff\x47\xff\x44\xff\x2e\xff\x29\xff\x00\x00\x00\x00\x00\x00\x00\x00\x9f\xff\x00\x00\x3a\xff\x00\x00\x00\x00\x00\x00\x5e\xff\x00\x00\x00\x00\x9f\xff\x00\x00\x26\xff\x00\x00\x00\x00\x5f\xff\x00\x00\xe2\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\xff\x12\xff\x11\xff\x0f\xff\x10\xff\xf0\xff\xee\xff\x00\x00\xef\xff\x00\x00\xf1\xff\xd6\xff\xd3\xff\xf2\xff\xdc\xff\xea\xff\xd5\xff\x00\x00\xd6\xff\x00\x00\x00\x00\x0e\xff\x9d\xff\x00\x00\xbf\xff\x9b\xff\x00\x00\x00\x00\x00\x00\xc3\xff\x00\x00\x00\x00\xc1\xff\xae\xff\x00\x00\xcb\xff\x00\x00\xca\xff\xc2\xff\xc8\xff\xc9\xff\xc7\xff\x00\x00\xcf\xff\x9b\xff\x00\x00\xc4\xff\xcd\xff\x00\x00\xce\xff\xcc\xff\x9b\xff\x1a\xff\x00\x00\xd0\xff\x00\x00\x78\xff\x00\x00\x00\x00\x7c\xff\x00\x00\x00\x00\x00\x00\x00\x00\x4c\xff\x00\x00\x00\x00\x76\xff\x5f\xff\x1f\xff\x53\xff\x4f\xff\x3b\xff\x00\x00\x54\xff\x4d\xff\x59\xff\x48\xff\x4e\xff\x2a\xff\x4a\xff\x00\x00\x99\xff\x98\xff\x94\xff\x65\xff\x00\x00\x63\xff\x23\xff\x00\x00\x37\xff\x00\x00\x32\xff\x6a\xff\x00\x00\x00\x00\x2f\xff\x2b\xff\x7f\xff\x9f\xff\x89\xff\x5b\xff\x00\x00\x85\xff\x00\x00\x9e\xff\x00\x00\x41\xff\x64\xff\x80\xff\x31\xff\x84\xff\x69\xff\x00\x00\x24\xff\x21\xff\x00\x00\x00\x00\x57\xff\x28\xff\x43\xff\x39\xff\x00\x00\x1e\xff\x00\x00\x5d\xff\x49\xff\x53\xff\x27\xff\x45\xff\x46\xff\x25\xff\x7b\xff\x7a\xff\x1a\xff\xa8\xff\xb8\xff\xb2\xff\x00\x00\xa6\xff\x00\x00\xaa\xff\x00\x00\xa4\xff\xa2\xff\xc5\xff\xc6\xff\xbe\xff\x00\x00\x00\x00\x00\x00\x00\x00\xac\xff\xec\xff\xed\xff\xe4\xff\xd5\xff\xe5\xff\xd6\xff\xdf\xff\xe1\xff\x00\x00\xdf\xff\x00\x00\x00\x00\x00\x00\x00\x00\xda\xff\x00\x00\xde\xff\x00\x00\xe3\xff\x00\x00\xe9\xff\xd4\xff\xab\xff\x00\x00\xbd\xff\xbc\xff\x9c\xff\x1a\xff\xa1\xff\xaf\xff\xa3\xff\xe3\xff\xa9\xff\xb9\xff\xa5\xff\x00\x00\x9a\xff\xb4\xff\xb1\xff\xb5\xff\x1b\xff\x19\xff\x34\xff\xa7\xff\x00\x00\x4b\xff\x77\xff\x1f\xff\x00\x00\x97\xff\x66\xff\x79\xff\x20\xff\x1d\xff\xb7\xff\x00\x00\xb2\xff\x00\x00\x00\x00\xa2\xff\xad\xff\x00\x00\xbb\xff\xdc\xff\xdf\xff\x00\x00\x00\x00\xdf\xff\xdb\xff\xd2\xff\x00\x00\xd1\xff\xdd\xff\x00\x00\xeb\xff\xe7\xff\x00\x00\xba\xff\xa0\xff\x00\x00\xb3\xff\xb0\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xff\xe3\xff\xdc\xff\x00\x00\xd9\xff\x00\x00\x00\x00\x1c\xff\xb6\xff\xe8\xff\xe3\xff\x00\x00\xe6\xff"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x03\x00\x01\x00\x09\x00\x0b\x00\x07\x00\x0d\x00\x09\x00\x01\x00\x03\x00\x03\x00\x09\x00\x1d\x00\x0f\x00\x10\x00\x11\x00\x01\x00\x07\x00\x03\x00\x03\x00\x01\x00\x17\x00\x03\x00\x1e\x00\x0a\x00\x1b\x00\x01\x00\x03\x00\x03\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x01\x00\x26\x00\x03\x00\x0a\x00\x29\x00\x0d\x00\x27\x00\x2c\x00\x07\x00\x09\x00\x2f\x00\x01\x00\x2d\x00\x03\x00\x09\x00\x34\x00\x0f\x00\x09\x00\x02\x00\x06\x00\x00\x00\x01\x00\x02\x00\x03\x00\x02\x00\x3e\x00\x3f\x00\x4f\x00\x0c\x00\x17\x00\x43\x00\x44\x00\x33\x00\x1b\x00\x0c\x00\x4d\x00\x49\x00\x4f\x00\x4f\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x48\x00\x03\x00\x4f\x00\x3a\x00\x52\x00\x07\x00\x4f\x00\x09\x00\x48\x00\x49\x00\x4f\x00\x42\x00\x48\x00\x0f\x00\x10\x00\x11\x00\x47\x00\x03\x00\x48\x00\x49\x00\x03\x00\x17\x00\x12\x00\x2f\x00\x4f\x00\x4d\x00\x4d\x00\x48\x00\x4f\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x4f\x00\x26\x00\x05\x00\x48\x00\x29\x00\x4f\x00\x4f\x00\x2c\x00\x4f\x00\x4b\x00\x2f\x00\x05\x00\x06\x00\x31\x00\x05\x00\x34\x00\x13\x00\x14\x00\x00\x00\x01\x00\x02\x00\x03\x00\x19\x00\x02\x00\x0d\x00\x3e\x00\x3f\x00\x06\x00\x13\x00\x14\x00\x43\x00\x44\x00\x1b\x00\x03\x00\x37\x00\x38\x00\x49\x00\x37\x00\x38\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x03\x00\x12\x00\x52\x00\x11\x00\x07\x00\x03\x00\x09\x00\x00\x00\x01\x00\x02\x00\x03\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x17\x00\x2f\x00\x30\x00\x31\x00\x03\x00\x17\x00\x18\x00\x4a\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x0a\x00\x26\x00\x3e\x00\x3f\x00\x29\x00\x03\x00\x4f\x00\x2c\x00\x22\x00\x23\x00\x2f\x00\x00\x00\x19\x00\x03\x00\x12\x00\x34\x00\x03\x00\x03\x00\x1f\x00\x26\x00\x2f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x3e\x00\x3f\x00\x36\x00\x06\x00\x03\x00\x43\x00\x44\x00\x0d\x00\x34\x00\x0c\x00\x21\x00\x49\x00\x40\x00\x41\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x03\x00\x12\x00\x21\x00\x21\x00\x07\x00\x44\x00\x09\x00\x00\x00\x01\x00\x02\x00\x03\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x00\x00\x01\x00\x02\x00\x03\x00\x03\x00\x17\x00\x37\x00\x38\x00\x03\x00\x2f\x00\x30\x00\x31\x00\x0e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x15\x00\x26\x00\x03\x00\x03\x00\x29\x00\x3e\x00\x3f\x00\x2c\x00\x1a\x00\x09\x00\x2f\x00\x0b\x00\x03\x00\x0a\x00\x20\x00\x34\x00\x10\x00\x11\x00\x09\x00\x21\x00\x2f\x00\x16\x00\x24\x00\x25\x00\x45\x00\x3e\x00\x3f\x00\x36\x00\x2f\x00\x1e\x00\x43\x00\x44\x00\x03\x00\x22\x00\x0a\x00\x36\x00\x49\x00\x40\x00\x41\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x03\x00\x10\x00\x11\x00\x01\x00\x07\x00\x03\x00\x09\x00\x00\x00\x01\x00\x02\x00\x03\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x07\x00\x03\x00\x09\x00\x0a\x00\x00\x00\x01\x00\x02\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x03\x00\x45\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x03\x00\x26\x00\x17\x00\x18\x00\x29\x00\x03\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x00\x00\x01\x00\x02\x00\x03\x00\x29\x00\x03\x00\x0e\x00\x21\x00\x03\x00\x2f\x00\x24\x00\x25\x00\x1a\x00\x15\x00\x3e\x00\x3f\x00\x36\x00\x19\x00\x20\x00\x43\x00\x44\x00\x2f\x00\x30\x00\x31\x00\x03\x00\x49\x00\x15\x00\x19\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x1f\x00\x1d\x00\x03\x00\x3e\x00\x3f\x00\x03\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x03\x00\x03\x00\x45\x00\x2f\x00\x07\x00\x03\x00\x09\x00\x10\x00\x11\x00\x03\x00\x36\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x07\x00\x03\x00\x09\x00\x0c\x00\x15\x00\x0e\x00\x18\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x07\x00\x1d\x00\x09\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x0f\x00\x10\x00\x11\x00\x04\x00\x29\x00\x06\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x00\x00\x01\x00\x02\x00\x03\x00\x29\x00\x03\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x00\x00\x01\x00\x02\x00\x03\x00\x29\x00\x03\x00\x46\x00\x47\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x03\x00\x0c\x00\x03\x00\x0e\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x0d\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x04\x00\x03\x00\x06\x00\x2f\x00\x30\x00\x31\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x03\x00\x21\x00\x26\x00\x2f\x00\x07\x00\x03\x00\x09\x00\x3e\x00\x3f\x00\x03\x00\x36\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x07\x00\x34\x00\x09\x00\x32\x00\x03\x00\x03\x00\x35\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x07\x00\x2f\x00\x09\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x0f\x00\x10\x00\x11\x00\x00\x00\x29\x00\x21\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x00\x00\x01\x00\x02\x00\x03\x00\x29\x00\x07\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x32\x00\x03\x00\x0f\x00\x35\x00\x29\x00\x00\x00\x01\x00\x02\x00\x03\x00\x09\x00\x0c\x00\x0b\x00\x0e\x00\x00\x00\x01\x00\x02\x00\x03\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x01\x00\x00\x00\x01\x00\x02\x00\x03\x00\x03\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x0d\x00\x01\x00\x0f\x00\x2f\x00\x30\x00\x31\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x03\x00\x03\x00\x12\x00\x03\x00\x07\x00\x03\x00\x09\x00\x03\x00\x2f\x00\x30\x00\x31\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x07\x00\x2f\x00\x09\x00\x03\x00\x03\x00\x3b\x00\x03\x00\x3d\x00\x0f\x00\x10\x00\x11\x00\x2f\x00\x30\x00\x31\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x00\x00\x01\x00\x02\x00\x03\x00\x29\x00\x08\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x0e\x00\x08\x00\x03\x00\x04\x00\x29\x00\x06\x00\x07\x00\x15\x00\x09\x00\x04\x00\x0a\x00\x06\x00\x0d\x00\x0e\x00\x03\x00\x10\x00\x11\x00\x03\x00\x0d\x00\x14\x00\x15\x00\x03\x00\x03\x00\x08\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x3a\x00\x08\x00\x04\x00\x2f\x00\x30\x00\x03\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x03\x00\x4c\x00\x01\x00\x0c\x00\x07\x00\x0e\x00\x09\x00\x03\x00\x21\x00\x4f\x00\x0d\x00\x24\x00\x25\x00\x10\x00\x11\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x0a\x00\x05\x00\x03\x00\x1a\x00\x1b\x00\x1c\x00\x07\x00\x02\x00\x09\x00\x4f\x00\x0b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x10\x00\x11\x00\x03\x00\x3a\x00\x0c\x00\x06\x00\x07\x00\x03\x00\x09\x00\x0e\x00\x1a\x00\x1b\x00\x02\x00\x0d\x00\x02\x00\x10\x00\x11\x00\x0e\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x03\x00\x2c\x00\x1a\x00\x1b\x00\x07\x00\x05\x00\x09\x00\x4b\x00\x0b\x00\x34\x00\x4f\x00\x06\x00\x2f\x00\x10\x00\x11\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x0a\x00\x4f\x00\x03\x00\x09\x00\x1a\x00\x1b\x00\x07\x00\x4f\x00\x09\x00\x03\x00\x4f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x10\x00\x11\x00\x02\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x06\x00\x0a\x00\x03\x00\x1a\x00\x1b\x00\x03\x00\x07\x00\x04\x00\x09\x00\x03\x00\x01\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x10\x00\x11\x00\x4f\x00\x1e\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x1a\x00\x1b\x00\x04\x00\x4f\x00\x04\x00\x04\x00\x12\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x2f\x00\x30\x00\x31\x00\x21\x00\x03\x00\x08\x00\x24\x00\x25\x00\x2f\x00\x02\x00\x4f\x00\x46\x00\x3b\x00\x04\x00\x3d\x00\x0a\x00\x4f\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x01\x00\x26\x00\x27\x00\x28\x00\x01\x00\x04\x00\x0c\x00\x01\x00\x27\x00\x02\x00\x29\x00\x2a\x00\x2b\x00\x21\x00\x2d\x00\x34\x00\x24\x00\x25\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x35\x00\x36\x00\x37\x00\x38\x00\x06\x00\x01\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x02\x00\x40\x00\x03\x00\x01\x00\x4f\x00\x04\x00\x45\x00\x01\x00\x27\x00\x48\x00\x29\x00\x2a\x00\x2b\x00\x05\x00\x2d\x00\x03\x00\x3a\x00\x4f\x00\x39\x00\x4f\x00\x39\x00\x04\x00\x35\x00\x36\x00\x37\x00\x38\x00\x04\x00\x01\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x21\x00\x40\x00\x0f\x00\x24\x00\x25\x00\x04\x00\x45\x00\x04\x00\x27\x00\x48\x00\x29\x00\x2a\x00\x2b\x00\x21\x00\x2d\x00\x01\x00\x24\x00\x25\x00\x01\x00\x4f\x00\x04\x00\x03\x00\x35\x00\x36\x00\x37\x00\x38\x00\x01\x00\x12\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x02\x00\x40\x00\x0a\x00\x06\x00\x0d\x00\x13\x00\x45\x00\x14\x00\x27\x00\x48\x00\x29\x00\x2a\x00\x2b\x00\x1b\x00\x2d\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x22\x00\x23\x00\x35\x00\x36\x00\x37\x00\x38\x00\x0d\x00\x04\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x04\x00\x40\x00\x01\x00\x4f\x00\x18\x00\x03\x00\x45\x00\x19\x00\x4f\x00\x48\x00\x0a\x00\x08\x00\x4f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x4c\x00\x0d\x00\x03\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x0c\x00\x08\x00\x34\x00\x12\x00\x0a\x00\x06\x00\x18\x00\x39\x00\x06\x00\x0c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x4f\x00\x42\x00\x43\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2f\x00\x01\x00\x06\x00\x39\x00\x4d\x00\x4f\x00\x0d\x00\x34\x00\x4f\x00\x4f\x00\x01\x00\x4f\x00\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x2f\x00\x30\x00\x02\x00\x42\x00\x43\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x01\x00\x52\x00\x34\x00\x03\x00\x03\x00\x03\x00\x03\x00\x39\x00\x3a\x00\x4f\x00\x3c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x18\x00\x15\x00\x34\x00\x52\x00\x16\x00\x26\x00\x27\x00\x39\x00\x3a\x00\x0d\x00\x3c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x4c\x00\x30\x00\xff\xff\x34\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x31\x00\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x34\x00\xff\xff\xff\xff\x37\x00\x38\x00\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x34\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\x37\x00\x38\x00\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x03\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x13\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\xff\xff\x1b\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x22\x00\x23\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\x34\x00\x26\x00\x27\x00\x28\x00\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x26\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x03\x00\xff\xff\x2e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x34\x00\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x2e\x00\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x34\x00\x26\x00\x27\x00\xff\xff\x1c\x00\xff\xff\x1e\x00\xff\xff\xff\xff\xff\xff\x22\x00\x23\x00\x26\x00\x27\x00\xff\xff\x34\x00\xff\xff\x27\x00\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\xff\xff\xff\xff\x34\x00\x26\x00\x27\x00\x03\x00\xff\xff\x35\x00\x36\x00\x37\x00\x38\x00\x03\x00\xff\xff\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x34\x00\x40\x00\xff\xff\xff\xff\xff\xff\x14\x00\x45\x00\x03\x00\xff\xff\x48\x00\x13\x00\x03\x00\xff\xff\x1c\x00\xff\xff\xff\xff\x03\x00\xff\xff\x1b\x00\x22\x00\x23\x00\x03\x00\xff\xff\x13\x00\xff\xff\x22\x00\x23\x00\x13\x00\xff\xff\xff\xff\x03\x00\x1b\x00\x13\x00\x03\x00\xff\xff\x1b\x00\xff\xff\x13\x00\x22\x00\x23\x00\x1b\x00\xff\xff\x22\x00\x23\x00\x03\x00\x1b\x00\x13\x00\x22\x00\x23\x00\x13\x00\x03\x00\xff\xff\x22\x00\x23\x00\x1b\x00\x03\x00\xff\xff\x1b\x00\xff\xff\xff\xff\x13\x00\x22\x00\x23\x00\xff\xff\x22\x00\x23\x00\x13\x00\x03\x00\x1b\x00\x03\x00\xff\xff\xff\xff\x14\x00\xff\xff\x1b\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\x1c\x00\x22\x00\x23\x00\x13\x00\xff\xff\x13\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\x1b\x00\x25\x00\xff\xff\xff\xff\x28\x00\x22\x00\x23\x00\x22\x00\x23\x00\xff\xff\x2e\x00\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x15\x00\x40\x00\xf4\x00\x45\x00\x16\x00\x46\x00\x17\x00\x40\x00\x61\x00\x41\x00\xf4\x00\x84\x00\x18\x00\x19\x00\x1a\x00\x40\x00\x83\x01\x41\x00\x81\x00\x40\x00\x1b\x00\x41\x00\x47\x00\xd2\x01\x6a\x00\x40\x00\xe0\xff\x41\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x40\x00\x22\x00\x41\x00\x71\x00\x23\x00\x81\x00\xf7\x00\x24\x00\x37\x00\x10\x01\x75\x00\x40\x00\xf8\x00\x41\x00\xf4\x00\x26\x00\x33\x00\x10\x01\x6e\x01\x77\x01\x4f\x00\x50\x00\x51\x00\x52\x00\xab\x00\x27\x00\x28\x00\x2e\x00\x6f\x01\x69\x00\x29\x00\x2a\x00\x82\x00\x6a\x00\xac\x00\x2c\x00\x2b\x00\x2e\x00\x2e\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xd8\x00\x15\x00\x2e\x00\xe0\xff\xff\xff\x16\x00\x2e\x00\x17\x00\x42\x00\xed\x00\x2e\x00\xea\x00\xd9\x00\x18\x00\x19\x00\x1a\x00\xeb\x00\x65\x00\x42\x00\x43\x00\x65\x00\x1b\x00\xc7\x00\x56\x01\x2e\x00\x2c\x00\x2c\x00\xda\x00\x2e\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x2e\x00\x22\x00\x7b\x00\xdc\x00\x23\x00\x2e\x00\x2e\x00\x24\x00\x2e\x00\x78\x01\x25\x00\x35\x00\x36\x00\x35\x00\x7b\x00\x26\x00\x7c\x00\x7d\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x7e\x00\x62\x01\xcc\x01\x27\x00\x28\x00\x63\x01\x7c\x00\x7d\x00\x29\x00\x2a\x00\x6a\x00\xe4\x00\x66\x00\x34\x01\x2b\x00\x66\x00\x9e\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x15\x00\xc7\x00\xf6\xff\x84\x01\x16\x00\x96\x01\x17\x00\x4f\x00\x50\x00\x51\x00\x52\x00\xee\x00\x18\x00\x19\x00\x1a\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x1b\x00\xaf\x00\xb0\x00\xc1\x00\xf9\x00\x97\x01\xc2\x01\x7f\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xcd\x01\x22\x00\xc2\x00\x49\x01\x23\x00\x5c\x00\x2e\x00\x24\x00\x04\x01\x95\x01\x75\x00\xc5\x01\xfa\x00\x65\x00\xc7\x00\x26\x00\x5c\x00\x5c\x00\x8f\x01\x99\x01\xa2\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x27\x00\x28\x00\xa3\x00\x36\xff\xca\x01\x29\x00\x2a\x00\xbd\x01\x12\x00\x36\xff\xb7\x01\x2b\x00\xa4\x00\x4b\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x15\x00\xc7\x00\x7e\x01\x41\x01\x16\x00\x9a\x01\x17\x00\x4f\x00\x50\x00\x51\x00\x52\x00\xc1\x01\x18\x00\x19\x00\x1a\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x8c\x01\x1b\x00\x66\x00\x67\x00\x5c\x00\xaf\x00\xb0\x00\xc1\x00\x16\x01\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x17\x01\x22\x00\xee\x00\xe4\x00\x23\x00\xc2\x00\x5b\x01\x24\x00\x8d\x01\xe5\x00\x25\x00\xe6\x00\xc5\x00\xab\x01\xbf\x01\x26\x00\xe7\x00\xe8\x00\xc6\x00\x5d\x00\xa2\x00\x08\x01\x5e\x00\x2c\x01\xad\x01\x27\x00\x28\x00\xa3\x00\xa2\x00\x93\x01\x29\x00\x2a\x00\xe4\x00\x94\x01\xb2\x01\x9e\x01\x2b\x00\xa4\x00\xa5\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x15\x00\x86\x01\x74\x01\x6e\x00\x4c\x00\x6f\x00\x17\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x98\x00\x18\x00\x19\x00\x1a\x00\x9c\x01\x96\x01\x17\x00\xa8\x01\x4f\x00\x50\x00\x51\x00\xc0\x00\x4d\x00\x19\x00\x1a\x00\xb3\x01\x9d\x01\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x8c\x01\x22\x00\x97\x01\x98\x01\x23\x00\x4e\x01\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x23\x00\xf9\x00\x16\x01\x5d\x00\x0c\x01\xa2\x00\x5e\x00\x76\x00\x8d\x01\x17\x01\x27\x00\x28\x00\x6f\x01\x18\x01\x8e\x01\x29\x00\x2a\x00\xaf\x00\xb0\x00\xc1\x00\x57\x01\x2b\x00\x0d\x01\xfa\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xfb\x00\x9c\x01\x5e\x01\xc2\x00\xc3\x00\xe4\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x15\x00\x0c\x01\x60\x01\xa2\x00\x4c\x00\x6c\x01\x17\x00\x73\x01\x74\x01\x7f\x01\x18\x01\x98\x00\x18\x00\x19\x00\x1a\x00\x9c\x01\x71\x01\x17\x00\xb9\x01\x0d\x01\x81\x01\x30\xff\x98\x00\x4d\x00\x19\x00\x1a\x00\x4c\x00\x0e\x01\x17\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x4d\x00\x19\x00\x1a\x00\x90\x00\x23\x00\x91\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x23\x00\x72\x01\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x23\x00\x7f\x01\x2f\x00\x30\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x75\x01\xbc\x01\x5c\x00\x81\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x79\x01\xf4\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x23\x01\xfc\x00\x91\x00\xaf\x00\xb0\x00\xc1\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x15\x00\xb8\x00\x49\x00\xa2\x00\x4c\x00\x1e\x01\x17\x00\xc2\x00\x12\x01\xb7\x00\x32\x01\x98\x00\x18\x00\x19\x00\x1a\x00\x4c\x00\x12\x00\x17\x00\xb9\x00\x3a\x01\x40\x01\x51\x01\x15\x00\x4d\x00\x19\x00\x1a\x00\x4c\x00\x25\x01\x17\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x18\x00\x19\x00\x1a\x00\x43\x01\x23\x00\xb8\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x23\x00\x32\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xb9\x00\x7f\x01\x33\x00\xba\x00\x23\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x7c\x01\x80\x01\x7d\x01\x81\x01\x4f\x00\x50\x00\x51\x00\x52\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xa6\x00\x4f\x00\x50\x00\x51\x00\xae\x00\xad\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x9a\x00\xb5\x00\x9b\x00\xaf\x00\xb0\x00\x50\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x4b\x00\xbf\x00\xc7\x00\xdd\x00\x4c\x00\xde\x00\x17\x00\xdf\x00\xaf\x00\xb0\x00\xb1\x00\x15\x00\x4d\x00\x19\x00\x1a\x00\x4c\x00\x53\x00\x17\x00\xe0\x00\xe1\x00\xb2\x00\xe2\x00\x4f\x01\x18\x00\x19\x00\x1a\x00\xaf\x00\xb0\x00\xb6\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x23\x00\x24\x01\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x16\x01\x38\x00\x55\x00\x90\x00\x23\x00\x91\x00\x56\x00\x17\x01\x57\x00\x90\x00\x47\x00\x91\x00\x1a\x01\x55\xff\x64\x00\x58\x00\x59\x00\x6d\x00\x92\x00\x55\xff\x55\xff\xd2\x01\x3b\x01\xcc\x01\x55\xff\x5a\x00\x5b\x00\x1b\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x7b\x01\xcf\x01\xd0\x01\xaf\x00\x59\x01\x7f\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x55\x00\x06\x00\xc8\x01\x85\x01\x56\x00\x81\x01\x57\x00\xc9\x01\x5d\x00\x2e\x00\x1a\x01\x5e\x00\x76\x00\x58\x00\x59\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\xb9\x01\xca\x01\x55\x00\x5a\x00\x5b\x00\x1b\x01\x56\x00\xbb\x01\x57\x00\x2e\x00\xb5\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x58\x00\x59\x00\x55\x00\x7b\x01\xc4\x01\x63\x01\x56\x00\xc5\x01\x57\x00\xaa\x01\x5a\x00\x5b\x00\x62\x01\xab\x01\xaf\x01\x58\x00\x59\x00\xad\x01\x0b\x00\x0c\x00\x8a\x00\x8b\x00\x8c\x00\x55\x00\x11\x00\x5a\x00\x5b\x00\x56\x00\xb1\x01\x57\x00\xb2\x01\xb5\x00\x12\x00\x2e\x00\xb5\x01\xb6\x01\x58\x00\x59\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\xb7\x01\x2e\x00\x55\x00\x7e\x01\x5a\x00\x5b\x00\x56\x00\x2e\x00\x57\x00\x84\x01\x2e\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x58\x00\x59\x00\x89\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\x77\x01\x8c\x01\x55\x00\x5a\x00\x5b\x00\x91\x01\x56\x00\xa0\x01\x57\x00\x5c\x00\xa1\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\x58\x00\x59\x00\x2e\x00\xa2\x01\xa5\x01\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x5a\x00\x5b\x00\x45\x01\x2e\x00\x46\x01\xd4\x01\x48\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\xaf\x00\xb0\x00\xb1\x00\x5d\x00\x5c\x00\x47\x01\x5e\x00\x42\x01\x4d\x01\x4e\x01\x2e\x00\x5c\x00\xb2\x00\x5d\x01\xb3\x00\x5e\x01\x2e\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x60\x01\x0b\x00\x0c\x00\x86\x00\x64\x01\xd1\x01\x65\x01\x66\x01\xc9\x00\x67\x01\xca\x00\xcb\x00\xcc\x00\x5d\x00\xcd\x00\x12\x00\x5e\x00\xa7\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\x63\x01\x68\x01\xd2\x00\xd3\x00\xd4\x00\xd5\x00\x69\x01\xd6\x00\x5c\x00\x6c\x01\x2e\x00\xbc\x01\xd7\x00\x71\x01\xc9\x00\xd8\x00\xca\x00\xcb\x00\xcc\x00\x79\x01\xcd\x00\x75\x00\x7b\x01\x2e\x00\xec\x00\x2e\x00\xed\x00\x11\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\x14\x01\x15\x01\xd2\x00\xd3\x00\xd4\x00\xd5\x00\x5d\x00\xd6\x00\x9b\x00\x5e\x00\x5f\x00\xc1\x01\xd7\x00\x1c\x01\xc9\x00\xd8\x00\xca\x00\xcb\x00\xcc\x00\x5d\x00\xcd\x00\x1d\x01\x5e\x00\x76\x00\x1e\x01\x2e\x00\x20\x01\xee\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\x21\x01\x27\x01\xd2\x00\xd3\x00\xd4\x00\xd5\x00\x22\x01\xd6\x00\x25\x01\x28\x01\x2a\x01\xef\x00\xd7\x00\x29\x01\xc9\x00\xd8\x00\xca\x00\xcb\x00\xcc\x00\x87\x01\xcd\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\xf1\x00\xf2\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\x81\x00\x2f\x01\xd2\x00\xd3\x00\xd4\x00\xd5\x00\x30\x01\xd6\x00\x31\x01\x2e\x00\x32\x01\x34\x01\xd7\x00\x37\x01\x2e\x00\xd8\x00\x3d\x01\x40\x01\x2e\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x06\x00\x81\x00\x85\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x52\x01\x11\x00\x8f\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x94\x00\x95\x00\x12\x00\x9c\x00\x99\x00\x9d\x00\xa0\x00\x13\x00\xa1\x00\x9e\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x2e\x00\x53\x01\xa6\x01\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x52\x01\x11\x00\xa9\x00\xaa\x00\x91\x00\xa2\x00\x2c\x00\x2e\x00\xbc\x00\x12\x00\x2e\x00\x2e\x00\xdc\x00\x2e\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\xaf\x00\x5a\x01\xe4\x00\x53\x01\x54\x01\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x38\x01\x11\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x40\x00\xff\xff\x12\x00\x49\x00\x4e\x00\x4f\x00\x63\x00\x13\x00\x6b\x00\x2e\x00\x39\x01\x06\x00\x07\x00\x08\x00\x71\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x6a\x00\x11\x00\x06\x00\x07\x00\x08\x00\x92\x00\x0a\x00\x78\x00\x79\x00\x12\x00\xff\xff\x7a\x00\x0b\x00\x7f\x00\x13\x00\x6b\x00\x81\x00\x6c\x00\x06\x00\x07\x00\x08\x00\x71\x00\x0a\x00\x06\x00\x32\x00\x00\x00\x12\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x72\x00\x11\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x61\x00\x12\x00\x00\x00\x00\x00\x66\x00\xa8\x01\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x12\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x72\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x66\x00\x73\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xbd\x00\x11\x00\x55\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xbd\x00\x11\x00\x11\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xbd\x00\x11\x00\xbe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xbd\x00\x11\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xc6\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xbe\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xa5\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xaf\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x89\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x8a\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x92\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xa2\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xa3\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x48\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x4a\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x58\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x2a\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x2b\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x2d\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x35\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x37\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x3e\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x85\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x89\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x8d\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xbc\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x72\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\xee\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x63\x00\x11\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\xef\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x69\x01\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\xf1\x00\xf2\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x12\x00\x0b\x00\x0c\x00\x87\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x0b\x00\x0c\x00\x88\x00\x00\x00\x00\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x95\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\xee\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x95\x00\x12\x00\x00\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x96\x00\x00\x00\x02\x01\x00\x00\x08\x01\x00\x00\x12\x00\x0b\x00\xac\x00\x00\x00\x09\x01\x00\x00\x0a\x01\x00\x00\x00\x00\x00\x00\x0b\x01\x05\x01\x0b\x00\x61\x00\x00\x00\x12\x00\x00\x00\xc9\x00\x00\x00\xca\x00\xcb\x00\xcc\x00\x00\x00\xcd\x00\x00\x00\x00\x00\x12\x00\x0b\x00\x7f\x00\xee\x00\x00\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xee\x00\x00\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\x12\x00\xd6\x00\x00\x00\x00\x00\x00\x00\x02\x01\xd7\x00\xee\x00\x00\x00\xd8\x00\xef\x00\xee\x00\x00\x00\x91\x01\x00\x00\x00\x00\xee\x00\x00\x00\x6a\x01\x04\x01\x05\x01\xee\x00\x00\x00\xef\x00\x00\x00\xf1\x00\xf2\x00\xef\x00\x00\x00\x00\x00\xee\x00\xf0\x00\xef\x00\xee\x00\x00\x00\xf5\x00\x00\x00\xef\x00\xf1\x00\xf2\x00\xf8\x00\x00\x00\xf1\x00\xf2\x00\xee\x00\xfd\x00\xef\x00\xf1\x00\xf2\x00\xef\x00\xee\x00\x00\x00\xf1\x00\xf2\x00\xfe\x00\xee\x00\x00\x00\xff\x00\x00\x00\x00\x00\xef\x00\xf1\x00\xf2\x00\x00\x00\xf1\x00\xf2\x00\xef\x00\xee\x00\x00\x01\xee\x00\x00\x00\x00\x00\x02\x01\x00\x00\x01\x01\xf1\x00\xf2\x00\x00\x00\x00\x00\x00\x00\x03\x01\xf1\x00\xf2\x00\xef\x00\x00\x00\xef\x00\x04\x01\x05\x01\x00\x00\x00\x00\x00\x00\x06\x01\x00\x00\x07\x01\x3a\x00\x00\x00\x00\x00\x3b\x00\xf1\x00\xf2\x00\xf1\x00\xf2\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyReduceArr = array (4, 241) [ - (4 , happyReduce_4), - (5 , happyReduce_5), - (6 , happyReduce_6), - (7 , happyReduce_7), - (8 , happyReduce_8), - (9 , happyReduce_9), - (10 , happyReduce_10), - (11 , happyReduce_11), - (12 , happyReduce_12), - (13 , happyReduce_13), - (14 , happyReduce_14), - (15 , happyReduce_15), - (16 , happyReduce_16), - (17 , happyReduce_17), - (18 , happyReduce_18), - (19 , happyReduce_19), - (20 , happyReduce_20), - (21 , happyReduce_21), - (22 , happyReduce_22), - (23 , happyReduce_23), - (24 , happyReduce_24), - (25 , happyReduce_25), - (26 , happyReduce_26), - (27 , happyReduce_27), - (28 , happyReduce_28), - (29 , happyReduce_29), - (30 , happyReduce_30), - (31 , happyReduce_31), - (32 , happyReduce_32), - (33 , happyReduce_33), - (34 , happyReduce_34), - (35 , happyReduce_35), - (36 , happyReduce_36), - (37 , happyReduce_37), - (38 , happyReduce_38), - (39 , happyReduce_39), - (40 , happyReduce_40), - (41 , happyReduce_41), - (42 , happyReduce_42), - (43 , happyReduce_43), - (44 , happyReduce_44), - (45 , happyReduce_45), - (46 , happyReduce_46), - (47 , happyReduce_47), - (48 , happyReduce_48), - (49 , happyReduce_49), - (50 , happyReduce_50), - (51 , happyReduce_51), - (52 , happyReduce_52), - (53 , happyReduce_53), - (54 , happyReduce_54), - (55 , happyReduce_55), - (56 , happyReduce_56), - (57 , happyReduce_57), - (58 , happyReduce_58), - (59 , happyReduce_59), - (60 , happyReduce_60), - (61 , happyReduce_61), - (62 , happyReduce_62), - (63 , happyReduce_63), - (64 , happyReduce_64), - (65 , happyReduce_65), - (66 , happyReduce_66), - (67 , happyReduce_67), - (68 , happyReduce_68), - (69 , happyReduce_69), - (70 , happyReduce_70), - (71 , happyReduce_71), - (72 , happyReduce_72), - (73 , happyReduce_73), - (74 , happyReduce_74), - (75 , happyReduce_75), - (76 , happyReduce_76), - (77 , happyReduce_77), - (78 , happyReduce_78), - (79 , happyReduce_79), - (80 , happyReduce_80), - (81 , happyReduce_81), - (82 , happyReduce_82), - (83 , happyReduce_83), - (84 , happyReduce_84), - (85 , happyReduce_85), - (86 , happyReduce_86), - (87 , happyReduce_87), - (88 , happyReduce_88), - (89 , happyReduce_89), - (90 , happyReduce_90), - (91 , happyReduce_91), - (92 , happyReduce_92), - (93 , happyReduce_93), - (94 , happyReduce_94), - (95 , happyReduce_95), - (96 , happyReduce_96), - (97 , happyReduce_97), - (98 , happyReduce_98), - (99 , happyReduce_99), - (100 , happyReduce_100), - (101 , happyReduce_101), - (102 , happyReduce_102), - (103 , happyReduce_103), - (104 , happyReduce_104), - (105 , happyReduce_105), - (106 , happyReduce_106), - (107 , happyReduce_107), - (108 , happyReduce_108), - (109 , happyReduce_109), - (110 , happyReduce_110), - (111 , happyReduce_111), - (112 , happyReduce_112), - (113 , happyReduce_113), - (114 , happyReduce_114), - (115 , happyReduce_115), - (116 , happyReduce_116), - (117 , happyReduce_117), - (118 , happyReduce_118), - (119 , happyReduce_119), - (120 , happyReduce_120), - (121 , happyReduce_121), - (122 , happyReduce_122), - (123 , happyReduce_123), - (124 , happyReduce_124), - (125 , happyReduce_125), - (126 , happyReduce_126), - (127 , happyReduce_127), - (128 , happyReduce_128), - (129 , happyReduce_129), - (130 , happyReduce_130), - (131 , happyReduce_131), - (132 , happyReduce_132), - (133 , happyReduce_133), - (134 , happyReduce_134), - (135 , happyReduce_135), - (136 , happyReduce_136), - (137 , happyReduce_137), - (138 , happyReduce_138), - (139 , happyReduce_139), - (140 , happyReduce_140), - (141 , happyReduce_141), - (142 , happyReduce_142), - (143 , happyReduce_143), - (144 , happyReduce_144), - (145 , happyReduce_145), - (146 , happyReduce_146), - (147 , happyReduce_147), - (148 , happyReduce_148), - (149 , happyReduce_149), - (150 , happyReduce_150), - (151 , happyReduce_151), - (152 , happyReduce_152), - (153 , happyReduce_153), - (154 , happyReduce_154), - (155 , happyReduce_155), - (156 , happyReduce_156), - (157 , happyReduce_157), - (158 , happyReduce_158), - (159 , happyReduce_159), - (160 , happyReduce_160), - (161 , happyReduce_161), - (162 , happyReduce_162), - (163 , happyReduce_163), - (164 , happyReduce_164), - (165 , happyReduce_165), - (166 , happyReduce_166), - (167 , happyReduce_167), - (168 , happyReduce_168), - (169 , happyReduce_169), - (170 , happyReduce_170), - (171 , happyReduce_171), - (172 , happyReduce_172), - (173 , happyReduce_173), - (174 , happyReduce_174), - (175 , happyReduce_175), - (176 , happyReduce_176), - (177 , happyReduce_177), - (178 , happyReduce_178), - (179 , happyReduce_179), - (180 , happyReduce_180), - (181 , happyReduce_181), - (182 , happyReduce_182), - (183 , happyReduce_183), - (184 , happyReduce_184), - (185 , happyReduce_185), - (186 , happyReduce_186), - (187 , happyReduce_187), - (188 , happyReduce_188), - (189 , happyReduce_189), - (190 , happyReduce_190), - (191 , happyReduce_191), - (192 , happyReduce_192), - (193 , happyReduce_193), - (194 , happyReduce_194), - (195 , happyReduce_195), - (196 , happyReduce_196), - (197 , happyReduce_197), - (198 , happyReduce_198), - (199 , happyReduce_199), - (200 , happyReduce_200), - (201 , happyReduce_201), - (202 , happyReduce_202), - (203 , happyReduce_203), - (204 , happyReduce_204), - (205 , happyReduce_205), - (206 , happyReduce_206), - (207 , happyReduce_207), - (208 , happyReduce_208), - (209 , happyReduce_209), - (210 , happyReduce_210), - (211 , happyReduce_211), - (212 , happyReduce_212), - (213 , happyReduce_213), - (214 , happyReduce_214), - (215 , happyReduce_215), - (216 , happyReduce_216), - (217 , happyReduce_217), - (218 , happyReduce_218), - (219 , happyReduce_219), - (220 , happyReduce_220), - (221 , happyReduce_221), - (222 , happyReduce_222), - (223 , happyReduce_223), - (224 , happyReduce_224), - (225 , happyReduce_225), - (226 , happyReduce_226), - (227 , happyReduce_227), - (228 , happyReduce_228), - (229 , happyReduce_229), - (230 , happyReduce_230), - (231 , happyReduce_231), - (232 , happyReduce_232), - (233 , happyReduce_233), - (234 , happyReduce_234), - (235 , happyReduce_235), - (236 , happyReduce_236), - (237 , happyReduce_237), - (238 , happyReduce_238), - (239 , happyReduce_239), - (240 , happyReduce_240), - (241 , happyReduce_241) - ] - -happy_n_terms = 83 :: Int -happy_n_nonterms = 74 :: Int - -happyReduce_4 = happySpecReduce_1 0# happyReduction_4 -happyReduction_4 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TI happy_var_1)) -> - happyIn7 - ((read happy_var_1) :: Integer - )} - -happyReduce_5 = happySpecReduce_1 1# happyReduction_5 -happyReduction_5 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TL happy_var_1)) -> - happyIn8 - (happy_var_1 - )} - -happyReduce_6 = happySpecReduce_1 2# happyReduction_6 -happyReduction_6 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TD happy_var_1)) -> - happyIn9 - ((read happy_var_1) :: Double - )} - -happyReduce_7 = happySpecReduce_1 3# happyReduction_7 -happyReduction_7 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn10 - (PIdent (mkPosToken happy_var_1) - )} - -happyReduce_8 = happySpecReduce_1 4# happyReduction_8 -happyReduction_8 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (T_LString happy_var_1)) -> - happyIn11 - (LString (happy_var_1) - )} - -happyReduce_9 = happySpecReduce_1 5# happyReduction_9 -happyReduction_9 happy_x_1 - = case happyOut13 happy_x_1 of { happy_var_1 -> - happyIn12 - (Gr (reverse happy_var_1) - )} - -happyReduce_10 = happySpecReduce_0 6# happyReduction_10 -happyReduction_10 = happyIn13 - ([] - ) - -happyReduce_11 = happySpecReduce_2 6# happyReduction_11 -happyReduction_11 happy_x_2 - happy_x_1 - = case happyOut13 happy_x_1 of { happy_var_1 -> - case happyOut14 happy_x_2 of { happy_var_2 -> - happyIn13 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_12 = happySpecReduce_2 7# happyReduction_12 -happyReduction_12 happy_x_2 - happy_x_1 - = case happyOut14 happy_x_1 of { happy_var_1 -> - happyIn14 - (happy_var_1 - )} - -happyReduce_13 = happyReduce 4# 7# happyReduction_13 -happyReduction_13 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut22 happy_x_1 of { happy_var_1 -> - case happyOut15 happy_x_2 of { happy_var_2 -> - case happyOut16 happy_x_4 of { happy_var_4 -> - happyIn14 - (MModule happy_var_1 happy_var_2 happy_var_4 - ) `HappyStk` happyRest}}} - -happyReduce_14 = happySpecReduce_2 8# happyReduction_14 -happyReduction_14 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn15 - (MAbstract happy_var_2 - )} - -happyReduce_15 = happySpecReduce_2 8# happyReduction_15 -happyReduction_15 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn15 - (MResource happy_var_2 - )} - -happyReduce_16 = happySpecReduce_2 8# happyReduction_16 -happyReduction_16 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn15 - (MGrammar happy_var_2 - )} - -happyReduce_17 = happySpecReduce_2 8# happyReduction_17 -happyReduction_17 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn15 - (MInterface happy_var_2 - )} - -happyReduce_18 = happyReduce 4# 8# happyReduction_18 -happyReduction_18 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_2 of { happy_var_2 -> - case happyOut10 happy_x_4 of { happy_var_4 -> - happyIn15 - (MConcrete happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_19 = happyReduce 4# 8# happyReduction_19 -happyReduction_19 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_2 of { happy_var_2 -> - case happyOut10 happy_x_4 of { happy_var_4 -> - happyIn15 - (MInstance happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_20 = happyReduce 5# 9# happyReduction_20 -happyReduction_20 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut18 happy_x_1 of { happy_var_1 -> - case happyOut20 happy_x_2 of { happy_var_2 -> - case happyOut17 happy_x_4 of { happy_var_4 -> - happyIn16 - (MBody happy_var_1 happy_var_2 (reverse happy_var_4) - ) `HappyStk` happyRest}}} - -happyReduce_21 = happySpecReduce_1 9# happyReduction_21 -happyReduction_21 happy_x_1 - = case happyOut23 happy_x_1 of { happy_var_1 -> - happyIn16 - (MNoBody happy_var_1 - )} - -happyReduce_22 = happySpecReduce_3 9# happyReduction_22 -happyReduction_22 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut24 happy_x_1 of { happy_var_1 -> - case happyOut19 happy_x_3 of { happy_var_3 -> - happyIn16 - (MWith happy_var_1 happy_var_3 - )}} - -happyReduce_23 = happyReduce 8# 9# happyReduction_23 -happyReduction_23 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut24 happy_x_1 of { happy_var_1 -> - case happyOut19 happy_x_3 of { happy_var_3 -> - case happyOut20 happy_x_5 of { happy_var_5 -> - case happyOut17 happy_x_7 of { happy_var_7 -> - happyIn16 - (MWithBody happy_var_1 happy_var_3 happy_var_5 (reverse happy_var_7) - ) `HappyStk` happyRest}}}} - -happyReduce_24 = happyReduce 5# 9# happyReduction_24 -happyReduction_24 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut23 happy_x_1 of { happy_var_1 -> - case happyOut24 happy_x_3 of { happy_var_3 -> - case happyOut19 happy_x_5 of { happy_var_5 -> - happyIn16 - (MWithE happy_var_1 happy_var_3 happy_var_5 - ) `HappyStk` happyRest}}} - -happyReduce_25 = happyReduce 10# 9# happyReduction_25 -happyReduction_25 (happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut23 happy_x_1 of { happy_var_1 -> - case happyOut24 happy_x_3 of { happy_var_3 -> - case happyOut19 happy_x_5 of { happy_var_5 -> - case happyOut20 happy_x_7 of { happy_var_7 -> - case happyOut17 happy_x_9 of { happy_var_9 -> - happyIn16 - (MWithEBody happy_var_1 happy_var_3 happy_var_5 happy_var_7 (reverse happy_var_9) - ) `HappyStk` happyRest}}}}} - -happyReduce_26 = happySpecReduce_2 9# happyReduction_26 -happyReduction_26 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn16 - (MReuse happy_var_2 - )} - -happyReduce_27 = happySpecReduce_2 9# happyReduction_27 -happyReduction_27 happy_x_2 - happy_x_1 - = case happyOut23 happy_x_2 of { happy_var_2 -> - happyIn16 - (MUnion happy_var_2 - )} - -happyReduce_28 = happySpecReduce_0 10# happyReduction_28 -happyReduction_28 = happyIn17 - ([] - ) - -happyReduce_29 = happySpecReduce_2 10# happyReduction_29 -happyReduction_29 happy_x_2 - happy_x_1 - = case happyOut17 happy_x_1 of { happy_var_1 -> - case happyOut25 happy_x_2 of { happy_var_2 -> - happyIn17 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_30 = happySpecReduce_2 11# happyReduction_30 -happyReduction_30 happy_x_2 - happy_x_1 - = case happyOut23 happy_x_1 of { happy_var_1 -> - happyIn18 - (Ext happy_var_1 - )} - -happyReduce_31 = happySpecReduce_0 11# happyReduction_31 -happyReduction_31 = happyIn18 - (NoExt - ) - -happyReduce_32 = happySpecReduce_0 12# happyReduction_32 -happyReduction_32 = happyIn19 - ([] - ) - -happyReduce_33 = happySpecReduce_1 12# happyReduction_33 -happyReduction_33 happy_x_1 - = case happyOut21 happy_x_1 of { happy_var_1 -> - happyIn19 - ((:[]) happy_var_1 - )} - -happyReduce_34 = happySpecReduce_3 12# happyReduction_34 -happyReduction_34 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut21 happy_x_1 of { happy_var_1 -> - case happyOut19 happy_x_3 of { happy_var_3 -> - happyIn19 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_35 = happySpecReduce_0 13# happyReduction_35 -happyReduction_35 = happyIn20 - (NoOpens - ) - -happyReduce_36 = happySpecReduce_3 13# happyReduction_36 -happyReduction_36 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut19 happy_x_2 of { happy_var_2 -> - happyIn20 - (OpenIn happy_var_2 - )} - -happyReduce_37 = happySpecReduce_1 14# happyReduction_37 -happyReduction_37 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn21 - (OName happy_var_1 - )} - -happyReduce_38 = happyReduce 5# 14# happyReduction_38 -happyReduction_38 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_2 of { happy_var_2 -> - case happyOut10 happy_x_4 of { happy_var_4 -> - happyIn21 - (OQual happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_39 = happySpecReduce_0 15# happyReduction_39 -happyReduction_39 = happyIn22 - (CMCompl - ) - -happyReduce_40 = happySpecReduce_1 15# happyReduction_40 -happyReduction_40 happy_x_1 - = happyIn22 - (CMIncompl - ) - -happyReduce_41 = happySpecReduce_0 16# happyReduction_41 -happyReduction_41 = happyIn23 - ([] - ) - -happyReduce_42 = happySpecReduce_1 16# happyReduction_42 -happyReduction_42 happy_x_1 - = case happyOut24 happy_x_1 of { happy_var_1 -> - happyIn23 - ((:[]) happy_var_1 - )} - -happyReduce_43 = happySpecReduce_3 16# happyReduction_43 -happyReduction_43 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut24 happy_x_1 of { happy_var_1 -> - case happyOut23 happy_x_3 of { happy_var_3 -> - happyIn23 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_44 = happySpecReduce_1 17# happyReduction_44 -happyReduction_44 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn24 - (IAll happy_var_1 - )} - -happyReduce_45 = happyReduce 4# 17# happyReduction_45 -happyReduction_45 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut40 happy_x_3 of { happy_var_3 -> - happyIn24 - (ISome happy_var_1 happy_var_3 - ) `HappyStk` happyRest}} - -happyReduce_46 = happyReduce 5# 17# happyReduction_46 -happyReduction_46 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut40 happy_x_4 of { happy_var_4 -> - happyIn24 - (IMinus happy_var_1 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_47 = happySpecReduce_2 18# happyReduction_47 -happyReduction_47 happy_x_2 - happy_x_1 - = case happyOut36 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefCat happy_var_2 - )} - -happyReduce_48 = happySpecReduce_2 18# happyReduction_48 -happyReduction_48 happy_x_2 - happy_x_1 - = case happyOut35 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefFun happy_var_2 - )} - -happyReduce_49 = happySpecReduce_2 18# happyReduction_49 -happyReduction_49 happy_x_2 - happy_x_1 - = case happyOut35 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefFunData happy_var_2 - )} - -happyReduce_50 = happySpecReduce_2 18# happyReduction_50 -happyReduction_50 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefDef happy_var_2 - )} - -happyReduce_51 = happySpecReduce_2 18# happyReduction_51 -happyReduction_51 happy_x_2 - happy_x_1 - = case happyOut37 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefData happy_var_2 - )} - -happyReduce_52 = happySpecReduce_2 18# happyReduction_52 -happyReduction_52 happy_x_2 - happy_x_1 - = case happyOut38 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefPar happy_var_2 - )} - -happyReduce_53 = happySpecReduce_2 18# happyReduction_53 -happyReduction_53 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefOper happy_var_2 - )} - -happyReduce_54 = happySpecReduce_2 18# happyReduction_54 -happyReduction_54 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefLincat happy_var_2 - )} - -happyReduce_55 = happySpecReduce_2 18# happyReduction_55 -happyReduction_55 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefLindef happy_var_2 - )} - -happyReduce_56 = happySpecReduce_2 18# happyReduction_56 -happyReduction_56 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefLin happy_var_2 - )} - -happyReduce_57 = happySpecReduce_3 18# happyReduction_57 -happyReduction_57 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut34 happy_x_3 of { happy_var_3 -> - happyIn25 - (DefPrintCat happy_var_3 - )} - -happyReduce_58 = happySpecReduce_3 18# happyReduction_58 -happyReduction_58 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut34 happy_x_3 of { happy_var_3 -> - happyIn25 - (DefPrintFun happy_var_3 - )} - -happyReduce_59 = happySpecReduce_2 18# happyReduction_59 -happyReduction_59 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefFlag happy_var_2 - )} - -happyReduce_60 = happySpecReduce_2 18# happyReduction_60 -happyReduction_60 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefPrintOld happy_var_2 - )} - -happyReduce_61 = happySpecReduce_2 18# happyReduction_61 -happyReduction_61 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefLintype happy_var_2 - )} - -happyReduce_62 = happySpecReduce_2 18# happyReduction_62 -happyReduction_62 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefPattern happy_var_2 - )} - -happyReduce_63 = happyReduce 7# 18# happyReduction_63 -happyReduction_63 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_2 of { happy_var_2 -> - case happyOut17 happy_x_5 of { happy_var_5 -> - happyIn25 - (DefPackage happy_var_2 (reverse happy_var_5) - ) `HappyStk` happyRest}} - -happyReduce_64 = happySpecReduce_2 18# happyReduction_64 -happyReduction_64 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefVars happy_var_2 - )} - -happyReduce_65 = happySpecReduce_3 18# happyReduction_65 -happyReduction_65 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefTokenizer happy_var_2 - )} - -happyReduce_66 = happySpecReduce_3 19# happyReduction_66 -happyReduction_66 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut42 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn26 - (DDecl happy_var_1 happy_var_3 - )}} - -happyReduce_67 = happySpecReduce_3 19# happyReduction_67 -happyReduction_67 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut42 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn26 - (DDef happy_var_1 happy_var_3 - )}} - -happyReduce_68 = happyReduce 4# 19# happyReduction_68 -happyReduction_68 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut41 happy_x_1 of { happy_var_1 -> - case happyOut61 happy_x_2 of { happy_var_2 -> - case happyOut50 happy_x_4 of { happy_var_4 -> - happyIn26 - (DPatt happy_var_1 happy_var_2 happy_var_4 - ) `HappyStk` happyRest}}} - -happyReduce_69 = happyReduce 5# 19# happyReduction_69 -happyReduction_69 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut42 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - case happyOut50 happy_x_5 of { happy_var_5 -> - happyIn26 - (DFull happy_var_1 happy_var_3 happy_var_5 - ) `HappyStk` happyRest}}} - -happyReduce_70 = happySpecReduce_3 20# happyReduction_70 -happyReduction_70 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut42 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn27 - (FDecl happy_var_1 happy_var_3 - )}} - -happyReduce_71 = happySpecReduce_2 21# happyReduction_71 -happyReduction_71 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut76 happy_x_2 of { happy_var_2 -> - happyIn28 - (SimpleCatDef happy_var_1 (reverse happy_var_2) - )}} - -happyReduce_72 = happyReduce 4# 21# happyReduction_72 -happyReduction_72 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_2 of { happy_var_2 -> - case happyOut76 happy_x_3 of { happy_var_3 -> - happyIn28 - (ListCatDef happy_var_2 (reverse happy_var_3) - ) `HappyStk` happyRest}} - -happyReduce_73 = happyReduce 7# 21# happyReduction_73 -happyReduction_73 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_2 of { happy_var_2 -> - case happyOut76 happy_x_3 of { happy_var_3 -> - case happyOut7 happy_x_6 of { happy_var_6 -> - happyIn28 - (ListSizeCatDef happy_var_2 (reverse happy_var_3) happy_var_6 - ) `HappyStk` happyRest}}} - -happyReduce_74 = happySpecReduce_3 22# happyReduction_74 -happyReduction_74 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut41 happy_x_1 of { happy_var_1 -> - case happyOut31 happy_x_3 of { happy_var_3 -> - happyIn29 - (DataDef happy_var_1 happy_var_3 - )}} - -happyReduce_75 = happySpecReduce_1 23# happyReduction_75 -happyReduction_75 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn30 - (DataId happy_var_1 - )} - -happyReduce_76 = happySpecReduce_3 23# happyReduction_76 -happyReduction_76 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut10 happy_x_3 of { happy_var_3 -> - happyIn30 - (DataQId happy_var_1 happy_var_3 - )}} - -happyReduce_77 = happySpecReduce_0 24# happyReduction_77 -happyReduction_77 = happyIn31 - ([] - ) - -happyReduce_78 = happySpecReduce_1 24# happyReduction_78 -happyReduction_78 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - happyIn31 - ((:[]) happy_var_1 - )} - -happyReduce_79 = happySpecReduce_3 24# happyReduction_79 -happyReduction_79 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - case happyOut31 happy_x_3 of { happy_var_3 -> - happyIn31 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_80 = happySpecReduce_3 25# happyReduction_80 -happyReduction_80 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut39 happy_x_3 of { happy_var_3 -> - happyIn32 - (ParDefDir happy_var_1 happy_var_3 - )}} - -happyReduce_81 = happySpecReduce_1 25# happyReduction_81 -happyReduction_81 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn32 - (ParDefAbs happy_var_1 - )} - -happyReduce_82 = happySpecReduce_2 26# happyReduction_82 -happyReduction_82 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut76 happy_x_2 of { happy_var_2 -> - happyIn33 - (ParConstr happy_var_1 (reverse happy_var_2) - )}} - -happyReduce_83 = happySpecReduce_2 27# happyReduction_83 -happyReduction_83 happy_x_2 - happy_x_1 - = case happyOut26 happy_x_1 of { happy_var_1 -> - happyIn34 - ((:[]) happy_var_1 - )} - -happyReduce_84 = happySpecReduce_3 27# happyReduction_84 -happyReduction_84 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut26 happy_x_1 of { happy_var_1 -> - case happyOut34 happy_x_3 of { happy_var_3 -> - happyIn34 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_85 = happySpecReduce_2 28# happyReduction_85 -happyReduction_85 happy_x_2 - happy_x_1 - = case happyOut27 happy_x_1 of { happy_var_1 -> - happyIn35 - ((:[]) happy_var_1 - )} - -happyReduce_86 = happySpecReduce_3 28# happyReduction_86 -happyReduction_86 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut27 happy_x_1 of { happy_var_1 -> - case happyOut35 happy_x_3 of { happy_var_3 -> - happyIn35 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_87 = happySpecReduce_2 29# happyReduction_87 -happyReduction_87 happy_x_2 - happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - happyIn36 - ((:[]) happy_var_1 - )} - -happyReduce_88 = happySpecReduce_3 29# happyReduction_88 -happyReduction_88 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - case happyOut36 happy_x_3 of { happy_var_3 -> - happyIn36 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_89 = happySpecReduce_2 30# happyReduction_89 -happyReduction_89 happy_x_2 - happy_x_1 - = case happyOut29 happy_x_1 of { happy_var_1 -> - happyIn37 - ((:[]) happy_var_1 - )} - -happyReduce_90 = happySpecReduce_3 30# happyReduction_90 -happyReduction_90 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut29 happy_x_1 of { happy_var_1 -> - case happyOut37 happy_x_3 of { happy_var_3 -> - happyIn37 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_91 = happySpecReduce_2 31# happyReduction_91 -happyReduction_91 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - happyIn38 - ((:[]) happy_var_1 - )} - -happyReduce_92 = happySpecReduce_3 31# happyReduction_92 -happyReduction_92 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut38 happy_x_3 of { happy_var_3 -> - happyIn38 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_93 = happySpecReduce_0 32# happyReduction_93 -happyReduction_93 = happyIn39 - ([] - ) - -happyReduce_94 = happySpecReduce_1 32# happyReduction_94 -happyReduction_94 happy_x_1 - = case happyOut33 happy_x_1 of { happy_var_1 -> - happyIn39 - ((:[]) happy_var_1 - )} - -happyReduce_95 = happySpecReduce_3 32# happyReduction_95 -happyReduction_95 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut33 happy_x_1 of { happy_var_1 -> - case happyOut39 happy_x_3 of { happy_var_3 -> - happyIn39 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_96 = happySpecReduce_1 33# happyReduction_96 -happyReduction_96 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn40 - ((:[]) happy_var_1 - )} - -happyReduce_97 = happySpecReduce_3 33# happyReduction_97 -happyReduction_97 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut40 happy_x_3 of { happy_var_3 -> - happyIn40 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_98 = happySpecReduce_1 34# happyReduction_98 -happyReduction_98 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn41 - (PIdentName happy_var_1 - )} - -happyReduce_99 = happySpecReduce_3 34# happyReduction_99 -happyReduction_99 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn41 - (ListName happy_var_2 - )} - -happyReduce_100 = happySpecReduce_1 35# happyReduction_100 -happyReduction_100 happy_x_1 - = case happyOut41 happy_x_1 of { happy_var_1 -> - happyIn42 - ((:[]) happy_var_1 - )} - -happyReduce_101 = happySpecReduce_3 35# happyReduction_101 -happyReduction_101 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut41 happy_x_1 of { happy_var_1 -> - case happyOut42 happy_x_3 of { happy_var_3 -> - happyIn42 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_102 = happySpecReduce_3 36# happyReduction_102 -happyReduction_102 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut40 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn43 - (LDDecl happy_var_1 happy_var_3 - )}} - -happyReduce_103 = happySpecReduce_3 36# happyReduction_103 -happyReduction_103 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut40 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn43 - (LDDef happy_var_1 happy_var_3 - )}} - -happyReduce_104 = happyReduce 5# 36# happyReduction_104 -happyReduction_104 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut40 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - case happyOut50 happy_x_5 of { happy_var_5 -> - happyIn43 - (LDFull happy_var_1 happy_var_3 happy_var_5 - ) `HappyStk` happyRest}}} - -happyReduce_105 = happySpecReduce_0 37# happyReduction_105 -happyReduction_105 = happyIn44 - ([] - ) - -happyReduce_106 = happySpecReduce_1 37# happyReduction_106 -happyReduction_106 happy_x_1 - = case happyOut43 happy_x_1 of { happy_var_1 -> - happyIn44 - ((:[]) happy_var_1 - )} - -happyReduce_107 = happySpecReduce_3 37# happyReduction_107 -happyReduction_107 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut43 happy_x_1 of { happy_var_1 -> - case happyOut44 happy_x_3 of { happy_var_3 -> - happyIn44 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_108 = happySpecReduce_1 38# happyReduction_108 -happyReduction_108 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn45 - (EPIdent happy_var_1 - )} - -happyReduce_109 = happySpecReduce_3 38# happyReduction_109 -happyReduction_109 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn45 - (EConstr happy_var_2 - )} - -happyReduce_110 = happySpecReduce_3 38# happyReduction_110 -happyReduction_110 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn45 - (ECons happy_var_2 - )} - -happyReduce_111 = happySpecReduce_1 38# happyReduction_111 -happyReduction_111 happy_x_1 - = case happyOut59 happy_x_1 of { happy_var_1 -> - happyIn45 - (ESort happy_var_1 - )} - -happyReduce_112 = happySpecReduce_1 38# happyReduction_112 -happyReduction_112 happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> - happyIn45 - (EString happy_var_1 - )} - -happyReduce_113 = happySpecReduce_1 38# happyReduction_113 -happyReduction_113 happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - happyIn45 - (EInt happy_var_1 - )} - -happyReduce_114 = happySpecReduce_1 38# happyReduction_114 -happyReduction_114 happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - happyIn45 - (EFloat happy_var_1 - )} - -happyReduce_115 = happySpecReduce_1 38# happyReduction_115 -happyReduction_115 happy_x_1 - = happyIn45 - (EMeta - ) - -happyReduce_116 = happySpecReduce_2 38# happyReduction_116 -happyReduction_116 happy_x_2 - happy_x_1 - = happyIn45 - (EEmpty - ) - -happyReduce_117 = happySpecReduce_1 38# happyReduction_117 -happyReduction_117 happy_x_1 - = happyIn45 - (EData - ) - -happyReduce_118 = happyReduce 4# 38# happyReduction_118 -happyReduction_118 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_2 of { happy_var_2 -> - case happyOut53 happy_x_3 of { happy_var_3 -> - happyIn45 - (EList happy_var_2 happy_var_3 - ) `HappyStk` happyRest}} - -happyReduce_119 = happySpecReduce_3 38# happyReduction_119 -happyReduction_119 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut8 happy_x_2 of { happy_var_2 -> - happyIn45 - (EStrings happy_var_2 - )} - -happyReduce_120 = happySpecReduce_3 38# happyReduction_120 -happyReduction_120 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut44 happy_x_2 of { happy_var_2 -> - happyIn45 - (ERecord happy_var_2 - )} - -happyReduce_121 = happySpecReduce_3 38# happyReduction_121 -happyReduction_121 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut67 happy_x_2 of { happy_var_2 -> - happyIn45 - (ETuple happy_var_2 - )} - -happyReduce_122 = happyReduce 4# 38# happyReduction_122 -happyReduction_122 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_3 of { happy_var_3 -> - happyIn45 - (EIndir happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_123 = happyReduce 5# 38# happyReduction_123 -happyReduction_123 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut50 happy_x_2 of { happy_var_2 -> - case happyOut50 happy_x_4 of { happy_var_4 -> - happyIn45 - (ETyped happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_124 = happySpecReduce_3 38# happyReduction_124 -happyReduction_124 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut50 happy_x_2 of { happy_var_2 -> - happyIn45 - (happy_var_2 - )} - -happyReduce_125 = happySpecReduce_1 38# happyReduction_125 -happyReduction_125 happy_x_1 - = case happyOut11 happy_x_1 of { happy_var_1 -> - happyIn45 - (ELString happy_var_1 - )} - -happyReduce_126 = happySpecReduce_3 39# happyReduction_126 -happyReduction_126 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut46 happy_x_1 of { happy_var_1 -> - case happyOut58 happy_x_3 of { happy_var_3 -> - happyIn46 - (EProj happy_var_1 happy_var_3 - )}} - -happyReduce_127 = happyReduce 5# 39# happyReduction_127 -happyReduction_127 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_2 of { happy_var_2 -> - case happyOut10 happy_x_4 of { happy_var_4 -> - happyIn46 - (EQConstr happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_128 = happyReduce 4# 39# happyReduction_128 -happyReduction_128 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_2 of { happy_var_2 -> - case happyOut10 happy_x_4 of { happy_var_4 -> - happyIn46 - (EQCons happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_129 = happySpecReduce_1 39# happyReduction_129 -happyReduction_129 happy_x_1 - = case happyOut45 happy_x_1 of { happy_var_1 -> - happyIn46 - (happy_var_1 - )} - -happyReduce_130 = happySpecReduce_2 40# happyReduction_130 -happyReduction_130 happy_x_2 - happy_x_1 - = case happyOut47 happy_x_1 of { happy_var_1 -> - case happyOut46 happy_x_2 of { happy_var_2 -> - happyIn47 - (EApp happy_var_1 happy_var_2 - )}} - -happyReduce_131 = happyReduce 4# 40# happyReduction_131 -happyReduction_131 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut70 happy_x_3 of { happy_var_3 -> - happyIn47 - (ETable happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_132 = happyReduce 5# 40# happyReduction_132 -happyReduction_132 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut45 happy_x_2 of { happy_var_2 -> - case happyOut70 happy_x_4 of { happy_var_4 -> - happyIn47 - (ETTable happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_133 = happyReduce 5# 40# happyReduction_133 -happyReduction_133 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut45 happy_x_2 of { happy_var_2 -> - case happyOut52 happy_x_4 of { happy_var_4 -> - happyIn47 - (EVTable happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_134 = happyReduce 6# 40# happyReduction_134 -happyReduction_134 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut50 happy_x_2 of { happy_var_2 -> - case happyOut70 happy_x_5 of { happy_var_5 -> - happyIn47 - (ECase happy_var_2 happy_var_5 - ) `HappyStk` happyRest}} - -happyReduce_135 = happyReduce 4# 40# happyReduction_135 -happyReduction_135 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut52 happy_x_3 of { happy_var_3 -> - happyIn47 - (EVariants happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_136 = happyReduce 6# 40# happyReduction_136 -happyReduction_136 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut50 happy_x_3 of { happy_var_3 -> - case happyOut74 happy_x_5 of { happy_var_5 -> - happyIn47 - (EPre happy_var_3 happy_var_5 - ) `HappyStk` happyRest}} - -happyReduce_137 = happyReduce 4# 40# happyReduction_137 -happyReduction_137 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut52 happy_x_3 of { happy_var_3 -> - happyIn47 - (EStrs happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_138 = happySpecReduce_2 40# happyReduction_138 -happyReduction_138 happy_x_2 - happy_x_1 - = case happyOut54 happy_x_2 of { happy_var_2 -> - happyIn47 - (EPatt happy_var_2 - )} - -happyReduce_139 = happySpecReduce_3 40# happyReduction_139 -happyReduction_139 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut46 happy_x_3 of { happy_var_3 -> - happyIn47 - (EPattType happy_var_3 - )} - -happyReduce_140 = happySpecReduce_1 40# happyReduction_140 -happyReduction_140 happy_x_1 - = case happyOut46 happy_x_1 of { happy_var_1 -> - happyIn47 - (happy_var_1 - )} - -happyReduce_141 = happySpecReduce_2 40# happyReduction_141 -happyReduction_141 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn47 - (ELin happy_var_2 - )} - -happyReduce_142 = happySpecReduce_3 41# happyReduction_142 -happyReduction_142 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut48 happy_x_1 of { happy_var_1 -> - case happyOut47 happy_x_3 of { happy_var_3 -> - happyIn48 - (ESelect happy_var_1 happy_var_3 - )}} - -happyReduce_143 = happySpecReduce_3 41# happyReduction_143 -happyReduction_143 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut48 happy_x_1 of { happy_var_1 -> - case happyOut47 happy_x_3 of { happy_var_3 -> - happyIn48 - (ETupTyp happy_var_1 happy_var_3 - )}} - -happyReduce_144 = happySpecReduce_3 41# happyReduction_144 -happyReduction_144 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut48 happy_x_1 of { happy_var_1 -> - case happyOut47 happy_x_3 of { happy_var_3 -> - happyIn48 - (EExtend happy_var_1 happy_var_3 - )}} - -happyReduce_145 = happySpecReduce_1 41# happyReduction_145 -happyReduction_145 happy_x_1 - = case happyOut47 happy_x_1 of { happy_var_1 -> - happyIn48 - (happy_var_1 - )} - -happyReduce_146 = happySpecReduce_3 42# happyReduction_146 -happyReduction_146 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut51 happy_x_1 of { happy_var_1 -> - case happyOut49 happy_x_3 of { happy_var_3 -> - happyIn49 - (EGlue happy_var_1 happy_var_3 - )}} - -happyReduce_147 = happySpecReduce_1 42# happyReduction_147 -happyReduction_147 happy_x_1 - = case happyOut51 happy_x_1 of { happy_var_1 -> - happyIn49 - (happy_var_1 - )} - -happyReduce_148 = happySpecReduce_3 43# happyReduction_148 -happyReduction_148 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut49 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn50 - (EConcat happy_var_1 happy_var_3 - )}} - -happyReduce_149 = happyReduce 4# 43# happyReduction_149 -happyReduction_149 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut63 happy_x_2 of { happy_var_2 -> - case happyOut50 happy_x_4 of { happy_var_4 -> - happyIn50 - (EAbstr happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_150 = happyReduce 5# 43# happyReduction_150 -happyReduction_150 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut63 happy_x_3 of { happy_var_3 -> - case happyOut50 happy_x_5 of { happy_var_5 -> - happyIn50 - (ECTable happy_var_3 happy_var_5 - ) `HappyStk` happyRest}} - -happyReduce_151 = happySpecReduce_3 43# happyReduction_151 -happyReduction_151 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut64 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn50 - (EProd happy_var_1 happy_var_3 - )}} - -happyReduce_152 = happySpecReduce_3 43# happyReduction_152 -happyReduction_152 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut48 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn50 - (ETType happy_var_1 happy_var_3 - )}} - -happyReduce_153 = happyReduce 6# 43# happyReduction_153 -happyReduction_153 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut44 happy_x_3 of { happy_var_3 -> - case happyOut50 happy_x_6 of { happy_var_6 -> - happyIn50 - (ELet happy_var_3 happy_var_6 - ) `HappyStk` happyRest}} - -happyReduce_154 = happyReduce 4# 43# happyReduction_154 -happyReduction_154 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut44 happy_x_2 of { happy_var_2 -> - case happyOut50 happy_x_4 of { happy_var_4 -> - happyIn50 - (ELetb happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_155 = happyReduce 5# 43# happyReduction_155 -happyReduction_155 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut48 happy_x_1 of { happy_var_1 -> - case happyOut44 happy_x_4 of { happy_var_4 -> - happyIn50 - (EWhere happy_var_1 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_156 = happyReduce 4# 43# happyReduction_156 -happyReduction_156 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut72 happy_x_3 of { happy_var_3 -> - happyIn50 - (EEqs happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_157 = happySpecReduce_3 43# happyReduction_157 -happyReduction_157 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut46 happy_x_2 of { happy_var_2 -> - case happyOut8 happy_x_3 of { happy_var_3 -> - happyIn50 - (EExample happy_var_2 happy_var_3 - )}} - -happyReduce_158 = happySpecReduce_1 43# happyReduction_158 -happyReduction_158 happy_x_1 - = case happyOut49 happy_x_1 of { happy_var_1 -> - happyIn50 - (happy_var_1 - )} - -happyReduce_159 = happySpecReduce_1 44# happyReduction_159 -happyReduction_159 happy_x_1 - = case happyOut48 happy_x_1 of { happy_var_1 -> - happyIn51 - (happy_var_1 - )} - -happyReduce_160 = happySpecReduce_0 45# happyReduction_160 -happyReduction_160 = happyIn52 - ([] - ) - -happyReduce_161 = happySpecReduce_1 45# happyReduction_161 -happyReduction_161 happy_x_1 - = case happyOut50 happy_x_1 of { happy_var_1 -> - happyIn52 - ((:[]) happy_var_1 - )} - -happyReduce_162 = happySpecReduce_3 45# happyReduction_162 -happyReduction_162 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut50 happy_x_1 of { happy_var_1 -> - case happyOut52 happy_x_3 of { happy_var_3 -> - happyIn52 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_163 = happySpecReduce_0 46# happyReduction_163 -happyReduction_163 = happyIn53 - (NilExp - ) - -happyReduce_164 = happySpecReduce_2 46# happyReduction_164 -happyReduction_164 happy_x_2 - happy_x_1 - = case happyOut45 happy_x_1 of { happy_var_1 -> - case happyOut53 happy_x_2 of { happy_var_2 -> - happyIn53 - (ConsExp happy_var_1 happy_var_2 - )}} - -happyReduce_165 = happySpecReduce_1 47# happyReduction_165 -happyReduction_165 happy_x_1 - = happyIn54 - (PChar - ) - -happyReduce_166 = happySpecReduce_3 47# happyReduction_166 -happyReduction_166 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut8 happy_x_2 of { happy_var_2 -> - happyIn54 - (PChars happy_var_2 - )} - -happyReduce_167 = happySpecReduce_2 47# happyReduction_167 -happyReduction_167 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn54 - (PMacro happy_var_2 - )} - -happyReduce_168 = happyReduce 4# 47# happyReduction_168 -happyReduction_168 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_2 of { happy_var_2 -> - case happyOut10 happy_x_4 of { happy_var_4 -> - happyIn54 - (PM happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_169 = happySpecReduce_1 47# happyReduction_169 -happyReduction_169 happy_x_1 - = happyIn54 - (PW - ) - -happyReduce_170 = happySpecReduce_1 47# happyReduction_170 -happyReduction_170 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn54 - (PV happy_var_1 - )} - -happyReduce_171 = happySpecReduce_3 47# happyReduction_171 -happyReduction_171 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn54 - (PCon happy_var_2 - )} - -happyReduce_172 = happySpecReduce_3 47# happyReduction_172 -happyReduction_172 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut10 happy_x_3 of { happy_var_3 -> - happyIn54 - (PQ happy_var_1 happy_var_3 - )}} - -happyReduce_173 = happySpecReduce_1 47# happyReduction_173 -happyReduction_173 happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - happyIn54 - (PInt happy_var_1 - )} - -happyReduce_174 = happySpecReduce_1 47# happyReduction_174 -happyReduction_174 happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - happyIn54 - (PFloat happy_var_1 - )} - -happyReduce_175 = happySpecReduce_1 47# happyReduction_175 -happyReduction_175 happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> - happyIn54 - (PStr happy_var_1 - )} - -happyReduce_176 = happySpecReduce_3 47# happyReduction_176 -happyReduction_176 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut60 happy_x_2 of { happy_var_2 -> - happyIn54 - (PR happy_var_2 - )} - -happyReduce_177 = happySpecReduce_3 47# happyReduction_177 -happyReduction_177 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut68 happy_x_2 of { happy_var_2 -> - happyIn54 - (PTup happy_var_2 - )} - -happyReduce_178 = happySpecReduce_3 47# happyReduction_178 -happyReduction_178 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut56 happy_x_2 of { happy_var_2 -> - happyIn54 - (happy_var_2 - )} - -happyReduce_179 = happySpecReduce_2 48# happyReduction_179 -happyReduction_179 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut61 happy_x_2 of { happy_var_2 -> - happyIn55 - (PC happy_var_1 happy_var_2 - )}} - -happyReduce_180 = happyReduce 4# 48# happyReduction_180 -happyReduction_180 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut10 happy_x_3 of { happy_var_3 -> - case happyOut61 happy_x_4 of { happy_var_4 -> - happyIn55 - (PQC happy_var_1 happy_var_3 happy_var_4 - ) `HappyStk` happyRest}}} - -happyReduce_181 = happySpecReduce_2 48# happyReduction_181 -happyReduction_181 happy_x_2 - happy_x_1 - = case happyOut54 happy_x_1 of { happy_var_1 -> - happyIn55 - (PRep happy_var_1 - )} - -happyReduce_182 = happySpecReduce_3 48# happyReduction_182 -happyReduction_182 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut54 happy_x_3 of { happy_var_3 -> - happyIn55 - (PAs happy_var_1 happy_var_3 - )}} - -happyReduce_183 = happySpecReduce_2 48# happyReduction_183 -happyReduction_183 happy_x_2 - happy_x_1 - = case happyOut54 happy_x_2 of { happy_var_2 -> - happyIn55 - (PNeg happy_var_2 - )} - -happyReduce_184 = happySpecReduce_1 48# happyReduction_184 -happyReduction_184 happy_x_1 - = case happyOut54 happy_x_1 of { happy_var_1 -> - happyIn55 - (happy_var_1 - )} - -happyReduce_185 = happySpecReduce_3 49# happyReduction_185 -happyReduction_185 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut56 happy_x_1 of { happy_var_1 -> - case happyOut55 happy_x_3 of { happy_var_3 -> - happyIn56 - (PDisj happy_var_1 happy_var_3 - )}} - -happyReduce_186 = happySpecReduce_3 49# happyReduction_186 -happyReduction_186 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut56 happy_x_1 of { happy_var_1 -> - case happyOut55 happy_x_3 of { happy_var_3 -> - happyIn56 - (PSeq happy_var_1 happy_var_3 - )}} - -happyReduce_187 = happySpecReduce_1 49# happyReduction_187 -happyReduction_187 happy_x_1 - = case happyOut55 happy_x_1 of { happy_var_1 -> - happyIn56 - (happy_var_1 - )} - -happyReduce_188 = happySpecReduce_3 50# happyReduction_188 -happyReduction_188 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut40 happy_x_1 of { happy_var_1 -> - case happyOut56 happy_x_3 of { happy_var_3 -> - happyIn57 - (PA happy_var_1 happy_var_3 - )}} - -happyReduce_189 = happySpecReduce_1 51# happyReduction_189 -happyReduction_189 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn58 - (LPIdent happy_var_1 - )} - -happyReduce_190 = happySpecReduce_2 51# happyReduction_190 -happyReduction_190 happy_x_2 - happy_x_1 - = case happyOut7 happy_x_2 of { happy_var_2 -> - happyIn58 - (LVar happy_var_2 - )} - -happyReduce_191 = happySpecReduce_1 52# happyReduction_191 -happyReduction_191 happy_x_1 - = happyIn59 - (Sort_Type - ) - -happyReduce_192 = happySpecReduce_1 52# happyReduction_192 -happyReduction_192 happy_x_1 - = happyIn59 - (Sort_PType - ) - -happyReduce_193 = happySpecReduce_1 52# happyReduction_193 -happyReduction_193 happy_x_1 - = happyIn59 - (Sort_Tok - ) - -happyReduce_194 = happySpecReduce_1 52# happyReduction_194 -happyReduction_194 happy_x_1 - = happyIn59 - (Sort_Str - ) - -happyReduce_195 = happySpecReduce_1 52# happyReduction_195 -happyReduction_195 happy_x_1 - = happyIn59 - (Sort_Strs - ) - -happyReduce_196 = happySpecReduce_0 53# happyReduction_196 -happyReduction_196 = happyIn60 - ([] - ) - -happyReduce_197 = happySpecReduce_1 53# happyReduction_197 -happyReduction_197 happy_x_1 - = case happyOut57 happy_x_1 of { happy_var_1 -> - happyIn60 - ((:[]) happy_var_1 - )} - -happyReduce_198 = happySpecReduce_3 53# happyReduction_198 -happyReduction_198 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut57 happy_x_1 of { happy_var_1 -> - case happyOut60 happy_x_3 of { happy_var_3 -> - happyIn60 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_199 = happySpecReduce_1 54# happyReduction_199 -happyReduction_199 happy_x_1 - = case happyOut54 happy_x_1 of { happy_var_1 -> - happyIn61 - ((:[]) happy_var_1 - )} - -happyReduce_200 = happySpecReduce_2 54# happyReduction_200 -happyReduction_200 happy_x_2 - happy_x_1 - = case happyOut54 happy_x_1 of { happy_var_1 -> - case happyOut61 happy_x_2 of { happy_var_2 -> - happyIn61 - ((:) happy_var_1 happy_var_2 - )}} - -happyReduce_201 = happySpecReduce_1 55# happyReduction_201 -happyReduction_201 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn62 - (BPIdent happy_var_1 - )} - -happyReduce_202 = happySpecReduce_1 55# happyReduction_202 -happyReduction_202 happy_x_1 - = happyIn62 - (BWild - ) - -happyReduce_203 = happySpecReduce_0 56# happyReduction_203 -happyReduction_203 = happyIn63 - ([] - ) - -happyReduce_204 = happySpecReduce_1 56# happyReduction_204 -happyReduction_204 happy_x_1 - = case happyOut62 happy_x_1 of { happy_var_1 -> - happyIn63 - ((:[]) happy_var_1 - )} - -happyReduce_205 = happySpecReduce_3 56# happyReduction_205 -happyReduction_205 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut62 happy_x_1 of { happy_var_1 -> - case happyOut63 happy_x_3 of { happy_var_3 -> - happyIn63 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_206 = happyReduce 5# 57# happyReduction_206 -happyReduction_206 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut63 happy_x_2 of { happy_var_2 -> - case happyOut50 happy_x_4 of { happy_var_4 -> - happyIn64 - (DDec happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_207 = happySpecReduce_1 57# happyReduction_207 -happyReduction_207 happy_x_1 - = case happyOut47 happy_x_1 of { happy_var_1 -> - happyIn64 - (DExp happy_var_1 - )} - -happyReduce_208 = happySpecReduce_1 58# happyReduction_208 -happyReduction_208 happy_x_1 - = case happyOut50 happy_x_1 of { happy_var_1 -> - happyIn65 - (TComp happy_var_1 - )} - -happyReduce_209 = happySpecReduce_1 59# happyReduction_209 -happyReduction_209 happy_x_1 - = case happyOut56 happy_x_1 of { happy_var_1 -> - happyIn66 - (PTComp happy_var_1 - )} - -happyReduce_210 = happySpecReduce_0 60# happyReduction_210 -happyReduction_210 = happyIn67 - ([] - ) - -happyReduce_211 = happySpecReduce_1 60# happyReduction_211 -happyReduction_211 happy_x_1 - = case happyOut65 happy_x_1 of { happy_var_1 -> - happyIn67 - ((:[]) happy_var_1 - )} - -happyReduce_212 = happySpecReduce_3 60# happyReduction_212 -happyReduction_212 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut65 happy_x_1 of { happy_var_1 -> - case happyOut67 happy_x_3 of { happy_var_3 -> - happyIn67 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_213 = happySpecReduce_0 61# happyReduction_213 -happyReduction_213 = happyIn68 - ([] - ) - -happyReduce_214 = happySpecReduce_1 61# happyReduction_214 -happyReduction_214 happy_x_1 - = case happyOut66 happy_x_1 of { happy_var_1 -> - happyIn68 - ((:[]) happy_var_1 - )} - -happyReduce_215 = happySpecReduce_3 61# happyReduction_215 -happyReduction_215 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut66 happy_x_1 of { happy_var_1 -> - case happyOut68 happy_x_3 of { happy_var_3 -> - happyIn68 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_216 = happySpecReduce_3 62# happyReduction_216 -happyReduction_216 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut56 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn69 - (Case happy_var_1 happy_var_3 - )}} - -happyReduce_217 = happySpecReduce_1 63# happyReduction_217 -happyReduction_217 happy_x_1 - = case happyOut69 happy_x_1 of { happy_var_1 -> - happyIn70 - ((:[]) happy_var_1 - )} - -happyReduce_218 = happySpecReduce_3 63# happyReduction_218 -happyReduction_218 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut69 happy_x_1 of { happy_var_1 -> - case happyOut70 happy_x_3 of { happy_var_3 -> - happyIn70 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_219 = happySpecReduce_3 64# happyReduction_219 -happyReduction_219 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut61 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn71 - (Equ happy_var_1 happy_var_3 - )}} - -happyReduce_220 = happySpecReduce_0 65# happyReduction_220 -happyReduction_220 = happyIn72 - ([] - ) - -happyReduce_221 = happySpecReduce_1 65# happyReduction_221 -happyReduction_221 happy_x_1 - = case happyOut71 happy_x_1 of { happy_var_1 -> - happyIn72 - ((:[]) happy_var_1 - )} - -happyReduce_222 = happySpecReduce_3 65# happyReduction_222 -happyReduction_222 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut71 happy_x_1 of { happy_var_1 -> - case happyOut72 happy_x_3 of { happy_var_3 -> - happyIn72 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_223 = happySpecReduce_3 66# happyReduction_223 -happyReduction_223 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut50 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn73 - (Alt happy_var_1 happy_var_3 - )}} - -happyReduce_224 = happySpecReduce_0 67# happyReduction_224 -happyReduction_224 = happyIn74 - ([] - ) - -happyReduce_225 = happySpecReduce_1 67# happyReduction_225 -happyReduction_225 happy_x_1 - = case happyOut73 happy_x_1 of { happy_var_1 -> - happyIn74 - ((:[]) happy_var_1 - )} - -happyReduce_226 = happySpecReduce_3 67# happyReduction_226 -happyReduction_226 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut73 happy_x_1 of { happy_var_1 -> - case happyOut74 happy_x_3 of { happy_var_3 -> - happyIn74 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_227 = happyReduce 5# 68# happyReduction_227 -happyReduction_227 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut63 happy_x_2 of { happy_var_2 -> - case happyOut50 happy_x_4 of { happy_var_4 -> - happyIn75 - (DDDec happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_228 = happySpecReduce_1 68# happyReduction_228 -happyReduction_228 happy_x_1 - = case happyOut45 happy_x_1 of { happy_var_1 -> - happyIn75 - (DDExp happy_var_1 - )} - -happyReduce_229 = happySpecReduce_0 69# happyReduction_229 -happyReduction_229 = happyIn76 - ([] - ) - -happyReduce_230 = happySpecReduce_2 69# happyReduction_230 -happyReduction_230 happy_x_2 - happy_x_1 - = case happyOut76 happy_x_1 of { happy_var_1 -> - case happyOut75 happy_x_2 of { happy_var_2 -> - happyIn76 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_231 = happySpecReduce_2 70# happyReduction_231 -happyReduction_231 happy_x_2 - happy_x_1 - = case happyOut78 happy_x_1 of { happy_var_1 -> - case happyOut17 happy_x_2 of { happy_var_2 -> - happyIn77 - (OldGr happy_var_1 (reverse happy_var_2) - )}} - -happyReduce_232 = happySpecReduce_0 71# happyReduction_232 -happyReduction_232 = happyIn78 - (NoIncl - ) - -happyReduce_233 = happySpecReduce_2 71# happyReduction_233 -happyReduction_233 happy_x_2 - happy_x_1 - = case happyOut80 happy_x_2 of { happy_var_2 -> - happyIn78 - (Incl happy_var_2 - )} - -happyReduce_234 = happySpecReduce_1 72# happyReduction_234 -happyReduction_234 happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> - happyIn79 - (FString happy_var_1 - )} - -happyReduce_235 = happySpecReduce_1 72# happyReduction_235 -happyReduction_235 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn79 - (FPIdent happy_var_1 - )} - -happyReduce_236 = happySpecReduce_2 72# happyReduction_236 -happyReduction_236 happy_x_2 - happy_x_1 - = case happyOut79 happy_x_2 of { happy_var_2 -> - happyIn79 - (FSlash happy_var_2 - )} - -happyReduce_237 = happySpecReduce_2 72# happyReduction_237 -happyReduction_237 happy_x_2 - happy_x_1 - = case happyOut79 happy_x_2 of { happy_var_2 -> - happyIn79 - (FDot happy_var_2 - )} - -happyReduce_238 = happySpecReduce_2 72# happyReduction_238 -happyReduction_238 happy_x_2 - happy_x_1 - = case happyOut79 happy_x_2 of { happy_var_2 -> - happyIn79 - (FMinus happy_var_2 - )} - -happyReduce_239 = happySpecReduce_2 72# happyReduction_239 -happyReduction_239 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut79 happy_x_2 of { happy_var_2 -> - happyIn79 - (FAddId happy_var_1 happy_var_2 - )}} - -happyReduce_240 = happySpecReduce_2 73# happyReduction_240 -happyReduction_240 happy_x_2 - happy_x_1 - = case happyOut79 happy_x_1 of { happy_var_1 -> - happyIn80 - ((:[]) happy_var_1 - )} - -happyReduce_241 = happySpecReduce_3 73# happyReduction_241 -happyReduction_241 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut79 happy_x_1 of { happy_var_1 -> - case happyOut80 happy_x_3 of { happy_var_3 -> - happyIn80 - ((:) happy_var_1 happy_var_3 - )}} - -happyNewToken action sts stk [] = - happyDoAction 82# notHappyAtAll action sts stk [] - -happyNewToken action sts stk (tk:tks) = - let cont i = happyDoAction i tk action sts stk tks in - case tk of { - PT _ (TS ";") -> cont 1#; - PT _ (TS "=") -> cont 2#; - PT _ (TS "{") -> cont 3#; - PT _ (TS "}") -> cont 4#; - PT _ (TS "**") -> cont 5#; - PT _ (TS ",") -> cont 6#; - PT _ (TS "(") -> cont 7#; - PT _ (TS ")") -> cont 8#; - PT _ (TS "[") -> cont 9#; - PT _ (TS "]") -> cont 10#; - PT _ (TS "-") -> cont 11#; - PT _ (TS ":") -> cont 12#; - PT _ (TS ".") -> cont 13#; - PT _ (TS "|") -> cont 14#; - PT _ (TS "%") -> cont 15#; - PT _ (TS "?") -> cont 16#; - PT _ (TS "<") -> cont 17#; - PT _ (TS ">") -> cont 18#; - PT _ (TS "!") -> cont 19#; - PT _ (TS "*") -> cont 20#; - PT _ (TS "+") -> cont 21#; - PT _ (TS "++") -> cont 22#; - PT _ (TS "\\") -> cont 23#; - PT _ (TS "->") -> cont 24#; - PT _ (TS "=>") -> cont 25#; - PT _ (TS "#") -> cont 26#; - PT _ (TS "_") -> cont 27#; - PT _ (TS "@") -> cont 28#; - PT _ (TS "$") -> cont 29#; - PT _ (TS "/") -> cont 30#; - PT _ (TS "Lin") -> cont 31#; - PT _ (TS "PType") -> cont 32#; - PT _ (TS "Str") -> cont 33#; - PT _ (TS "Strs") -> cont 34#; - PT _ (TS "Tok") -> cont 35#; - PT _ (TS "Type") -> cont 36#; - PT _ (TS "abstract") -> cont 37#; - PT _ (TS "case") -> cont 38#; - PT _ (TS "cat") -> cont 39#; - PT _ (TS "concrete") -> cont 40#; - PT _ (TS "data") -> cont 41#; - PT _ (TS "def") -> cont 42#; - PT _ (TS "flags") -> cont 43#; - PT _ (TS "fn") -> cont 44#; - PT _ (TS "fun") -> cont 45#; - PT _ (TS "grammar") -> cont 46#; - PT _ (TS "in") -> cont 47#; - PT _ (TS "include") -> cont 48#; - PT _ (TS "incomplete") -> cont 49#; - PT _ (TS "instance") -> cont 50#; - PT _ (TS "interface") -> cont 51#; - PT _ (TS "let") -> cont 52#; - PT _ (TS "lin") -> cont 53#; - PT _ (TS "lincat") -> cont 54#; - PT _ (TS "lindef") -> cont 55#; - PT _ (TS "lintype") -> cont 56#; - PT _ (TS "of") -> cont 57#; - PT _ (TS "open") -> cont 58#; - PT _ (TS "oper") -> cont 59#; - PT _ (TS "package") -> cont 60#; - PT _ (TS "param") -> cont 61#; - PT _ (TS "pattern") -> cont 62#; - PT _ (TS "pre") -> cont 63#; - PT _ (TS "printname") -> cont 64#; - PT _ (TS "resource") -> cont 65#; - PT _ (TS "reuse") -> cont 66#; - PT _ (TS "strs") -> cont 67#; - PT _ (TS "table") -> cont 68#; - PT _ (TS "tokenizer") -> cont 69#; - PT _ (TS "type") -> cont 70#; - PT _ (TS "union") -> cont 71#; - PT _ (TS "var") -> cont 72#; - PT _ (TS "variants") -> cont 73#; - PT _ (TS "where") -> cont 74#; - PT _ (TS "with") -> cont 75#; - PT _ (TI happy_dollar_dollar) -> cont 76#; - PT _ (TL happy_dollar_dollar) -> cont 77#; - PT _ (TD happy_dollar_dollar) -> cont 78#; - PT _ (T_PIdent _) -> cont 79#; - PT _ (T_LString happy_dollar_dollar) -> cont 80#; - _ -> cont 81#; - _ -> happyError' (tk:tks) - } - -happyError_ tk tks = happyError' (tk:tks) - -happyThen :: () => Err a -> (a -> Err b) -> Err b -happyThen = (thenM) -happyReturn :: () => a -> Err a -happyReturn = (returnM) -happyThen1 m k tks = (thenM) m (\a -> k a tks) -happyReturn1 :: () => a -> b -> Err a -happyReturn1 = \a tks -> (returnM) a -happyError' :: () => [Token] -> Err a -happyError' = happyError - -pGrammar tks = happySomeParser where - happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut12 x)) - -pModDef tks = happySomeParser where - happySomeParser = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut14 x)) - -pOldGrammar tks = happySomeParser where - happySomeParser = happyThen (happyParse 2# tks) (\x -> happyReturn (happyOut77 x)) - -pExp tks = happySomeParser where - happySomeParser = happyThen (happyParse 3# tks) (\x -> happyReturn (happyOut50 x)) - -happySeq = happyDontSeq - - -returnM :: a -> Err a -returnM = return - -thenM :: Err a -> (a -> Err b) -> Err b -thenM = (>>=) - -happyError :: [Token] -> Err a -happyError ts = - Bad $ "syntax error at " ++ tokenPos ts ++ - case ts of - [] -> [] - [Err _] -> " due to lexer error" - _ -> " before " ++ unwords (map prToken (take 4 ts)) - -myLexer = tokens -{-# LINE 1 "GenericTemplate.hs" #-} -{-# LINE 1 "<built-in>" #-} -{-# LINE 1 "<command line>" #-} -{-# LINE 1 "GenericTemplate.hs" #-} --- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp - -{-# LINE 28 "GenericTemplate.hs" #-} - - -data Happy_IntList = HappyCons Int# Happy_IntList - - - - - -{-# LINE 49 "GenericTemplate.hs" #-} - -{-# LINE 59 "GenericTemplate.hs" #-} - -{-# LINE 68 "GenericTemplate.hs" #-} - -infixr 9 `HappyStk` -data HappyStk a = HappyStk a (HappyStk a) - ------------------------------------------------------------------------------ --- starting the parse - -happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll - ------------------------------------------------------------------------------ --- Accepting the parse - --- If the current token is 0#, it means we've just accepted a partial --- parse (a %partial parser). We must ignore the saved token on the top of --- the stack in this case. -happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans) - ------------------------------------------------------------------------------ --- Arrays only: do the next action - - - -happyDoAction i tk st - = {- nothing -} - - - case action of - 0# -> {- nothing -} - happyFail i tk st - -1# -> {- nothing -} - happyAccept i tk st - n | (n <# (0# :: Int#)) -> {- nothing -} - - (happyReduceArr ! rule) i tk st - where rule = (I# ((negateInt# ((n +# (1# :: Int#)))))) - n -> {- nothing -} - - - happyShift new_state i tk st - where new_state = (n -# (1# :: Int#)) - where off = indexShortOffAddr happyActOffsets st - off_i = (off +# i) - check = if (off_i >=# (0# :: Int#)) - then (indexShortOffAddr happyCheck off_i ==# i) - else False - action | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st - -{-# LINE 127 "GenericTemplate.hs" #-} - - -indexShortOffAddr (HappyA# arr) off = -#if __GLASGOW_HASKELL__ > 500 - narrow16Int# i -#elif __GLASGOW_HASKELL__ == 500 - intToInt16# i -#else - (i `iShiftL#` 16#) `iShiftRA#` 16# -#endif - where -#if __GLASGOW_HASKELL__ >= 503 - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) -#else - i = word2Int# ((high `shiftL#` 8#) `or#` low) -#endif - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# - - - - - -data HappyAddr = HappyA# Addr# - - - - ------------------------------------------------------------------------------ --- HappyState data type (not arrays) - -{-# LINE 170 "GenericTemplate.hs" #-} - ------------------------------------------------------------------------------ --- Shifting a token - -happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in --- trace "shifting the error token" $ - happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) - -happyShift new_state i tk st sts stk = - happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) - --- happyReduce is specialised for the common cases. - -happySpecReduce_0 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_0 nt fn j tk st@((action)) sts stk - = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k -# (1# :: Int#)) sts of - sts1@((HappyCons (st1@(action)) (_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (happyGoto nt j tk st1 sts1 r) - -happyMonadReduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonadReduce k nt fn j tk st sts stk = - happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) - drop_stk = happyDropStk k stk - -happyMonad2Reduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonad2Reduce k nt fn j tk st sts stk = - happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) - where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) - drop_stk = happyDropStk k stk - - off = indexShortOffAddr happyGotoOffsets st1 - off_i = (off +# nt) - new_state = indexShortOffAddr happyTable off_i - - - - -happyDrop 0# l = l -happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t - -happyDropStk 0# l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs - ------------------------------------------------------------------------------ --- Moving to a new state after a reduction - - -happyGoto nt j tk st = - {- nothing -} - happyDoAction j tk new_state - where off = indexShortOffAddr happyGotoOffsets st - off_i = (off +# nt) - new_state = indexShortOffAddr happyTable off_i - - - - ------------------------------------------------------------------------------ --- Error recovery (0# is the error token) - --- parse error if we are in recovery and we fail again -happyFail 0# tk old_st _ stk = --- trace "failing" $ - happyError_ tk - -{- We don't need state discarding for our restricted implementation of - "error". In fact, it can cause some bogus parses, so I've disabled it - for now --SDM - --- discard a state -happyFail 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) --} - --- Enter error recovery: generate an error token, --- save the old token and carry on. -happyFail i tk (action) sts stk = --- trace "entering error recovery" $ - happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk) - --- Internal happy errors: - -notHappyAtAll = error "Internal Happy error\n" - ------------------------------------------------------------------------------ --- Hack to get the typechecker to accept our action functions - - -happyTcHack :: Int# -> a -> a -happyTcHack x y = y -{-# INLINE happyTcHack #-} - - ------------------------------------------------------------------------------ --- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq --- otherwise it emits --- happySeq = happyDontSeq - -happyDoSeq, happyDontSeq :: a -> b -> b -happyDoSeq a b = a `seq` b -happyDontSeq a b = b - ------------------------------------------------------------------------------ --- Don't inline any functions from the template. GHC has a nasty habit --- of deciding to inline happyGoto everywhere, which increases the size of --- the generated parser quite a bit. - - -{-# NOINLINE happyDoAction #-} -{-# NOINLINE happyTable #-} -{-# NOINLINE happyCheck #-} -{-# NOINLINE happyActOffsets #-} -{-# NOINLINE happyGotoOffsets #-} -{-# NOINLINE happyDefActions #-} - -{-# NOINLINE happyShift #-} -{-# NOINLINE happySpecReduce_0 #-} -{-# NOINLINE happySpecReduce_1 #-} -{-# NOINLINE happySpecReduce_2 #-} -{-# NOINLINE happySpecReduce_3 #-} -{-# NOINLINE happyReduce #-} -{-# NOINLINE happyMonadReduce #-} -{-# NOINLINE happyGoto #-} -{-# NOINLINE happyFail #-} - --- end of Happy Template. diff --git a/src/GF/Devel/Compile/PrintGF.hs b/src/GF/Devel/Compile/PrintGF.hs deleted file mode 100644 index 7eb63612a..000000000 --- a/src/GF/Devel/Compile/PrintGF.hs +++ /dev/null @@ -1,481 +0,0 @@ -{-# OPTIONS -fno-warn-incomplete-patterns #-} -module GF.Devel.Compile.PrintGF where - --- pretty-printer generated by the BNF converter - -import GF.Devel.Compile.AbsGF -import Char - --- the top-level printing method -printTree :: Print a => a -> String -printTree = render . prt 0 - -type Doc = [ShowS] -> [ShowS] - -doc :: ShowS -> Doc -doc = (:) - -render :: Doc -> String -render d = rend 0 (map ($ "") $ d []) "" where - rend i ss = case ss of - "[" :ts -> showChar '[' . rend i ts - "(" :ts -> showChar '(' . rend i ts - "{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts - "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts - "}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts - ";" :ts -> showChar ';' . new i . rend i ts - t : "," :ts -> showString t . space "," . rend i ts - t : ")" :ts -> showString t . showChar ')' . rend i ts - t : "]" :ts -> showString t . showChar ']' . rend i ts - t :ts -> space t . rend i ts - _ -> id - new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace - space t = showString t . (\s -> if null s then "" else (' ':s)) - -parenth :: Doc -> Doc -parenth ss = doc (showChar '(') . ss . doc (showChar ')') - -concatS :: [ShowS] -> ShowS -concatS = foldr (.) id - -concatD :: [Doc] -> Doc -concatD = foldr (.) id - -replicateS :: Int -> ShowS -> ShowS -replicateS n f = concatS (replicate n f) - --- the printer class does the job -class Print a where - prt :: Int -> a -> Doc - prtList :: [a] -> Doc - prtList = concatD . map (prt 0) - -instance Print a => Print [a] where - prt _ = prtList - -instance Print Char where - prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'') - prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"') - -mkEsc :: Char -> Char -> ShowS -mkEsc q s = case s of - _ | s == q -> showChar '\\' . showChar s - '\\'-> showString "\\\\" - '\n' -> showString "\\n" - '\t' -> showString "\\t" - _ -> showChar s - -prPrec :: Int -> Int -> Doc -> Doc -prPrec i j = if j<i then parenth else id - - -instance Print Integer where - prt _ x = doc (shows x) - - -instance Print Double where - prt _ x = doc (shows x) - - - -instance Print PIdent where - prt _ (PIdent (_,i)) = doc (showString i) - prtList es = case es of - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - - -instance Print LString where - prt _ (LString i) = doc (showString i) - - - -instance Print Grammar where - prt i e = case e of - Gr moddefs -> prPrec i 0 (concatD [prt 0 moddefs]) - - -instance Print ModDef where - prt i e = case e of - MModule complmod modtype modbody -> prPrec i 0 (concatD [prt 0 complmod , prt 0 modtype , doc (showString "=") , prt 0 modbody]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , prt 0 xs]) - -instance Print ModType where - prt i e = case e of - MAbstract pident -> prPrec i 0 (concatD [doc (showString "abstract") , prt 0 pident]) - MResource pident -> prPrec i 0 (concatD [doc (showString "resource") , prt 0 pident]) - MGrammar pident -> prPrec i 0 (concatD [doc (showString "grammar") , prt 0 pident]) - MInterface pident -> prPrec i 0 (concatD [doc (showString "interface") , prt 0 pident]) - MConcrete pident0 pident -> prPrec i 0 (concatD [doc (showString "concrete") , prt 0 pident0 , doc (showString "of") , prt 0 pident]) - MInstance pident0 pident -> prPrec i 0 (concatD [doc (showString "instance") , prt 0 pident0 , doc (showString "of") , prt 0 pident]) - - -instance Print ModBody where - prt i e = case e of - MBody extend opens topdefs -> prPrec i 0 (concatD [prt 0 extend , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")]) - MNoBody includeds -> prPrec i 0 (concatD [prt 0 includeds]) - MWith included opens -> prPrec i 0 (concatD [prt 0 included , doc (showString "with") , prt 0 opens]) - MWithBody included opens0 opens topdefs -> prPrec i 0 (concatD [prt 0 included , doc (showString "with") , prt 0 opens0 , doc (showString "**") , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")]) - MWithE includeds included opens -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 included , doc (showString "with") , prt 0 opens]) - MWithEBody includeds included opens0 opens topdefs -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 included , doc (showString "with") , prt 0 opens0 , doc (showString "**") , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")]) - MReuse pident -> prPrec i 0 (concatD [doc (showString "reuse") , prt 0 pident]) - MUnion includeds -> prPrec i 0 (concatD [doc (showString "union") , prt 0 includeds]) - - -instance Print Extend where - prt i e = case e of - Ext includeds -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**")]) - NoExt -> prPrec i 0 (concatD []) - - -instance Print Opens where - prt i e = case e of - NoOpens -> prPrec i 0 (concatD []) - OpenIn opens -> prPrec i 0 (concatD [doc (showString "open") , prt 0 opens , doc (showString "in")]) - - -instance Print Open where - prt i e = case e of - OName pident -> prPrec i 0 (concatD [prt 0 pident]) - OQual pident0 pident -> prPrec i 0 (concatD [doc (showString "(") , prt 0 pident0 , doc (showString "=") , prt 0 pident , doc (showString ")")]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print ComplMod where - prt i e = case e of - CMCompl -> prPrec i 0 (concatD []) - CMIncompl -> prPrec i 0 (concatD [doc (showString "incomplete")]) - - -instance Print Included where - prt i e = case e of - IAll pident -> prPrec i 0 (concatD [prt 0 pident]) - ISome pident pidents -> prPrec i 0 (concatD [prt 0 pident , doc (showString "[") , prt 0 pidents , doc (showString "]")]) - IMinus pident pidents -> prPrec i 0 (concatD [prt 0 pident , doc (showString "-") , doc (showString "[") , prt 0 pidents , doc (showString "]")]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print TopDef where - prt i e = case e of - DefCat catdefs -> prPrec i 0 (concatD [doc (showString "cat") , prt 0 catdefs]) - DefFun fundefs -> prPrec i 0 (concatD [doc (showString "fun") , prt 0 fundefs]) - DefFunData fundefs -> prPrec i 0 (concatD [doc (showString "data") , prt 0 fundefs]) - DefDef defs -> prPrec i 0 (concatD [doc (showString "def") , prt 0 defs]) - DefData datadefs -> prPrec i 0 (concatD [doc (showString "data") , prt 0 datadefs]) - DefPar pardefs -> prPrec i 0 (concatD [doc (showString "param") , prt 0 pardefs]) - DefOper defs -> prPrec i 0 (concatD [doc (showString "oper") , prt 0 defs]) - DefLincat defs -> prPrec i 0 (concatD [doc (showString "lincat") , prt 0 defs]) - DefLindef defs -> prPrec i 0 (concatD [doc (showString "lindef") , prt 0 defs]) - DefLin defs -> prPrec i 0 (concatD [doc (showString "lin") , prt 0 defs]) - DefPrintCat defs -> prPrec i 0 (concatD [doc (showString "printname") , doc (showString "cat") , prt 0 defs]) - DefPrintFun defs -> prPrec i 0 (concatD [doc (showString "printname") , doc (showString "fun") , prt 0 defs]) - DefFlag defs -> prPrec i 0 (concatD [doc (showString "flags") , prt 0 defs]) - DefPrintOld defs -> prPrec i 0 (concatD [doc (showString "printname") , prt 0 defs]) - DefLintype defs -> prPrec i 0 (concatD [doc (showString "lintype") , prt 0 defs]) - DefPattern defs -> prPrec i 0 (concatD [doc (showString "pattern") , prt 0 defs]) - DefPackage pident topdefs -> prPrec i 0 (concatD [doc (showString "package") , prt 0 pident , doc (showString "=") , doc (showString "{") , prt 0 topdefs , doc (showString "}") , doc (showString ";")]) - DefVars defs -> prPrec i 0 (concatD [doc (showString "var") , prt 0 defs]) - DefTokenizer pident -> prPrec i 0 (concatD [doc (showString "tokenizer") , prt 0 pident , doc (showString ";")]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , prt 0 xs]) - -instance Print Def where - prt i e = case e of - DDecl names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString ":") , prt 0 exp]) - DDef names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString "=") , prt 0 exp]) - DPatt name patts exp -> prPrec i 0 (concatD [prt 0 name , prt 0 patts , doc (showString "=") , prt 0 exp]) - DFull names exp0 exp -> prPrec i 0 (concatD [prt 0 names , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp]) - - prtList es = case es of - [x] -> (concatD [prt 0 x , doc (showString ";")]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print FunDef where - prt i e = case e of - FDecl names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString ":") , prt 0 exp]) - - prtList es = case es of - [x] -> (concatD [prt 0 x , doc (showString ";")]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print CatDef where - prt i e = case e of - SimpleCatDef pident ddecls -> prPrec i 0 (concatD [prt 0 pident , prt 0 ddecls]) - ListCatDef pident ddecls -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , prt 0 ddecls , doc (showString "]")]) - ListSizeCatDef pident ddecls n -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , prt 0 ddecls , doc (showString "]") , doc (showString "{") , prt 0 n , doc (showString "}")]) - - prtList es = case es of - [x] -> (concatD [prt 0 x , doc (showString ";")]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print DataDef where - prt i e = case e of - DataDef name dataconstrs -> prPrec i 0 (concatD [prt 0 name , doc (showString "=") , prt 0 dataconstrs]) - - prtList es = case es of - [x] -> (concatD [prt 0 x , doc (showString ";")]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print DataConstr where - prt i e = case e of - DataId pident -> prPrec i 0 (concatD [prt 0 pident]) - DataQId pident0 pident -> prPrec i 0 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs]) - -instance Print ParDef where - prt i e = case e of - ParDefDir pident parconstrs -> prPrec i 0 (concatD [prt 0 pident , doc (showString "=") , prt 0 parconstrs]) - ParDefAbs pident -> prPrec i 0 (concatD [prt 0 pident]) - - prtList es = case es of - [x] -> (concatD [prt 0 x , doc (showString ";")]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print ParConstr where - prt i e = case e of - ParConstr pident ddecls -> prPrec i 0 (concatD [prt 0 pident , prt 0 ddecls]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs]) - -instance Print Name where - prt i e = case e of - PIdentName pident -> prPrec i 0 (concatD [prt 0 pident]) - ListName pident -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , doc (showString "]")]) - - prtList es = case es of - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print LocDef where - prt i e = case e of - LDDecl pidents exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString ":") , prt 0 exp]) - LDDef pidents exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString "=") , prt 0 exp]) - LDFull pidents exp0 exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Exp where - prt i e = case e of - EPIdent pident -> prPrec i 6 (concatD [prt 0 pident]) - EConstr pident -> prPrec i 6 (concatD [doc (showString "{") , prt 0 pident , doc (showString "}")]) - ECons pident -> prPrec i 6 (concatD [doc (showString "%") , prt 0 pident , doc (showString "%")]) - ESort sort -> prPrec i 6 (concatD [prt 0 sort]) - EString str -> prPrec i 6 (concatD [prt 0 str]) - EInt n -> prPrec i 6 (concatD [prt 0 n]) - EFloat d -> prPrec i 6 (concatD [prt 0 d]) - EMeta -> prPrec i 6 (concatD [doc (showString "?")]) - EEmpty -> prPrec i 6 (concatD [doc (showString "[") , doc (showString "]")]) - EData -> prPrec i 6 (concatD [doc (showString "data")]) - EList pident exps -> prPrec i 6 (concatD [doc (showString "[") , prt 0 pident , prt 0 exps , doc (showString "]")]) - EStrings str -> prPrec i 6 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")]) - ERecord locdefs -> prPrec i 6 (concatD [doc (showString "{") , prt 0 locdefs , doc (showString "}")]) - ETuple tuplecomps -> prPrec i 6 (concatD [doc (showString "<") , prt 0 tuplecomps , doc (showString ">")]) - EIndir pident -> prPrec i 6 (concatD [doc (showString "(") , doc (showString "in") , prt 0 pident , doc (showString ")")]) - ETyped exp0 exp -> prPrec i 6 (concatD [doc (showString "<") , prt 0 exp0 , doc (showString ":") , prt 0 exp , doc (showString ">")]) - EProj exp label -> prPrec i 5 (concatD [prt 5 exp , doc (showString ".") , prt 0 label]) - EQConstr pident0 pident -> prPrec i 5 (concatD [doc (showString "{") , prt 0 pident0 , doc (showString ".") , prt 0 pident , doc (showString "}")]) - EQCons pident0 pident -> prPrec i 5 (concatD [doc (showString "%") , prt 0 pident0 , doc (showString ".") , prt 0 pident]) - EApp exp0 exp -> prPrec i 4 (concatD [prt 4 exp0 , prt 5 exp]) - ETable cases -> prPrec i 4 (concatD [doc (showString "table") , doc (showString "{") , prt 0 cases , doc (showString "}")]) - ETTable exp cases -> prPrec i 4 (concatD [doc (showString "table") , prt 6 exp , doc (showString "{") , prt 0 cases , doc (showString "}")]) - EVTable exp exps -> prPrec i 4 (concatD [doc (showString "table") , prt 6 exp , doc (showString "[") , prt 0 exps , doc (showString "]")]) - ECase exp cases -> prPrec i 4 (concatD [doc (showString "case") , prt 0 exp , doc (showString "of") , doc (showString "{") , prt 0 cases , doc (showString "}")]) - EVariants exps -> prPrec i 4 (concatD [doc (showString "variants") , doc (showString "{") , prt 0 exps , doc (showString "}")]) - EPre exp alterns -> prPrec i 4 (concatD [doc (showString "pre") , doc (showString "{") , prt 0 exp , doc (showString ";") , prt 0 alterns , doc (showString "}")]) - EStrs exps -> prPrec i 4 (concatD [doc (showString "strs") , doc (showString "{") , prt 0 exps , doc (showString "}")]) - EPatt patt -> prPrec i 4 (concatD [doc (showString "pattern") , prt 2 patt]) - EPattType exp -> prPrec i 4 (concatD [doc (showString "pattern") , doc (showString "type") , prt 5 exp]) - ESelect exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "!") , prt 4 exp]) - ETupTyp exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "*") , prt 4 exp]) - EExtend exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "**") , prt 4 exp]) - EGlue exp0 exp -> prPrec i 1 (concatD [prt 2 exp0 , doc (showString "+") , prt 1 exp]) - EConcat exp0 exp -> prPrec i 0 (concatD [prt 1 exp0 , doc (showString "++") , prt 0 exp]) - EAbstr binds exp -> prPrec i 0 (concatD [doc (showString "\\") , prt 0 binds , doc (showString "->") , prt 0 exp]) - ECTable binds exp -> prPrec i 0 (concatD [doc (showString "\\") , doc (showString "\\") , prt 0 binds , doc (showString "=>") , prt 0 exp]) - EProd decl exp -> prPrec i 0 (concatD [prt 0 decl , doc (showString "->") , prt 0 exp]) - ETType exp0 exp -> prPrec i 0 (concatD [prt 3 exp0 , doc (showString "=>") , prt 0 exp]) - ELet locdefs exp -> prPrec i 0 (concatD [doc (showString "let") , doc (showString "{") , prt 0 locdefs , doc (showString "}") , doc (showString "in") , prt 0 exp]) - ELetb locdefs exp -> prPrec i 0 (concatD [doc (showString "let") , prt 0 locdefs , doc (showString "in") , prt 0 exp]) - EWhere exp locdefs -> prPrec i 0 (concatD [prt 3 exp , doc (showString "where") , doc (showString "{") , prt 0 locdefs , doc (showString "}")]) - EEqs equations -> prPrec i 0 (concatD [doc (showString "fn") , doc (showString "{") , prt 0 equations , doc (showString "}")]) - EExample exp str -> prPrec i 0 (concatD [doc (showString "in") , prt 5 exp , prt 0 str]) - ELString lstring -> prPrec i 6 (concatD [prt 0 lstring]) - ELin pident -> prPrec i 4 (concatD [doc (showString "Lin") , prt 0 pident]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Exps where - prt i e = case e of - NilExp -> prPrec i 0 (concatD []) - ConsExp exp exps -> prPrec i 0 (concatD [prt 6 exp , prt 0 exps]) - - -instance Print Patt where - prt i e = case e of - PChar -> prPrec i 2 (concatD [doc (showString "?")]) - PChars str -> prPrec i 2 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")]) - PMacro pident -> prPrec i 2 (concatD [doc (showString "#") , prt 0 pident]) - PM pident0 pident -> prPrec i 2 (concatD [doc (showString "#") , prt 0 pident0 , doc (showString ".") , prt 0 pident]) - PW -> prPrec i 2 (concatD [doc (showString "_")]) - PV pident -> prPrec i 2 (concatD [prt 0 pident]) - PCon pident -> prPrec i 2 (concatD [doc (showString "{") , prt 0 pident , doc (showString "}")]) - PQ pident0 pident -> prPrec i 2 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident]) - PInt n -> prPrec i 2 (concatD [prt 0 n]) - PFloat d -> prPrec i 2 (concatD [prt 0 d]) - PStr str -> prPrec i 2 (concatD [prt 0 str]) - PR pattasss -> prPrec i 2 (concatD [doc (showString "{") , prt 0 pattasss , doc (showString "}")]) - PTup patttuplecomps -> prPrec i 2 (concatD [doc (showString "<") , prt 0 patttuplecomps , doc (showString ">")]) - PC pident patts -> prPrec i 1 (concatD [prt 0 pident , prt 0 patts]) - PQC pident0 pident patts -> prPrec i 1 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident , prt 0 patts]) - PDisj patt0 patt -> prPrec i 0 (concatD [prt 0 patt0 , doc (showString "|") , prt 1 patt]) - PSeq patt0 patt -> prPrec i 0 (concatD [prt 0 patt0 , doc (showString "+") , prt 1 patt]) - PRep patt -> prPrec i 1 (concatD [prt 2 patt , doc (showString "*")]) - PAs pident patt -> prPrec i 1 (concatD [prt 0 pident , doc (showString "@") , prt 2 patt]) - PNeg patt -> prPrec i 1 (concatD [doc (showString "-") , prt 2 patt]) - - prtList es = case es of - [x] -> (concatD [prt 2 x]) - x:xs -> (concatD [prt 2 x , prt 0 xs]) - -instance Print PattAss where - prt i e = case e of - PA pidents patt -> prPrec i 0 (concatD [prt 0 pidents , doc (showString "=") , prt 0 patt]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Label where - prt i e = case e of - LPIdent pident -> prPrec i 0 (concatD [prt 0 pident]) - LVar n -> prPrec i 0 (concatD [doc (showString "$") , prt 0 n]) - - -instance Print Sort where - prt i e = case e of - Sort_Type -> prPrec i 0 (concatD [doc (showString "Type")]) - Sort_PType -> prPrec i 0 (concatD [doc (showString "PType")]) - Sort_Tok -> prPrec i 0 (concatD [doc (showString "Tok")]) - Sort_Str -> prPrec i 0 (concatD [doc (showString "Str")]) - Sort_Strs -> prPrec i 0 (concatD [doc (showString "Strs")]) - - -instance Print Bind where - prt i e = case e of - BPIdent pident -> prPrec i 0 (concatD [prt 0 pident]) - BWild -> prPrec i 0 (concatD [doc (showString "_")]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print Decl where - prt i e = case e of - DDec binds exp -> prPrec i 0 (concatD [doc (showString "(") , prt 0 binds , doc (showString ":") , prt 0 exp , doc (showString ")")]) - DExp exp -> prPrec i 0 (concatD [prt 4 exp]) - - -instance Print TupleComp where - prt i e = case e of - TComp exp -> prPrec i 0 (concatD [prt 0 exp]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print PattTupleComp where - prt i e = case e of - PTComp patt -> prPrec i 0 (concatD [prt 0 patt]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print Case where - prt i e = case e of - Case patt exp -> prPrec i 0 (concatD [prt 0 patt , doc (showString "=>") , prt 0 exp]) - - prtList es = case es of - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Equation where - prt i e = case e of - Equ patts exp -> prPrec i 0 (concatD [prt 0 patts , doc (showString "->") , prt 0 exp]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Altern where - prt i e = case e of - Alt exp0 exp -> prPrec i 0 (concatD [prt 0 exp0 , doc (showString "/") , prt 0 exp]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print DDecl where - prt i e = case e of - DDDec binds exp -> prPrec i 0 (concatD [doc (showString "(") , prt 0 binds , doc (showString ":") , prt 0 exp , doc (showString ")")]) - DDExp exp -> prPrec i 0 (concatD [prt 6 exp]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , prt 0 xs]) - -instance Print OldGrammar where - prt i e = case e of - OldGr include topdefs -> prPrec i 0 (concatD [prt 0 include , prt 0 topdefs]) - - -instance Print Include where - prt i e = case e of - NoIncl -> prPrec i 0 (concatD []) - Incl filenames -> prPrec i 0 (concatD [doc (showString "include") , prt 0 filenames]) - - -instance Print FileName where - prt i e = case e of - FString str -> prPrec i 0 (concatD [prt 0 str]) - FPIdent pident -> prPrec i 0 (concatD [prt 0 pident]) - FSlash filename -> prPrec i 0 (concatD [doc (showString "/") , prt 0 filename]) - FDot filename -> prPrec i 0 (concatD [doc (showString ".") , prt 0 filename]) - FMinus filename -> prPrec i 0 (concatD [doc (showString "-") , prt 0 filename]) - FAddId pident filename -> prPrec i 0 (concatD [prt 0 pident , prt 0 filename]) - - prtList es = case es of - [x] -> (concatD [prt 0 x , doc (showString ";")]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - - diff --git a/src/GF/Devel/Compile/Refresh.hs b/src/GF/Devel/Compile/Refresh.hs deleted file mode 100644 index 1708761fc..000000000 --- a/src/GF/Devel/Compile/Refresh.hs +++ /dev/null @@ -1,118 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Refresh --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:27 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- make variable names unique by adding an integer index to each ------------------------------------------------------------------------------ - -module GF.Devel.Compile.Refresh ( - refreshModule, - refreshTerm, - refreshTermN - ) where - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Devel.Grammar.Macros -import GF.Infra.Ident - -import GF.Data.Operations - -import Control.Monad - - --- for concrete and resource in grammar, before optimizing - -refreshModule :: Int -> SourceModule -> Err (SourceModule,Int) -refreshModule k (m,mo) = do - (mo',(_,k')) <- appSTM (termOpModule refresh mo) (initIdStateN k) - return ((m,mo'),k') - - -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' <- refVarPlus 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 (refVarPlus 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') - - PAs x p' -> liftM2 PAs (refVar x) (refreshPatt p') - - PSeq p' q' -> liftM2 PSeq (refreshPatt p') (refreshPatt q') - PAlt p' q' -> liftM2 PAlt (refreshPatt p') (refreshPatt q') - PRep p' -> liftM PRep (refreshPatt p') - PNeg p' -> liftM PNeg (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) - diff --git a/src/GF/Devel/Compile/Rename.hs b/src/GF/Devel/Compile/Rename.hs deleted file mode 100644 index 9ba704c19..000000000 --- a/src/GF/Devel/Compile/Rename.hs +++ /dev/null @@ -1,239 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Rename --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/30 18:39:44 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.19 $ --- --- 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 --- ------------------------------------------------------------------------------ - -module GF.Devel.Compile.Rename ( - renameModule - ) where - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Devel.Grammar.Macros -import GF.Devel.Grammar.PrGF -import GF.Infra.Ident -import GF.Devel.Grammar.Lookup -import GF.Data.Operations - -import Control.Monad -import qualified Data.Map as Map -import Data.List (nub) -import Debug.Trace (trace) - -{- --- | 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 :: GF -> SourceModule -> Err SourceModule -renameModule gf sm@(name,mo) = case mtype mo of - MTInterface -> return sm - _ | not (isCompleteModule mo) -> return sm - _ -> errIn ("renaming module" +++ prt name) $ do - let gf1 = gf {gfmodules = Map.insert name mo (gfmodules gf)} - let rename = renameTerm (gf1,sm) [] - mo1 <- termOpModule rename mo - let mo2 = mo1 {mopens = nub [(i,i) | (_,i) <- mopens mo1]} - return (name,mo2) - -type RenameEnv = (GF,SourceModule) - -renameIdentTerm :: RenameEnv -> Term -> Err Term -renameIdentTerm (gf, (name,mo)) trm = case trm of - Vr i -> looks i - Con i -> looks i - Q m i -> getQualified m >>= look i - QC m i -> getQualified m >>= look i - _ -> return trm - where - looks i = do - let ts = nub [t | m <- pool, Ok t <- [look i m]] - case ts of - [t] -> return t - [] | elem i [IC "Int",IC "Float",IC "String"] -> ---- do this better - return (Q (IC "PredefAbs") i) - [] -> prtBad "identifier not found" i - t:_ -> - trace (unwords $ "WARNING":"identifier":prt i:"ambiguous:" : map prt ts) - (return t) ----- _ -> fail $ unwords $ "identifier" : prt i : "ambiguous:" : map prt ts - look i m = do - ju <- lookupIdent gf m i - return $ case jform ju of - JLink -> if isConstructor ju then QC (jlink ju) i else Q (jlink ju) i - _ -> if isConstructor ju then QC m i else Q m i - pool = nub $ name : - maybe name id (interfaceName mo) : - IC "Predef" : - map fst (mextends mo) ++ - map snd (mopens mo) - getQualified m = case Map.lookup m qualifMap of - Just n -> return n - _ -> prtBad "unknown qualifier" m - qualifMap = Map.fromList $ - mopens mo ++ - concat [ops | (_,ops) <- minstances mo] ++ - [(m,m) | m <- pool] - ---- TODO: check uniqueness of these names - -renameTerm :: RenameEnv -> [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) - Typed a b -> liftM2 Typed (ren vs a) (ren vs b) - Vr x - | elem x vs -> return trm - | otherwise -> renid trm - Con _ -> renid trm - Q _ _ -> renid trm - QC _ _ -> renid trm - Eqs eqs -> liftM Eqs $ mapM (renameEquation env vars) 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 - _ -> case liftM (flip P l) $ renid t of - Ok t -> return t -- const proj last - _ -> prtBad "unknown qualified constant" trm - - EPatt p -> do - (p',_) <- renpatt p - return $ EPatt p' - - _ -> 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 :: RenameEnv -> Patt -> Err (Patt,[Ident]) -renamePattern env patt = case patt of - - PMacro c -> do - c' <- renid $ Vr c - case c' of - Q p d -> renp $ PM p d - _ -> prtBad "unresolved pattern" patt - - PC c ps -> do - c' <- renid $ Vr c - case c' of - QC p d -> renp $ PP p d ps - Q p d -> renp $ PP p d ps - _ -> prtBad "unresolved pattern" c' ---- (PC c ps', concat vs) - - PP p c ps -> do - - (p', c') <- case renid (QC p c) of - Ok (QC p' c') -> return (p',c') - _ -> return (p,c) --- temporarily, for bw compat - psvss <- mapM renp ps - let (ps',vs) = unzip psvss - return (PP p' c' ps', concat vs) - - PV x -> case renid (Vr x) of - Ok (QC m c) -> return (PP m c [],[]) - _ -> 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') - - PAlt p q -> do - (p',vs) <- renp p - (q',ws) <- renp q - return (PAlt p' q', vs ++ ws) - - PSeq p q -> do - (p',vs) <- renp p - (q',ws) <- renp q - return (PSeq p' q', vs ++ ws) - - PRep p -> do - (p',vs) <- renp p - return (PRep p', vs) - - PNeg p -> do - (p',vs) <- renp p - return (PNeg p', vs) - - PAs x p -> do - (p',vs) <- renp p - return (PAs x p', x:vs) - - _ -> return (patt,[]) - - where - renp = renamePattern env - renid = renameIdentTerm env - -renameParam :: RenameEnv -> (Ident, Context) -> Err (Ident, Context) -renameParam env (c,co) = do - co' <- renameContext env co - return (c,co') - -renameContext :: RenameEnv -> 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 - --- | vars not needed in env, since patterns always overshadow old vars -renameEquation :: RenameEnv -> [Ident] -> Equation -> Err Equation -renameEquation b vs (ps,t) = do - (ps',vs') <- liftM unzip $ mapM (renamePattern b) ps - t' <- renameTerm b (concat vs' ++ vs) t - return (ps',t') - diff --git a/src/GF/Devel/Compile/SourceToGF.hs b/src/GF/Devel/Compile/SourceToGF.hs deleted file mode 100644 index a62179c18..000000000 --- a/src/GF/Devel/Compile/SourceToGF.hs +++ /dev/null @@ -1,679 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : SourceToGF --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/04 11:05:07 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.28 $ --- --- based on the skeleton Haskell module generated by the BNF converter ------------------------------------------------------------------------------ - -module GF.Devel.Compile.SourceToGF ( - transGrammar, - transModDef, - transExp, ----- transOldGrammar, ----- transInclude, - newReservedWords - ) where - -import qualified GF.Devel.Grammar.Grammar as G -import GF.Devel.Grammar.Construct -import qualified GF.Devel.Grammar.Macros as M -----import qualified GF.Compile.Update as U ---import qualified GF.Infra.Option as GO ---import qualified GF.Compile.ModDeps as GD -import GF.Infra.Ident -import GF.Devel.Compile.AbsGF -import GF.Devel.Compile.PrintGF (printTree) -----import GF.Source.PrintGF -----import GF.Compile.RemoveLiT --- for bw compat -import GF.Data.Operations ---import GF.Infra.Option - -import Control.Monad -import Data.Char -import qualified Data.Map as Map -import Data.List (genericReplicate) - -import Debug.Trace (trace) ---- - --- 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 - -getIdentPos :: PIdent -> Err (Ident,Int) -getIdentPos x = case x of - PIdent ((line,_),c) -> return (IC c,line) - -transIdent :: PIdent -> Err Ident -transIdent = liftM fst . getIdentPos - -transName :: Name -> Err Ident -transName n = case n of - PIdentName i -> transIdent i - ListName i -> transIdent (mkListId i) - -transGrammar :: Grammar -> Err G.GF -transGrammar x = case x of - Gr moddefs -> do - moddefs' <- mapM transModDef moddefs - let mos = Map.fromList moddefs' - return $ emptyGF {G.gfmodules = mos} - -transModDef :: ModDef -> Err (Ident, G.Module) -transModDef x = case x of - MModule compl mtyp body -> do - - let isCompl = transComplMod compl - - (trDef, mtyp', id') <- case mtyp of - MAbstract id -> do - id' <- transIdent id - return (transAbsDef, G.MTAbstract, id') - MGrammar id -> mkModRes id G.MTGrammar body - MResource id -> mkModRes id G.MTGrammar body - MConcrete id open -> do - id' <- transIdent id - open' <- transIdent open - return (transCncDef, G.MTConcrete open', id') - MInterface id -> mkModRes id G.MTInterface body - MInstance id open -> do - open' <- transIdent open - mkModRes id (G.MTInstance open') body - - mkBody (isCompl, trDef, mtyp', id') body - where - mkBody xx@(isc, trDef, mtyp', id') bod = case bod of - MNoBody incls -> do - mkBody xx $ MBody (Ext incls) NoOpens [] - MBody extends opens defs -> do - extends' <- transExtend extends - opens' <- transOpens opens - defs0 <- mapM trDef $ getTopDefs defs - let defs' = Map.fromListWith unifyJudgements - [(i,d) | Left ds <- defs0, (i,d) <- ds] - let flags' = Map.fromList [f | Right fs <- defs0, f <- fs] - return (id', G.Module mtyp' isc [] [] extends' opens' flags' defs') - - MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens [] - MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs - MWithE extends m insts -> mkBody xx $ MWithEBody extends m insts NoOpens [] - MWithEBody extends m insts opens defs -> do - extends' <- mapM transIncludedExt extends - m' <- transIncludedExt m - insts' <- mapM transOpen insts - opens' <- transOpens opens - defs0 <- mapM trDef $ getTopDefs defs - let defs' = Map.fromListWith unifyJudgements - [(i,d) | Left ds <- defs0, (i,d) <- ds] - let flags' = Map.fromList [f | Right fs <- defs0, f <- fs] - return (id', G.Module mtyp' isc [] [(m',insts')] extends' opens' flags' defs') - _ -> fail "deprecated module form" - - - mkModRes id mtyp body = do - id' <- transIdent id - return (transResDef, mtyp, id') - - -getTopDefs :: [TopDef] -> [TopDef] -getTopDefs x = x - -transComplMod :: ComplMod -> Bool -transComplMod x = case x of - CMCompl -> True - CMIncompl -> False - -transExtend :: Extend -> Err [(Ident,G.MInclude)] -transExtend x = case x of - Ext ids -> mapM transIncludedExt ids - NoExt -> return [] - -transOpens :: Opens -> Err [(Ident,Ident)] -transOpens x = case x of - NoOpens -> return [] - OpenIn opens -> mapM transOpen opens - -transOpen :: Open -> Err (Ident,Ident) -transOpen x = case x of - OName id -> transIdent id >>= \y -> return (y,y) - OQual id m -> liftM2 (,) (transIdent id) (transIdent m) - -transIncludedExt :: Included -> Err (Ident, G.MInclude) -transIncludedExt x = case x of - IAll i -> liftM2 (,) (transIdent i) (return G.MIAll) - ISome i ids -> liftM2 (,) (transIdent i) (liftM G.MIOnly $ mapM transIdent ids) - IMinus i ids -> liftM2 (,) (transIdent i) (liftM G.MIExcept $ mapM transIdent ids) - -transAbsDef :: TopDef -> Err (Either [(Ident,G.Judgement)] [(Ident,String)]) -transAbsDef x = case x of - DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs - DefFun fundefs -> do - fundefs' <- mapM transFunDef fundefs - returnl [(fun, absFun typ) | (funs,typ) <- fundefs', fun <- funs] -{- ---- - DefFunData fundefs -> do - fundefs' <- mapM transFunDef fundefs - returnl $ - [(cat, G.AbsCat nope (yes [M.cn fun])) | (funs,typ) <- fundefs', - fun <- funs, - Ok (_,cat) <- [M.valCat typ] - ] ++ - [(fun, G.AbsFun (yes typ) (yes G.EData)) | (funs,typ) <- fundefs', fun <- funs] - DefDef defs -> do - defs' <- liftM concat $ mapM getDefsGen defs - returnl [(c, G.AbsFun nope pe) | (c,(_,pe)) <- defs'] - DefData ds -> do - ds' <- mapM transDataDef ds - returnl $ - [(c, G.AbsCat nope (yes ps)) | (c,ps) <- ds'] ++ - [(f, G.AbsFun nope (yes G.EData)) | (_,fs) <- ds', tf <- fs, f <- funs tf] --} - DefFlag defs -> liftM (Right . concat) $ mapM transFlagDef defs - _ -> return $ Left [] ---- ----- _ -> Bad $ "illegal definition in abstract module:" ++++ printTree x - where - -- to get data constructors as terms - funs t = case t of - G.Con f -> [f] - G.Q _ f -> [f] - G.QC _ f -> [f] - _ -> [] - -returnl :: a -> Err (Either a b) -returnl = return . Left - -transFlagDef :: Def -> Err [(Ident,String)] -transFlagDef x = case x of - DDef f x -> do - fs <- mapM transName f - x' <- transExp x - v <- case x' of - G.K s -> return s - G.Vr (IC s) -> return s - G.EInt i -> return $ show i - _ -> fail $ "illegal flag value" +++ printTree x - return $ [(f',v) | f' <- fs] - - --- | Cat definitions can also return some fun defs --- if it is a list category definition -transCatDef :: CatDef -> Err [(Ident, G.Judgement)] -transCatDef x = case x of - SimpleCatDef id ddecls -> liftM (:[]) $ cat id ddecls - ListCatDef id ddecls -> listCat id ddecls 0 - ListSizeCatDef id ddecls size -> listCat id ddecls size - where - cat id ddecls = do - i <- transIdent id - cont <- liftM concat $ mapM transDDecl ddecls - return (i, absCat cont) - listCat id ddecls size = do - let li = mkListId id - li' <- transIdent $ li - baseId <- transIdent $ mkBaseId id - consId <- transIdent $ mkConsId id - catd0@(c,ju) <- cat li ddecls - id' <- transIdent id - let - cont0 = [] ---- cat context - catd = (c,ju) ----(Yes cont0) (Yes [M.cn baseId,M.cn consId])) - cont = [(mkId x i,ty) | (i,(x,ty)) <- zip [0..] cont0] - xs = map (G.Vr . fst) cont - cd = M.mkDecl (M.mkApp (G.Vr id') xs) - lc = M.mkApp (G.Vr li') xs - niltyp = mkProd (cont ++ genericReplicate size cd) lc - nilfund = (baseId, absFun niltyp) ---- (yes niltyp) (yes G.EData)) - constyp = mkProd (cont ++ [cd, M.mkDecl lc]) lc - consfund = (consId, absFun constyp) ---- (yes constyp) (yes G.EData)) - return [catd,nilfund,consfund] - mkId x i = if isWildIdent x then (mkIdent "x" i) else x - -transFunDef :: FunDef -> Err ([Ident], G.Type) -transFunDef x = case x of - FDecl ids typ -> liftM2 (,) (mapM transName ids) (transExp typ) - -{- ---- -transDataDef :: DataDef -> Err (Ident,[G.Term]) -transDataDef x = case x of - DataDef id ds -> liftM2 (,) (transIdent id) (mapM transData ds) - where - transData d = case d of - DataId id -> liftM G.Con $ transIdent id - DataQId id0 id -> liftM2 G.QC (transIdent id0) (transIdent id) --} - -transResDef :: TopDef -> Err (Either [(Ident,G.Judgement)] [(Ident,String)]) -transResDef x = case x of - DefPar pardefs -> do - pardefs' <- mapM transParDef pardefs - returnl $ concatMap mkParamDefs pardefs' - - DefOper defs -> do - defs' <- liftM concat $ mapM getDefs defs - returnl $ concatMap mkOverload [(f, resOper pt pe) | (f,(pt,pe)) <- defs'] - - DefLintype defs -> do - defs' <- liftM concat $ mapM getDefs defs - returnl [(f, resOper pt pe) | (f,(pt,pe)) <- defs'] - - DefFlag defs -> liftM (Right . concat) $ mapM transFlagDef defs - _ -> return $ Left [] ---- ----- _ -> Bad $ "illegal definition form in resource" +++ printTree x - where - - mkParamDefs (p,pars) = - if null pars - then [(p,addJType M.meta0 (emptyJudgement G.JParam))] -- in an interface - else (p,resParam p pars) : paramConstructors p pars - - mkOverload (c,j) = case (G.jtype j, G.jdef j) of - (_,G.App keyw (G.R fs@(_:_:_))) | isOverloading keyw c fs -> - [(c,resOverload [(ty,fu) | (_,(Just ty,fu)) <- fs])] - - -- to enable separare type signature --- not type-checked - (G.App keyw (G.RecType fs@(_:_:_)),_) | isOverloading keyw c fs -> [] - _ -> [(c,j)] - isOverloading (G.Vr keyw) c fs = - prIdent keyw == "overload" && -- overload is a "soft keyword" - True ---- all (== GP.prt c) (map (GP.prt . fst) fs) - -transParDef :: ParDef -> Err (Ident, [(Ident,G.Context)]) -transParDef x = case x of - ParDefDir id params -> liftM2 (,) (transIdent id) (mapM transParConstr params) - ParDefAbs id -> liftM2 (,) (transIdent id) (return []) - -transCncDef :: TopDef -> Err (Either [(Ident,G.Judgement)] [(Ident,String)]) -transCncDef x = case x of - DefLincat defs -> do - defs' <- liftM concat $ mapM transPrintDef defs - returnl [(f, cncCat t) | (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, cncFun pe) | (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] --} - _ -> return $ Left [] ---- ----- _ -> errIn ("illegal definition in concrete syntax:") $ transResDef x - -transPrintDef :: Def -> Err [(Ident,G.Term)] -transPrintDef x = case x of - DDef ids exp -> do - (ids,e) <- liftM2 (,) (mapM transName ids) (transExp exp) - return $ [(i,e) | i <- ids] - -getDefsGen :: Def -> Err [(Ident, (G.Type, G.Term))] -getDefsGen d = case d of - DDecl ids t -> do - ids' <- mapM transName ids - t' <- transExp t - return [(i,(t', nope)) | i <- ids'] - DDef ids e -> do - ids' <- mapM transName ids - e' <- transExp e - return [(i,(nope, yes e')) | i <- ids'] - DFull ids t e -> do - ids' <- mapM transName ids - t' <- transExp t - e' <- transExp e - return [(i,(yes t', yes e')) | i <- ids'] - DPatt id patts e -> do - id' <- transName id - ps' <- mapM transPatt patts - e' <- transExp e - return [(id',(nope, yes (G.Eqs [(ps',e')])))] - where - yes = id - nope = G.Meta 0 - --- | sometimes you need this special case, e.g. in linearization rules -getDefs :: Def -> Err [(Ident, (G.Type, G.Term))] -getDefs d = case d of - DPatt id patts e -> do - id' <- transName id - xs <- mapM tryMakeVar patts - e' <- transExp e - return [(id',(nope, (M.mkAbs xs e')))] - _ -> getDefsGen d - where - nope = G.Meta 0 - --- | 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" +++ show p' - -transExp :: Exp -> Err G.Term -transExp x = case x of - EPIdent id -> liftM G.Vr $ transIdent id - EConstr id -> liftM G.Con $ transIdent id - ECons id -> liftM G.Con $ 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 n - EFloat n -> return $ G.EFloat n - EMeta -> return $ G.Meta 0 - EEmpty -> return G.Empty - -- [ C x_1 ... x_n ] becomes (ListC x_1 ... x_n) - EList i es -> transExp $ foldl EApp (EPIdent (mkListId i)) (exps2list es) - 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) - EVTable exp cases -> - liftM2 (\t c -> G.V t c) (transExp exp) (mapM transExp cases) - ECase exp cases -> do - exp' <- transExp exp - cases' <- transCases cases - let annot = case exp' of - G.Typed _ t -> G.TTyped t - _ -> G.TRaw - return $ G.S (G.T annot 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.FV $ 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) - EExample exp str -> liftM2 G.Example (transExp exp) (return str) - - EProd decl exp -> liftM2 mkProd (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" +++ prIdent c +++ "without value" - ELetb defs exp -> transExp $ ELet defs exp - EWhere exp defs -> transExp $ ELet defs exp - - EPattType typ -> liftM G.EPattType (transExp typ) - EPatt patt -> liftM G.EPatt (transPatt patt) - - ELString (LString str) -> return $ G.K str ----- ELin id -> liftM G.LiT $ transIdent id - - EEqs eqs -> liftM G.Eqs $ mapM transEquation eqs - EData -> return G.EData - - _ -> Bad $ "translation not yet defined for" +++ printTree x ---- - -exps2list :: Exps -> [Exp] -exps2list NilExp = [] -exps2list (ConsExp e es) = e : exps2list es - ---- 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" +++ show (fst f) --- manifest fields ?! - tryR f = case f of - (lab,(mty, Just t)) -> return (M.ident2label lab,(mty,t)) - _ -> Bad $ "illegal record field" +++ show (fst f) - - -locdef2fields :: LocDef -> Err [(Ident, (Maybe G.Type, Maybe G.Type))] -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 - LPIdent (PIdent (_,'v':ds)) | all isDigit ds -> return $ G.LVar $ readIntArg ds - - LPIdent (PIdent (_, 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 - PChar -> return G.PChar - PChars s -> return $ G.PChars s - PMacro c -> liftM G.PMacro $ transIdent c - PM m c -> liftM2 G.PM (transIdent m) (transIdent c) - PW -> return wildPatt - PV (PIdent (_,"_")) -> return 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 n - PFloat n -> return $ G.PFloat n - PStr str -> return $ G.PString str - PR pattasss -> do - let (lss,ps) = unzip [(ls,p) | PA ls p <- pattasss] - ls = map LPIdent $ 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) - PDisj p1 p2 -> liftM2 G.PAlt (transPatt p1) (transPatt p2) - PSeq p1 p2 -> liftM2 G.PSeq (transPatt p1) (transPatt p2) - PRep p -> liftM G.PRep (transPatt p) - PNeg p -> liftM G.PNeg (transPatt p) - PAs x p -> liftM2 G.PAs (transIdent x) (transPatt p) - - - -transBind :: Bind -> Err Ident -transBind x = case x of - BPIdent (PIdent (_,"_")) -> return identW - BPIdent 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 = mapM transCase - -transCase :: Case -> Err G.Case -transCase (Case p exp) = do - patt <- transPatt p - exp' <- transExp exp - return (patt,exp') - -transEquation :: Equation -> Err G.Equation -transEquation x = case x of - Equ apatts exp -> liftM2 (,) (mapM transPatt apatts) (transExp exp) - -transAltern :: Altern -> Err (G.Term, G.Term) -transAltern x = case x of - Alt exp0 exp -> liftM2 (,) (transExp exp0) (transExp exp) - -transParConstr :: ParConstr -> Err (Ident,G.Context) -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 :: Options -> FilePath -> OldGrammar -> Err G.SourceGrammar -transOldGrammar opts name0 x = 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 ops r,mkCnc ops c] ++ map mkPack ps - where - ops = map fst ps - (a,r,c,ps) = foldr srt ([],[],[],[]) ds - srt d (a,r,c,ps) = case d of - DefCat catdefs -> (d:a,r,c,ps) - DefFun fundefs -> (d:a,r,c,ps) - DefFunData fundefs -> (d:a,r,c,ps) - DefDef defs -> (d:a,r,c,ps) - DefData pardefs -> (d:a,r,c,ps) - DefPar pardefs -> (a,d:r,c,ps) - DefOper defs -> (a,d:r,c,ps) - DefLintype defs -> (a,d:r,c,ps) - DefLincat defs -> (a,r,d:c,ps) - DefLindef defs -> (a,r,d:c,ps) - DefLin defs -> (a,r,d:c,ps) - DefPattern defs -> (a,r,d:c,ps) - DefFlag defs -> (a,r,d:c,ps) --- a guess - DefPrintCat printdefs -> (a,r,d:c,ps) - DefPrintFun printdefs -> (a,r,d:c,ps) - DefPrintOld printdefs -> (a,r,d:c,ps) - DefPackage m ds -> (a,r,c,(m,ds):ps) - _ -> (a,r,c,ps) - mkAbs a = MModule q (MTAbstract absName) (MBody ne (OpenIn []) (topDefs a)) - mkRes ps r = MModule q (MTResource resName) (MBody ne (OpenIn ops) (topDefs r)) - where ops = map OName ps - mkCnc ps r = MModule q (MTConcrete cncName absName) - (MBody ne (OpenIn (map OName (resName:ps))) (topDefs r)) - mkPack (m, ds) = MModule q (MTResource m) (MBody ne (OpenIn []) (topDefs ds)) - topDefs t = t - ne = NoExt - q = CMCompl - - name = maybe name0 (++ ".gf") $ getOptVal opts useName - absName = identC $ maybe topic id $ getOptVal opts useAbsName - resName = identC $ maybe ("Res" ++ lang) id $ getOptVal opts useResName - cncName = identC $ maybe lang id $ getOptVal opts useCncName - - (beg,rest) = span (/='.') name - (topic,lang) = case rest of -- to avoid overwriting old files - ".gf" -> ("Abs" ++ beg,"Cnc" ++ beg) - ".cf" -> ("Abs" ++ beg,"Cnc" ++ beg) - ".ebnf" -> ("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) -> modif s - FSlash filename -> '/' : trans filename - FDot filename -> '.' : trans filename - FMinus filename -> '-' : trans filename - FAddId (IC s) filename -> modif s ++ trans filename - modif s = let s' = init s ++ [toLower (last s)] in - if elem s' newReservedWords then s' else s - --- unsafe hack ; cf. GetGrammar.oldLexer --} - -newReservedWords :: [String] -newReservedWords = - words $ "abstract concrete interface incomplete " ++ - "instance out open resource reuse transfer union with where" - -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) - -mkListId,mkConsId,mkBaseId :: PIdent -> PIdent -mkListId = prefixId "List" -mkConsId = prefixId "Cons" -mkBaseId = prefixId "Base" - -prefixId :: String -> PIdent -> PIdent -prefixId pref (PIdent (p,id)) = PIdent (p, pref ++ id) diff --git a/src/GF/Devel/Compute.hs b/src/GF/Devel/Compute.hs deleted file mode 100644 index a9081c28a..000000000 --- a/src/GF/Devel/Compute.hs +++ /dev/null @@ -1,455 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Compute --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/01 15:39:12 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.19 $ --- --- Computation of source terms. Used in compilation and in @cc@ command. ------------------------------------------------------------------------------ - -module GF.Devel.Compute (computeConcrete, computeTerm,computeConcreteRec) where - -import GF.Data.Operations -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Option -import GF.Data.Str -import GF.Grammar.PrGrammar -import GF.Infra.Modules -import GF.Grammar.Macros -import GF.Grammar.Lookup -import GF.Grammar.Refresh -import GF.Grammar.PatternMatch -import GF.Grammar.Lockfield (isLockLabel) ---- - -import GF.Grammar.AppPredefined - -import Data.List (nub,intersperse) -import Control.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 -computeConcreteRec g t = {- refreshTerm t >>= -} computeTermOpt True g [] t - -computeTerm :: SourceGrammar -> Substitution -> Term -> Err Term -computeTerm = computeTermOpt False - --- rec=True is used if it cannot be assumed that looked-up constants --- have already been computed (mainly with -optimize=noexpand in .gfr) - -computeTermOpt :: Bool -> SourceGrammar -> Substitution -> Term -> Err Term -computeTermOpt rec gr = comput True where - - comput full 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@(IA _) b -> do - Abs x b | full -> do - let (xs,b1) = termFormCnc t - b' <- comp ([(x,Vr x) | x <- xs] ++ g) b1 - return $ mkAbs xs b' - -- b' <- comp (ext x (Vr x) g) b - -- return $ Abs x b' - Abs _ _ -> return t -- hnf - - 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 -> case appForm t of - (h,as) | length as > 1 -> do - h' <- hnf g h - as' <- mapM (comp g) as - case h' of - _ | not (null [() | FV _ <- as']) -> compApp g (mkApp h' as') - c@(QC _ _) -> do - return $ mkApp c as' - Q (IC "Predef") f -> do - (t',b) <- appPredefined (mkApp h' as') - if b then return t' else comp g t' - - Abs _ _ -> do - let (xs,b) = termFormCnc h' - let g' = (zip xs as') ++ g - let as2 = drop (length xs) as' - let xs2 = drop (length as') xs - b' <- comp g' (mkAbs xs2 b) - if null as2 then return b' else comp g (mkApp b' as2) - - _ -> compApp g (mkApp h' as') - _ -> compApp g t - - P t l | isLockLabel l -> return $ R [] - ---- a workaround 18/2/2005: take this away and find the reason - ---- why earlier compilation destroys the lock field - - - P t l -> do - t' <- comp g t - case t' of - FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants - R r -> maybe (prtBad "no value for label" l) (comp g . snd) $ - lookup l $ reverse r - - ExtR a (R b) -> - case comp g (P (R b) l) of - Ok v -> return v - _ -> comp g (P a l) - ---- { - --- this is incorrect, since b can contain the proper value - 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) ---- - } --- - - Alias _ _ r -> comp g (P r l) - - S (T i cs) e -> prawitz g i (flip P l) cs e - S (V i cs) e -> prawitzV g i (flip P l) cs e - - _ -> returnC $ P t' l - - PI t l i -> comp g $ P t l ----- - - S t@(T ti cc) v -> do - v' <- comp g v - case v' of - FV vs -> do - ts' <- mapM (comp g . S t) vs - return $ variants ts' - _ -> case ti of -{- - TComp _ -> do - case term2patt v' of - Ok p' -> case lookup p' cc of - Just u -> comp g u - _ -> do - t' <- comp g t - return $ S t' v' -- if v' is not canonical - _ -> do - t' <- comp g t - return $ S t' v' --} - _ -> case matchPattern cc v' of - Ok (c,g') -> comp (g' ++ g) c - _ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t - _ -> do - t' <- comp g t - return $ S t' v' -- if v' is not canonical - - - S t v -> do - - t' <- case t of --- T _ _ -> return t --- V _ _ -> return t - _ -> comp g t - - v' <- comp g v - - case v' of - FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants - _ -> case t' of - FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants - - 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 - - -- course-of-values table: look up by index, no pattern matching needed - V ptyp ts -> do - vs <- allParamValues gr ptyp - case lookup v' (zip vs [0 .. length vs - 1]) of - Just i -> comp g $ ts !! i ------ _ -> prtBad "selection" $ S t' v' -- debug - _ -> return $ S t' v' -- if v' is not canonical - - T (TComp _) cs -> do - case term2patt v' of - Ok p' -> case lookup p' cs of - Just u -> comp g u - _ -> return $ S t' v' -- if v' is not canonical - _ -> return $ S t' v' - - T _ cc -> 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 - S (V i cs) e -> prawitzV g i (flip S v') cs e - _ -> returnC $ S t' v' - - -- normalize away empty tokens - K "" -> return Empty - - -- glue if you can - Glue x0 y0 -> do - x <- comp g x0 - y <- comp g y0 - case (x,y) of - (FV ks,_) -> do - kys <- mapM (comp g . flip Glue y) ks - return $ variants kys - (_,FV ks) -> do - xks <- mapM (comp g . Glue x) ks - return $ variants xks - - (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 - (S (V i cs) e, s) -> prawitzV g i (flip Glue s) cs e - (s, S (V i cs) e) -> prawitzV g i (Glue s) cs e - (_,Empty) -> return x - (Empty,_) -> return y - (K a, K b) -> return $ K (a ++ b) - (_, Alts (d,vs)) -> do ----- (K a, Alts (d,vs)) -> do - let glx = Glue x - comp g $ Alts (glx d, [(glx v,c) | (v,c) <- vs]) - (Alts _, ka) -> checks [do - y' <- strsFromTerm ka ----- (Alts _, K a) -> checks [do - x' <- strsFromTerm x -- this may fail when compiling opers - return $ variants [ - foldr1 C (map K (str2strings (glueStr v u))) | v <- x', u <- y'] ----- foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x'] - ,return $ Glue x y - ] - (C u v,_) -> comp g $ C u (Glue v y) - - _ -> 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 - case (a',b') of - (Alts _, K a) -> checks [do - as <- strsFromTerm a' -- this may fail when compiling opers - return $ variants [ - foldr1 C (map K (str2strings (plusStr v (str a)))) | v <- as] - , - return $ C a' b' - ] - (Empty,_) -> returnC b' - (_,Empty) -> returnC a' - _ -> returnC $ C a' b' - - -- reduce free variation as much as you can - FV ts -> mapM (comp g) ts >>= returnC . variants - - -- 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) -> plusRecord r' s' - (RecType rs, RecType ss) -> plusRecType r' s' - _ -> return $ ExtR r' s' - - -- case-expand tables - -- if already expanded, don't expand again - T i@(TComp ty) cs -> do - -- if there are no variables, don't even go inside - cs' <- if (null g) then return cs else mapPairsM (comp g) cs ----- return $ V ty (map snd cs') - return $ T i cs' - --- this means some extra work; should implement TSh directly - TSh i cs -> comp g $ T i [(p,v) | (ps,v) <- cs, p <- ps] - - T i cs -> do - pty0 <- getTableType i - ptyp <- comp g pty0 - case allParamValues gr ptyp of - Ok vs -> do - - ps0 <- mapM (compPatternMacro . fst) cs - cs' <- mapM (compBranchOpt g) (zip ps0 (map snd 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 $ V ptyp ts -- to save space, just course of values - 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 - - compApp g (App f a) = do - f' <- hnf g f - a' <- comp g a - case (f',a') of - (Abs x b, FV as) -> - mapM (\c -> comp (ext x c g) b) as >>= return . variants - (_, FV as) -> mapM (\c -> comp g (App f' c)) as >>= return . variants - (FV fs, _) -> mapM (\c -> comp g (App c a')) fs >>= return . variants - (Abs x b,_) -> comp (ext x a' g) b - - (QC _ _,_) -> returnC $ App f' a' - - (Alias _ _ d, _) -> comp g (App d a') - - (S (T i cs) e,_) -> prawitz g i (flip App a') cs e - (S (V i cs) e,_) -> prawitzV g i (flip App a') cs e - - _ -> do - (t',b) <- appPredefined (App f' a') - if b then return t' else comp g t' - - hnf = comput False - comp = comput True - - look p c - | rec = lookupResDef gr p c >>= comp [] - | otherwise = lookupResDef gr p c - -{- - look p c = case lookupResDefKind gr p c of - Ok (t,_) | noExpand p || rec -> comp [] t - Ok (t,_) -> return t - Bad s -> raise s - - noExpand p = errVal False $ do - mo <- lookupModMod gr p - return $ case getOptVal (iOpts (flags mo)) useOptimizer of - Just "noexpand" -> True - _ -> False --} - - ext x a g = (x,a):g - - returnC = return --- . computed - - variants ts = case nub ts of - [t] -> t - 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 - - compPatternMacro p = case p of - PM m c -> case look m c of - Ok (EPatt p') -> compPatternMacro p' - _ -> prtBad "pattern expected as value of" p ---- should be in CheckGr - PAs x p -> do - p' <- compPatternMacro p - return $ PAs x p' - PAlt p q -> do - p' <- compPatternMacro p - q' <- compPatternMacro q - return $ PAlt p' q' - PSeq p q -> do - p' <- compPatternMacro p - q' <- compPatternMacro q - return $ PSeq p' q' - PRep p -> do - p' <- compPatternMacro p - return $ PRep p' - PNeg p -> do - p' <- compPatternMacro p - return $ PNeg p' - PR rs -> do - rs' <- mapPairsM compPatternMacro rs - return $ PR rs' - - _ -> return p - - 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 - - PAs x p -> (x,Vr x) : contP p - - PSeq p q -> concatMap contP [p,q] - PAlt p q -> concatMap contP [p,q] - PRep p -> contP p - PNeg p -> contP p - - _ -> [] - - prawitz g i f cs e = do - cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs] - return $ S (T i cs') e - prawitzV g i f cs e = do - cs' <- mapM (comp g) [(f v) | v <- cs] - return $ S (V i cs') e - - --- | argument variables cannot be glued -checkNoArgVars :: Term -> Err Term -checkNoArgVars t = case t of - Vr (IA _) -> Bad $ glueErrorMsg $ prt t - Vr (IAV _) -> Bad $ glueErrorMsg $ prt t - _ -> composOp checkNoArgVars t - -glueErrorMsg s = - "Cannot glue (+) term with run-time variable" +++ s ++ "." ++++ - "Use Prelude.bind instead." diff --git a/src/GF/Devel/GF.hs b/src/GF/Devel/GF.hs deleted file mode 100644 index 70fddcd67..000000000 --- a/src/GF/Devel/GF.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Main where - -import GF.Devel.GFC -import GF.Devel.GFI - -import System (getArgs) - -main :: IO () -main = do - xx <- getArgs - case xx of - "--batch":args -> mainGFC args - _ -> mainGFI xx - diff --git a/src/GF/Devel/GFC.hs b/src/GF/Devel/GFC.hs deleted file mode 100644 index 27e0e3ae2..000000000 --- a/src/GF/Devel/GFC.hs +++ /dev/null @@ -1,67 +0,0 @@ -module GF.Devel.GFC (mainGFC) where --- module Main where - -import GF.Compile.API -import GF.Devel.PrintGFCC -import GF.GFCC.CId -import GF.GFCC.DataGFCC -import GF.GFCC.Raw.ParGFCCRaw -import GF.GFCC.Raw.ConvertGFCC -import GF.Devel.UseIO -import GF.Infra.Option -import GF.GFCC.API -import GF.Data.ErrM - -import System.FilePath - -mainGFC :: [String] -> IO () -mainGFC xx = do - let (opts,fs) = getOptions "-" xx - case opts of - _ | oElem (iOpt "help") opts -> putStrLn usageMsg - _ | oElem (iOpt "-make") opts -> do - gfcc <- appIOE (compileToGFCC opts fs) >>= err fail return - let gfccFile = targetNameGFCC opts (absname gfcc) - outputFile gfccFile (printGFCC gfcc) - mapM_ (alsoPrint opts gfcc) printOptions - - -- gfc -o target.gfcc source_1.gfcc ... source_n.gfcc - _ | all ((==".gfcc") . takeExtensions) fs -> do - gfccs <- mapM file2gfcc fs - let gfcc = foldl1 unionGFCC gfccs - let gfccFile = targetNameGFCC opts (absname gfcc) - outputFile gfccFile (printGFCC gfcc) - mapM_ (alsoPrint opts gfcc) printOptions - - _ -> do - appIOE (mapM_ (batchCompile opts) (map return fs)) >>= err fail return - putStrLn "Done." - -targetName :: Options -> CId -> String -targetName opts abs = case getOptVal opts (aOpt "target") of - Just n -> n - _ -> prIdent abs - -targetNameGFCC :: Options -> CId -> FilePath -targetNameGFCC opts abs = targetName opts abs ++ ".gfcc" - ----- TODO: nicer and richer print options - -alsoPrint opts gr (opt,name) = do - if oElem (iOpt opt) opts - then outputFile name (prGFCC opt gr) - else return () - -outputFile :: FilePath -> String -> IO () -outputFile outfile output = - do writeFile outfile output - putStrLn $ "wrote file " ++ outfile - -printOptions = [ - ("haskell","GSyntax.hs"), - ("haskell_gadt","GSyntax.hs"), - ("js","grammar.js") - ] - -usageMsg = - "usage: gfc (-h | --make (-noopt) (-noparse) (-target=PREFIX) (-js | -haskell | -haskell_gadt)) (-src) FILES" diff --git a/src/GF/Devel/GFC/Main.hs b/src/GF/Devel/GFC/Main.hs deleted file mode 100644 index d9ceb8e70..000000000 --- a/src/GF/Devel/GFC/Main.hs +++ /dev/null @@ -1,28 +0,0 @@ -module GF.Devel.GFC.Main where - -import GF.Devel.GFC.Options - -import System.Environment -import System.Exit -import System.IO - - -version = "X.X" - -main :: IO () -main = - do args <- getArgs - case parseOptions args of - Ok (opts, files) -> - case optMode opts of - Version -> putStrLn $ "GF, version " ++ version - Help -> putStr helpMessage - Compiler -> gfcMain opts files - Errors errs -> - do mapM_ (hPutStrLn stderr) errs - exitFailure - -gfcMain :: Options -> [FilePath] -> IO () -gfcMain opts files = return () - - diff --git a/src/GF/Devel/GFCCInterpreter.hs b/src/GF/Devel/GFCCInterpreter.hs deleted file mode 100644 index b2b17dba7..000000000 --- a/src/GF/Devel/GFCCInterpreter.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Main where - -import GF.Command.Interpreter -import GF.Command.Commands -import GF.GFCC.API -import System (getArgs) -import Data.Char (isDigit) - --- Simple translation application built on GFCC. AR 7/9/2006 -- 19/9/2007 - -main :: IO () -main = do - file:_ <- getArgs - grammar <- file2grammar file - let env = CommandEnv grammar (allCommands grammar) - printHelp grammar - loop env - -loop :: CommandEnv -> IO () -loop env = do - s <- getLine - if s == "q" then return () else do - interpretCommandLine env s - loop env - -printHelp grammar = do - putStrLn $ "languages: " ++ unwords (languages grammar) - putStrLn $ "categories: " ++ unwords (categories grammar) diff --git a/src/GF/Devel/GFCCtoHaskell.hs b/src/GF/Devel/GFCCtoHaskell.hs deleted file mode 100644 index aa3eebe58..000000000 --- a/src/GF/Devel/GFCCtoHaskell.hs +++ /dev/null @@ -1,213 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GFCCtoHaskell --- Maintainer : Aarne Ranta --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/06/17 12:39:07 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.8 $ --- --- to write a GF abstract grammar into a Haskell module with translations from --- data objects into GF trees. Example: GSyntax for Agda. --- AR 11/11/1999 -- 7/12/2000 -- 18/5/2004 ------------------------------------------------------------------------------ - -module GF.Devel.GFCCtoHaskell (grammar2haskell, grammar2haskellGADT) where - -import GF.GFCC.Macros -import GF.GFCC.DataGFCC -import GF.GFCC.CId - -import GF.Data.Operations -import GF.Text.UTF8 - -import Data.List --(isPrefixOf, find, intersperse) -import qualified Data.Map as Map - --- | the main function -grammar2haskell :: GFCC -> String -grammar2haskell gr = encodeUTF8 $ foldr (++++) [] $ - haskPreamble ++ [datatypes gr', gfinstances gr'] - where gr' = hSkeleton gr - -grammar2haskellGADT :: GFCC -> String -grammar2haskellGADT gr = encodeUTF8 $ foldr (++++) [] $ - ["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++ - haskPreamble ++ [datatypesGADT gr', gfinstances gr'] - where gr' = hSkeleton gr - --- | by this you can prefix all identifiers with stg; the default is 'G' -gId :: OIdent -> OIdent -gId i = 'G':i - -haskPreamble = - [ - "module GSyntax where", - "", - "import GF.GFCC.DataGFCC", - "import GF.GFCC.CId", - "----------------------------------------------------", - "-- automatic translation from GF to Haskell", - "----------------------------------------------------", - "", - "class Gf a where", - " gf :: a -> Exp", - " fg :: Exp -> a", - "", - predefInst "GString" "String" "DTr [] (AS s) []", - "", - predefInst "GInt" "Integer" "DTr [] (AI s) []", - "", - predefInst "GFloat" "Double" "DTr [] (AF s) []", - "", - "----------------------------------------------------", - "-- below this line machine-generated", - "----------------------------------------------------", - "" - ] - -predefInst gtyp typ patt = - "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show" +++++ - "instance Gf" +++ gtyp +++ "where" ++++ - " gf (" ++ gtyp +++ "s) =" +++ patt ++++ - " fg t =" ++++ - " case t of" ++++ - " " +++ patt +++ " ->" +++ gtyp +++ "s" ++++ - " _ -> error (\"no" +++ gtyp +++ "\" ++ show t)" - -type OIdent = String - -type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] - -datatypes, gfinstances :: (String,HSkeleton) -> String -datatypes = (foldr (+++++) "") . (filter (/="")) . (map hDatatype) . snd -gfinstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance m)) g - -hDatatype :: (OIdent, [(OIdent, [OIdent])]) -> String -gfInstance :: String -> (OIdent, [(OIdent, [OIdent])]) -> String - -hDatatype ("Cn",_) = "" --- -hDatatype (cat,[]) = "" -hDatatype (cat,rules) | isListCat (cat,rules) = - "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]" - +++ "deriving Show" -hDatatype (cat,rules) = - "data" +++ gId cat +++ "=" ++ - (if length rules == 1 then "" else "\n ") +++ - foldr1 (\x y -> x ++ "\n |" +++ y) - [gId f +++ foldr (+++) "" (map gId xx) | (f,xx) <- rules] ++++ - " deriving Show" - --- GADT version of data types -datatypesGADT :: (String,HSkeleton) -> String -datatypesGADT (_,skel) = - unlines (concatMap hCatTypeGADT skel) - +++++ - "data Tree :: * -> * where" ++++ unlines (concatMap (map (" "++) . hDatatypeGADT) skel) - -hCatTypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String] -hCatTypeGADT (cat,rules) - = ["type"+++gId cat+++"="+++"Tree"+++gId cat++"_", - "data"+++gId cat++"_"] - -hDatatypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String] -hDatatypeGADT (cat, rules) - | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t] - | otherwise = - [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t | (f,args) <- rules ] - where t = "Tree" +++ gId cat ++ "_" - -gfInstance m crs = hInstance m crs ++++ fInstance m crs - -----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004 -hInstance m (cat,[]) = "" -hInstance m (cat,rules) - | isListCat (cat,rules) = - "instance Gf" +++ gId cat +++ "where" ++++ - " gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])" - +++ "=" +++ mkRHS ("Base"++ec) baseVars ++++ - " gf (" ++ gId cat +++ "(x:xs)) = " - ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")] --- no show for GADTs --- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)" - | otherwise = - "instance Gf" +++ gId cat +++ "where\n" ++ - unlines [mkInst f xx | (f,xx) <- rules] - where - ec = elemCat cat - baseVars = mkVars (baseSize (cat,rules)) - mkInst f xx = let xx' = mkVars (length xx) in " gf " ++ - (if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++ - "=" +++ mkRHS f xx' - mkVars n = ["x" ++ show i | i <- [1..n]] - mkRHS f vars = "DTr [] (AC (CId \"" ++ f ++ "\"))" +++ - "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]" - - -----fInstance m ("Cn",_) = "" --- -fInstance m (cat,[]) = "" -fInstance m (cat,rules) = - " fg t =" ++++ - " case t of" ++++ - unlines [mkInst f xx | (f,xx) <- rules] ++++ - " _ -> error (\"no" +++ cat ++ " \" ++ show t)" - where - mkInst f xx = - " DTr [] (AC (CId \"" ++ f ++ "\")) " ++ - "[" ++ prTList "," xx' ++ "]" +++ - "->" +++ mkRHS f xx' - where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]] - mkRHS f vars - | isListCat (cat,rules) = - if "Base" `isPrefixOf` f then - gId cat +++ "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]" - else - let (i,t) = (init vars,last vars) - in "let" +++ gId cat +++ "xs = fg " ++ t +++ "in" +++ - gId cat +++ prParenth (prTList ":" (["fg"+++v | v <- i] ++ ["xs"])) - | otherwise = - gId f +++ - prTList " " [prParenth ("fg" +++ x) | x <- vars] - - ---type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] -hSkeleton :: GFCC -> (String,HSkeleton) -hSkeleton gr = - (pr (absname gr), - [(pr c, [(pr f, map pr cs) | (f, (cs,_)) <- fs]) | - fs@((_, (_,c)):_) <- fns] - ) - where - fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr))))) - valtyps (_, (_,x)) (_, (_,y)) = compare x y - valtypg (_, (_,x)) (_, (_,y)) = x == y - pr (CId c) = c - jty (f,(ty,_)) = (f,catSkeleton ty) - -updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton -updateSkeleton cat skel rule = - case skel of - (cat0,rules):rr | cat0 == cat -> (cat0, rule:rules) : rr - (cat0,rules):rr -> (cat0, rules) : updateSkeleton cat rr rule - -isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool -isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2 - && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs - where c = elemCat cat - fs = map fst rules - --- | Gets the element category of a list category. -elemCat :: OIdent -> OIdent -elemCat = drop 4 - -isBaseFun :: OIdent -> Bool -isBaseFun f = "Base" `isPrefixOf` f - -isConsFun :: OIdent -> Bool -isConsFun f = "Cons" `isPrefixOf` f - -baseSize :: (OIdent, [(OIdent, [OIdent])]) -> Int -baseSize (_,rules) = length bs - where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules diff --git a/src/GF/Devel/GFCCtoJS.hs b/src/GF/Devel/GFCCtoJS.hs deleted file mode 100644 index c61ad08d5..000000000 --- a/src/GF/Devel/GFCCtoJS.hs +++ /dev/null @@ -1,132 +0,0 @@ -module GF.Devel.GFCCtoJS (gfcc2js) where - -import qualified GF.GFCC.Macros as M -import qualified GF.GFCC.DataGFCC as D -import GF.GFCC.CId -import qualified GF.JavaScript.AbsJS as JS -import qualified GF.JavaScript.PrintJS as JS - -import GF.Formalism.FCFG -import GF.Parsing.FCFG.PInfo -import GF.Formalism.Utilities (NameProfile(..), Profile(..), SyntaxForest(..)) - -import GF.Text.UTF8 -import GF.Data.ErrM -import GF.Infra.Option - -import Control.Monad (mplus) -import Data.Array (Array) -import qualified Data.Array as Array -import Data.Maybe (fromMaybe) -import qualified Data.Map as Map - -gfcc2js :: D.GFCC -> String -gfcc2js gfcc = - encodeUTF8 $ JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]] - where - n = D.printCId $ D.absname gfcc - as = D.abstract gfcc - cs = Map.assocs (D.concretes gfcc) - start = M.lookStartCat gfcc - grammar = new "GFGrammar" [abstract, concrete] - abstract = abstract2js start as - concrete = JS.EObj $ map (concrete2js start n) cs - -abstract2js :: String -> D.Abstr -> JS.Expr -abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (D.funs ds))] - -absdef2js :: (CId,(D.Type,D.Exp)) -> JS.Property -absdef2js (CId f,(typ,_)) = - let (args,CId cat) = M.catSkeleton typ in - JS.Prop (JS.StringPropName f) (new "Type" [JS.EArray [JS.EStr x | CId x <- args], JS.EStr cat]) - -concrete2js :: String -> String -> (CId,D.Concr) -> JS.Property -concrete2js start n (CId c, cnc) = - JS.Prop l (new "GFConcrete" ([(JS.EObj $ ((map (cncdef2js n c) ds) ++ litslins))] ++ - maybe [] (parser2js start) (D.parser cnc))) - where - l = JS.StringPropName c - ds = concatMap Map.assocs [D.lins cnc, D.opers cnc, D.lindefs cnc] - litslins = [JS.Prop (JS.StringPropName "Int") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]), - JS.Prop (JS.StringPropName "Float") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]), - JS.Prop (JS.StringPropName "String") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]])] - - -cncdef2js :: String -> String -> (CId,D.Term) -> JS.Property -cncdef2js n l (CId f, t) = JS.Prop (JS.StringPropName f) (JS.EFun [children] [JS.SReturn (term2js n l t)]) - -term2js :: String -> String -> D.Term -> JS.Expr -term2js n l t = f t - where - f t = - case t of - D.R xs -> new "Arr" (map f xs) - D.P x y -> JS.ECall (JS.EMember (f x) (JS.Ident "sel")) [f y] - D.S xs -> mkSeq (map f xs) - D.K t -> tokn2js t - D.V i -> JS.EIndex (JS.EVar children) (JS.EInt i) - D.C i -> new "Int" [JS.EInt i] - D.F (CId f) -> JS.ECall (JS.EMember (JS.EIndex (JS.EMember (JS.EVar $ JS.Ident n) (JS.Ident "concretes")) (JS.EStr l)) (JS.Ident "rule")) [JS.EStr f, JS.EVar children] - D.FV xs -> new "Variants" (map f xs) - D.W str x -> new "Suffix" [JS.EStr str, f x] - D.RP x y -> new "Rp" [f x, f y] - D.TM _ -> new "Meta" [] - -tokn2js :: D.Tokn -> JS.Expr -tokn2js (D.KS s) = mkStr s -tokn2js (D.KP ss vs) = mkSeq (map mkStr ss) -- FIXME - -mkStr :: String -> JS.Expr -mkStr s = new "Str" [JS.EStr s] - -mkSeq :: [JS.Expr] -> JS.Expr -mkSeq [x] = x -mkSeq xs = new "Seq" xs - -argIdent :: Integer -> JS.Ident -argIdent n = JS.Ident ("x" ++ show n) - -children :: JS.Ident -children = JS.Ident "cs" - --- Parser -parser2js :: String -> FCFPInfo -> [JS.Expr] -parser2js start p = [new "Parser" [JS.EStr start, - JS.EArray $ map frule2js (Array.elems (allRules p)), - JS.EObj $ map cats (Map.assocs (startupCats p))]] - where - cats (CId c,is) = JS.Prop (JS.StringPropName c) (JS.EArray (map JS.EInt is)) - -frule2js :: FRule -> JS.Expr -frule2js (FRule n args res lins) = new "Rule" [JS.EInt res, name2js n, JS.EArray (map JS.EInt args), lins2js lins] - -name2js :: FName -> JS.Expr -name2js n = case n of - Name (CId "_") [p] -> fromProfile p - Name f ps -> new "FunApp" $ [JS.EStr $ prCId f, JS.EArray (map fromProfile ps)] - where - fromProfile :: Profile (SyntaxForest CId) -> JS.Expr - fromProfile (Unify []) = new "MetaVar" [] - fromProfile (Unify [x]) = daughter x - fromProfile (Unify args) = new "Unify" [JS.EArray (map daughter args)] - fromProfile (Constant forest) = fromSyntaxForest forest - - daughter i = new "Arg" [JS.EInt i] - - fromSyntaxForest :: SyntaxForest CId -> JS.Expr - fromSyntaxForest FMeta = new "MetaVar" [] - -- FIXME: is there always just one element here? - fromSyntaxForest (FNode n [args]) = new "FunApp" $ [JS.EStr $ prCId n, JS.EArray (map fromSyntaxForest args)] - fromSyntaxForest (FString s) = new "Lit" $ [JS.EStr s] - fromSyntaxForest (FInt i) = new "Lit" $ [JS.EInt $ fromIntegral i] - fromSyntaxForest (FFloat f) = new "Lit" $ [JS.EDbl f] - -lins2js :: Array FIndex (Array FPointPos FSymbol) -> JS.Expr -lins2js ls = JS.EArray [ JS.EArray [ sym2js s | s <- Array.elems l] | l <- Array.elems ls] - -sym2js :: FSymbol -> JS.Expr -sym2js (FSymCat _ l n) = new "ArgProj" [JS.EInt n, JS.EInt l] -sym2js (FSymTok t) = new "Terminal" [JS.EStr t] - -new :: String -> [JS.Expr] -> JS.Expr -new f xs = JS.ENew (JS.Ident f) xs diff --git a/src/GF/Devel/GFI.hs b/src/GF/Devel/GFI.hs deleted file mode 100644 index f59bd15e6..000000000 --- a/src/GF/Devel/GFI.hs +++ /dev/null @@ -1,77 +0,0 @@ -module GF.Devel.GFI (mainGFI) where - -import GF.Command.Interpreter -import GF.Command.Importing -import GF.Command.Commands -import GF.GFCC.API - -import GF.Devel.UseIO -import GF.Devel.Arch -import GF.Infra.Option ---- Haskell's option lib - - -mainGFI :: [String] -> IO () -mainGFI xx = do - putStrLn welcome - env <- importInEnv emptyMultiGrammar xx - loop (GFEnv env [] 0) - return () - -loop :: GFEnv -> IO GFEnv -loop gfenv0 = do - let env = commandenv gfenv0 - putStrFlush (prompt env) - s <- getLine - let gfenv = gfenv0 {history = s : history gfenv0} - case words s of - - -- special commands, working on GFEnv - "i":args -> do - env1 <- importInEnv (multigrammar env) args - loopNewCPU $ gfenv {commandenv = env1} - "e":_ -> loopNewCPU $ gfenv {commandenv=env{multigrammar=emptyMultiGrammar}} - "ph":_ -> mapM_ putStrLn (reverse (history gfenv0)) >> loopNewCPU gfenv - "q":_ -> putStrLn "See you." >> return gfenv - - -- ordinary commands, working on CommandEnv - _ -> do - interpretCommandLine env s - loopNewCPU gfenv - -loopNewCPU gfenv = do - cpu <- prCPU $ cputime gfenv - loop $ gfenv {cputime = cpu} - -importInEnv mgr0 xx = do - let (opts,files) = getOptions "-" xx - mgr1 <- case files of - [] -> return mgr0 - _ -> importGrammar mgr0 opts files - let env = CommandEnv mgr1 (allCommands mgr1) - putStrLn $ unwords $ "\nLanguages:" : languages mgr1 - return env - -welcome = unlines [ - " ", - " * * * ", - " * * ", - " * * ", - " * ", - " * ", - " * * * * * * * ", - " * * * ", - " * * * * * * ", - " * * * ", - " * * * ", - " ", - "This is GF version 3.0 alpha. ", - "Some things may work. " - ] - -prompt env = abstractName (multigrammar env) ++ "> " - -data GFEnv = GFEnv { - commandenv :: CommandEnv, - history :: [String], - cputime :: Integer - } diff --git a/src/GF/Devel/GetGrammar.hs b/src/GF/Devel/GetGrammar.hs deleted file mode 100644 index cdd275ace..000000000 --- a/src/GF/Devel/GetGrammar.hs +++ /dev/null @@ -1,54 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GetGrammar --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/15 17:56:13 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.16 $ --- --- this module builds the internal GF grammar that is sent to the type checker ------------------------------------------------------------------------------ - -module GF.Devel.GetGrammar where - -import GF.Data.Operations -import qualified GF.Source.ErrM as E - -import GF.Devel.UseIO -import GF.Grammar.Grammar -import GF.Infra.Modules -import GF.Devel.PrGrammar -import qualified GF.Source.AbsGF as A -import GF.Source.SourceToGrammar ----- import Macros ----- import Rename -import GF.Infra.Option ---- import Custom -import GF.Source.ParGF -import qualified GF.Source.LexGF as L - -import GF.Devel.ReadFiles ---- - -import Data.Char (toUpper) -import Data.List (nub) -import qualified Data.ByteString.Char8 as BS -import Control.Monad (foldM) -import System (system) - -getSourceModule :: Options -> FilePath -> IOE SourceModule -getSourceModule opts file0 = do - file <- case getOptVal opts usePreprocessor of - Just p -> do - let tmp = "_gf_preproc.tmp" - cmd = p +++ file0 ++ ">" ++ tmp - ioeIO $ system cmd - -- ioeIO $ putStrLn $ "preproc" +++ cmd - return tmp - _ -> return file0 - string <- readFileIOE file - let tokens = myLexer string - mo1 <- ioeErr $ pModDef tokens - ioeErr $ transModDef mo1 diff --git a/src/GF/Devel/Grammar/AppPredefined.hs b/src/GF/Devel/Grammar/AppPredefined.hs deleted file mode 100644 index c8d2988fd..000000000 --- a/src/GF/Devel/Grammar/AppPredefined.hs +++ /dev/null @@ -1,166 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : AppPredefined --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/06 14:21:34 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.13 $ --- --- Predefined function type signatures and definitions. ------------------------------------------------------------------------------ - -module GF.Devel.Grammar.AppPredefined ( - isInPredefined, - typPredefined, - appPredefined - ) where - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Devel.Grammar.Macros -import GF.Devel.Grammar.PrGF (prt,prt_,prtBad) -import GF.Infra.Ident - -import GF.Data.Operations - - --- predefined function type signatures and definitions. AR 12/3/2003. - -isInPredefined :: Ident -> Bool -isInPredefined = err (const True) (const False) . typPredefined - -typPredefined :: Ident -> Err Type -typPredefined c@(IC f) = case f of - "Int" -> return typePType - "Float" -> return typePType - "Error" -> return typeType - "Ints" -> return $ mkFunType [cnPredef "Int"] typePType - "PBool" -> return typePType - "error" -> return $ mkFunType [typeStr] (cnPredef "Error") -- non-can. of empty set - "PFalse" -> return $ cnPredef "PBool" - "PTrue" -> return $ cnPredef "PBool" - "dp" -> return $ mkFunType [cnPredef "Int",typeStr] typeStr - "drop" -> return $ mkFunType [cnPredef "Int",typeStr] typeStr - "eqInt" -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool") - "lessInt"-> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool") - "eqStr" -> return $ mkFunType [typeStr,typeStr] (cnPredef "PBool") - "length" -> return $ mkFunType [typeStr] (cnPredef "Int") - "occur" -> return $ mkFunType [typeStr,typeStr] (cnPredef "PBool") - "occurs" -> return $ mkFunType [typeStr,typeStr] (cnPredef "PBool") - "plus" -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "Int") ----- "read" -> (P : Type) -> Tok -> P - "show" -> return $ mkProds -- (P : PType) -> P -> Tok - ([(identC "P",typePType),(wildIdent,Vr (identC "P"))],typeStr,[]) - "toStr" -> return $ mkProds -- (L : Type) -> L -> Str - ([(identC "L",typeType),(wildIdent,Vr (identC "L"))],typeStr,[]) - "mapStr" -> - let ty = identC "L" in - return $ mkProds -- (L : Type) -> (Str -> Str) -> L -> L - ([(ty,typeType),(wildIdent,mkFunType [typeStr] typeStr),(wildIdent,Vr ty)],Vr ty,[]) - "take" -> return $ mkFunType [cnPredef "Int",typeStr] typeStr - "tk" -> return $ mkFunType [cnPredef "Int",typeStr] typeStr - _ -> prtBad "unknown in Predef:" c - -typPredefined c = prtBad "unknown in Predef:" c - -mkProds (cont,t,xx) = foldr (uncurry Prod) (mkApp t xx) cont - -appPredefined :: Term -> Err (Term,Bool) -appPredefined t = case t of - - App f x0 -> do - (x,_) <- appPredefined x0 - case f of - -- one-place functions - Q (IC "Predef") (IC f) -> case (f, x) of - ("length", K s) -> retb $ EInt $ toInteger $ length s - _ -> retb t ---- prtBad "cannot compute predefined" t - - -- two-place functions - App (Q (IC "Predef") (IC f)) z0 -> do - (z,_) <- appPredefined z0 - case (f, norm z, norm x) of - ("drop", EInt i, K s) -> retb $ K (drop (fi i) s) - ("take", EInt i, K s) -> retb $ K (take (fi i) s) - ("tk", EInt i, K s) -> retb $ K (take (max 0 (length s - fi i)) s) - ("dp", EInt i, K s) -> retb $ K (drop (max 0 (length s - fi i)) s) - ("eqStr",K s, K t) -> retb $ if s == t then predefTrue else predefFalse - ("occur",K s, K t) -> retb $ if substring s t then predefTrue else predefFalse - ("occurs",K s, K t) -> retb $ if any (flip elem t) s then predefTrue else predefFalse - ("eqInt",EInt i, EInt j) -> retb $ if i==j then predefTrue else predefFalse - ("lessInt",EInt i, EInt j) -> retb $ if i<j then predefTrue else predefFalse - ("plus", EInt i, EInt j) -> retb $ EInt $ i+j - ("show", _, t) -> retb $ foldr C Empty $ map K $ words $ prt t - ("read", _, K s) -> retb $ str2tag s --- because of K, only works for atomic tags - ("toStr", _, t) -> trm2str t >>= retb - - _ -> retb t ---- prtBad "cannot compute predefined" t - - -- three-place functions - App (App (Q (IC "Predef") (IC f)) z0) y0 -> do - (y,_) <- appPredefined y0 - (z,_) <- appPredefined z0 - case (f, z, y, x) of - ("mapStr",ty,op,t) -> retf $ mapStr ty op t - _ -> retb t ---- prtBad "cannot compute predefined" t - - _ -> retb t ---- prtBad "cannot compute predefined" t - _ -> retb t - ---- should really check the absence of arg variables - where - retb t = return (t,True) -- no further computing needed - retf t = return (t,False) -- must be computed further - norm t = case t of - Empty -> K [] - _ -> t - fi = fromInteger - --- read makes variables into constants - -str2tag :: String -> Term -str2tag s = case s of ----- '\'' : cs -> mkCn $ pTrm $ init cs - _ -> Con $ IC s --- - where - mkCn t = case t of - Vr i -> Con i - App c a -> App (mkCn c) (mkCn a) - _ -> t - - -predefTrue = Q (IC "Predef") (IC "PTrue") -predefFalse = Q (IC "Predef") (IC "PFalse") - -substring :: String -> String -> Bool -substring s t = case (s,t) of - (c:cs, d:ds) -> (c == d && substring cs ds) || substring s ds - ([],_) -> True - _ -> False - -trm2str :: Term -> Err Term -trm2str t = case t of - R ((_,(_,s)):_) -> trm2str s - T _ ((_,s):_) -> trm2str s - V _ (s:_) -> trm2str s - C _ _ -> return $ t - K _ -> return $ t - S c _ -> trm2str c - Empty -> return $ t - _ -> prtBad "cannot get Str from term" t - --- simultaneous recursion on type and term: type arg is essential! --- But simplify the task by assuming records are type-annotated --- (this has been done in type checking) -mapStr :: Type -> Term -> Term -> Term -mapStr ty f t = case (ty,t) of - _ | elem ty [typeStr,typeStr] -> App f t - (_, R ts) -> R [(l,mapField v) | (l,v) <- ts] - (Table a b,T ti cs) -> T ti [(p,mapStr b f v) | (p,v) <- cs] - _ -> t - where - mapField (mty,te) = case mty of - Just ty -> (mty,mapStr ty f te) - _ -> (mty,te) diff --git a/src/GF/Devel/Grammar/Compute.hs b/src/GF/Devel/Grammar/Compute.hs deleted file mode 100644 index 5e465c160..000000000 --- a/src/GF/Devel/Grammar/Compute.hs +++ /dev/null @@ -1,380 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Compute --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/01 15:39:12 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.19 $ --- --- Computation of source terms. Used in compilation and in @cc@ command. ------------------------------------------------------------------------------ - -module GF.Devel.Grammar.Compute ( - computeTerm, - computeTermCont, - computeTermRec - ) where - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Devel.Grammar.Macros -import GF.Devel.Grammar.Lookup -import GF.Devel.Grammar.PrGF -import GF.Devel.Grammar.PatternMatch -import GF.Devel.Grammar.AppPredefined - -import GF.Infra.Ident -import GF.Infra.Option - ---import GF.Grammar.Refresh ---import GF.Grammar.Lockfield (isLockLabel) ---- - -import GF.Data.Str ---- -import GF.Data.Operations - -import Data.List (nub,intersperse) -import Control.Monad (liftM2, liftM) - --- | computation of concrete syntax terms into normal form --- used mainly for partial evaluation -computeTerm :: GF -> Term -> Err Term -computeTerm g t = {- refreshTerm t >>= -} computeTermCont g [] t -computeTermRec g t = {- refreshTerm t >>= -} computeTermOpt True g [] t - -computeTermCont :: GF -> Substitution -> Term -> Err Term -computeTermCont = computeTermOpt False - --- rec=True is used if it cannot be assumed that looked-up constants --- have already been computed (mainly with -optimize=noexpand in .gfr) - -computeTermOpt :: Bool -> GF -> Substitution -> Term -> Err Term -computeTermOpt rec 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 for 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, FV as) -> - mapM (\c -> comp (ext x c g) b) as >>= return . variants - (_, FV as) -> mapM (\c -> comp g (App f' c)) as >>= return . variants - (FV fs, _) -> mapM (\c -> comp g (App c a')) fs >>= return . variants - (Abs x b,_) -> comp (ext x a' g) b - (QC _ _,_) -> returnC $ App f' a' - - (S (T i cs) e,_) -> prawitz g i (flip App a') cs e - (S (V i cs) e,_) -> prawitzV g i (flip App a') cs e - - _ -> do - (t',b) <- appPredefined (App f' a') - if b then return t' else comp g t' - - P t l -> do - t' <- comp g t - case t' of - FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants - R r -> maybe (prtBad "no value for label" l) (comp g . snd) $ - lookup l $ reverse r - - ExtR a (R b) -> - case comp g (P (R b) l) of - Ok v -> return v - _ -> comp g (P a l) - ---- { - --- this is incorrect, since b can contain the proper value - 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) ---- - } --- - - - S (T i cs) e -> prawitz g i (flip P l) cs e - S (V i cs) e -> prawitzV g i (flip P l) cs e - - _ -> returnC $ P t' l - - PI t l i -> comp g $ P t l ----- - - S t@(T ti cc) v -> do - v' <- comp g v - case v' of - FV vs -> do - ts' <- mapM (comp g . S t) vs - return $ variants ts' - _ -> case ti of -{- - TComp _ -> do - case term2patt v' of - Ok p' -> case lookup p' cc of - Just u -> comp g u - _ -> do - t' <- comp g t - return $ S t' v' -- if v' is not canonical - _ -> do - t' <- comp g t - return $ S t' v' --} - _ -> case matchPattern cc v' of - Ok (c,g') -> comp (g' ++ g) c - _ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t - _ -> do - t' <- comp g t - return $ S t' v' -- if v' is not canonical - - - S t v -> do - - t' <- case t of ----- why not? ResFin.Agr "has no values" ----- T (TComp _) _ -> return t ----- V _ _ -> return t - _ -> comp g t - - v' <- comp g v - - case v' of - FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants - _ -> case t' of - FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants - - 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 - - -- course-of-values table: look up by index, no pattern matching needed - V ptyp ts -> do - vs <- allParamValues gr ptyp - case lookup v' (zip vs [0 .. length vs - 1]) of - Just i -> comp g $ ts !! i ------ _ -> prtBad "selection" $ S t' v' -- debug - _ -> return $ S t' v' -- if v' is not canonical - - T (TComp _) cs -> do - case term2patt v' of - Ok p' -> case lookup p' cs of - Just u -> comp g u - _ -> return $ S t' v' -- if v' is not canonical - _ -> return $ S t' v' - - T _ cc -> 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 - - - S (T i cs) e -> prawitz g i (flip S v') cs e - S (V i cs) e -> prawitzV g i (flip S v') cs e - _ -> returnC $ S t' v' - - -- normalize away empty tokens - K "" -> return Empty - - -- glue if you can - Glue x0 y0 -> do - x <- comp g x0 - y <- comp g y0 - case (x,y) of - (FV ks,_) -> do - kys <- mapM (comp g . flip Glue y) ks - return $ variants kys - (_,FV ks) -> do - xks <- mapM (comp g . Glue x) ks - return $ variants xks - - (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 - (S (V i cs) e, s) -> prawitzV g i (flip Glue s) cs e - (s, S (V i cs) e) -> prawitzV g i (Glue s) cs e - (_,Empty) -> return x - (Empty,_) -> return y - (K a, K b) -> return $ K (a ++ b) - (_, Alts (d,vs)) -> do ----- (K a, Alts (d,vs)) -> do - let glx = Glue x - comp g $ Alts (glx d, [(glx v,c) | (v,c) <- vs]) - (Alts _, ka) -> checks [do - y' <- strsFromTerm ka ----- (Alts _, K a) -> checks [do - x' <- strsFromTerm x -- this may fail when compiling opers - return $ variants [ - foldr1 C (map K (str2strings (glueStr v u))) | v <- x', u <- y'] ----- foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x'] - ,return $ Glue x y - ] - (C u v,_) -> comp g $ C u (Glue v y) - - _ -> 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 - case (a',b') of - (Alts _, K a) -> checks [do - as <- strsFromTerm a' -- this may fail when compiling opers - return $ variants [ - foldr1 C (map K (str2strings (plusStr v (str a)))) | v <- as] - , - return $ C a' b' - ] - (Empty,_) -> returnC b' - (_,Empty) -> returnC a' - _ -> returnC $ C a' b' - - -- reduce free variation as much as you can - FV ts -> mapM (comp g) ts >>= returnC . variants - - -- merge record extensions if you can - ExtR r s -> do - r' <- comp g r - s' <- comp g s - case (r',s') of - (R rs, R ss) -> plusRecord r' s' - (RecType rs, RecType ss) -> plusRecType r' s' - _ -> return $ ExtR r' s' - - -- case-expand tables - -- if already expanded, don't expand again - T i@(TComp ty) cs -> do - -- if there are no variables, don't even go inside - cs' <- if (null g) then return cs else mapPairsM (comp g) cs ----- return $ V ty (map snd cs') - return $ T i cs' - - T i cs -> do - pty0 <- errIn (prt t) $ getTableType i - ptyp <- comp g pty0 - case allParamValues gr ptyp of - Ok vs -> do - - cs' <- mapM (compBranchOpt g) cs ---- why is this needed?? - 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 $ V ptyp ts -- to save space ---- why doesn't this work?? - return $ T (TComp ptyp) (zip ps' ts) - _ -> do - cs' <- mapM (compBranch g) cs - return $ T i cs' -- happens with variable types - - -- otherwise go ahead - _ -> composOp (comp g) t >>= returnC - - where - - look p c - | rec = lookupOperDef gr p c >>= comp [] - | otherwise = lookupOperDef gr p c - -{- - look p c = case lookupResDefKind gr p c of - Ok (t,_) | noExpand p || rec -> comp [] t - Ok (t,_) -> return t - Bad s -> raise s - - noExpand p = errVal False $ do - mo <- lookupModMod gr p - return $ case getOptVal (iOpts (flags mo)) useOptimizer of - Just "noexpand" -> True - _ -> False --} - - ext x a g = (x,a):g - - returnC = return --- . computed - - variants ts = case nub ts of - [t] -> t - 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 - - PAs x p -> (x,Vr x) : contP p - - PSeq p q -> concatMap contP [p,q] - PAlt p q -> concatMap contP [p,q] - PRep p -> contP p - PNeg p -> contP p - - _ -> [] - - prawitz g i f cs e = do - cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs] - return $ S (T i cs') e - prawitzV g i f cs e = do - cs' <- mapM (comp g) [(f v) | v <- cs] - return $ S (V i cs') e - --- | argument variables cannot be glued -checkNoArgVars :: Term -> Err Term -checkNoArgVars t = case t of - Vr (IA _) -> Bad $ glueErrorMsg $ prt t - Vr (IAV _) -> Bad $ glueErrorMsg $ prt t - _ -> composOp checkNoArgVars t - -glueErrorMsg s = - "Cannot glue (+) term with run-time variable" +++ s ++ "." ++++ - "Use Prelude.bind instead." diff --git a/src/GF/Devel/Grammar/Construct.hs b/src/GF/Devel/Grammar/Construct.hs deleted file mode 100644 index 5b4215843..000000000 --- a/src/GF/Devel/Grammar/Construct.hs +++ /dev/null @@ -1,221 +0,0 @@ -module GF.Devel.Grammar.Construct where - -import GF.Devel.Grammar.Grammar -import GF.Infra.Ident - -import GF.Data.Operations - -import Control.Monad -import Data.Map -import Debug.Trace (trace) - ------------------- --- abstractions on Grammar, constructing objects ------------------- - --- abstractions on GF - -emptyGF :: GF -emptyGF = GF Nothing [] empty empty - -type SourceModule = (Ident,Module) - -listModules :: GF -> [SourceModule] -listModules = assocs.gfmodules - -addModule :: Ident -> Module -> GF -> GF -addModule c m gf = gf {gfmodules = insert c m (gfmodules gf)} - -gfModules :: [(Ident,Module)] -> GF -gfModules ms = emptyGF {gfmodules = fromList ms} - --- abstractions on Module - -emptyModule :: Module -emptyModule = Module MTGrammar True [] [] [] [] empty empty - -isCompleteModule :: Module -> Bool -isCompleteModule = miscomplete - -isInterface :: Module -> Bool -isInterface m = case mtype m of - MTInterface -> True - MTAbstract -> True - _ -> False - -interfaceName :: Module -> Maybe Ident -interfaceName mo = case mtype mo of - MTInstance i -> return i - MTConcrete i -> return i - _ -> Nothing - -listJudgements :: Module -> [(Ident,Judgement)] -listJudgements = assocs . mjments - -isInherited :: MInclude -> Ident -> Bool -isInherited mi i = case mi of - MIExcept is -> notElem i is - MIOnly is -> elem i is - _ -> True - --- abstractions on Judgement - -isConstructor :: Judgement -> Bool -isConstructor j = jdef j == EData - -isLink :: Judgement -> Bool -isLink j = jform j == JLink - --- constructing judgements from parse tree - -emptyJudgement :: JudgementForm -> Judgement -emptyJudgement form = Judgement form meta meta meta (identC "#") 0 where - meta = Meta 0 - -addJType :: Type -> Judgement -> Judgement -addJType tr ju = ju {jtype = tr} - -addJDef :: Term -> Judgement -> Judgement -addJDef tr ju = ju {jdef = tr} - -addJPrintname :: Term -> Judgement -> Judgement -addJPrintname tr ju = ju {jprintname = tr} - -linkInherited :: Bool -> Ident -> Judgement -linkInherited can mo = (emptyJudgement JLink){ - jlink = mo, - jdef = if can then EData else Meta 0 - } - -absCat :: Context -> Judgement -absCat co = addJType (mkProd co typeType) (emptyJudgement JCat) - -absFun :: Type -> Judgement -absFun ty = addJType ty (emptyJudgement JFun) - -cncCat :: Type -> Judgement -cncCat ty = addJType ty (emptyJudgement JLincat) - -cncFun :: Term -> Judgement -cncFun tr = addJDef tr (emptyJudgement JLin) - -resOperType :: Type -> Judgement -resOperType ty = addJType ty (emptyJudgement JOper) - -resOperDef :: Term -> Judgement -resOperDef tr = addJDef tr (emptyJudgement JOper) - -resOper :: Type -> Term -> Judgement -resOper ty tr = addJDef tr (resOperType ty) - -resOverload :: [(Type,Term)] -> Judgement -resOverload tts = resOperDef (Overload tts) - --- param p = ci gi is encoded as p : ((ci : gi) -> p) -> Type --- we use EData instead of p to make circularity check easier -resParam :: Ident -> [(Ident,Context)] -> Judgement -resParam p cos = addJDef (EParam (Con p) cos) (addJType typePType (emptyJudgement JParam)) - --- to enable constructor type lookup: --- create an oper for each constructor p = c g, as c : g -> p = EData -paramConstructors :: Ident -> [(Ident,Context)] -> [(Ident,Judgement)] -paramConstructors p cs = [(c,resOper (mkProd co (Con p)) EData) | (c,co) <- cs] - --- unifying contents of judgements - ----- used in SourceToGF; make error-free and informative -unifyJudgements j k = case unifyJudgement j k of - Ok l -> l - Bad s -> error s - -unifyJudgement :: Judgement -> Judgement -> Err Judgement -unifyJudgement old new = do - testErr (jform old == jform new) "different judment forms" - [jty,jde,jpri] <- mapM unifyField [jtype,jdef,jprintname] - return $ old{jtype = jty, jdef = jde, jprintname = jpri} - where - unifyField field = unifyTerm (field old) (field new) - unifyTerm oterm nterm = case (oterm,nterm) of - (Meta _,t) -> return t - (t,Meta _) -> return t - _ -> do - if (nterm /= oterm) - then (trace (unwords ["illegal update of",show oterm,"to",show nterm]) - (return ())) - else return () ---- to recover from spurious qualification conflicts ----- testErr (nterm == oterm) ----- (unwords ["illegal update of",prt oterm,"to",prt nterm]) - return nterm - -updateJudgement :: Ident -> Ident -> Judgement -> GF -> Err GF -updateJudgement m c ju gf = do - mo <- maybe (Bad (show m)) return $ Data.Map.lookup m $ gfmodules gf - let mo' = mo {mjments = insert c ju (mjments mo)} - return $ gf {gfmodules = insert m mo' (gfmodules gf)} - --- abstractions on Term - -type Cat = QIdent -type Fun = QIdent -type QIdent = (Ident,Ident) - --- | branches à la Alfa -newtype Branch = Branch (Con,([Ident],Term)) deriving (Eq, Ord,Show,Read) -type Con = Ident --- - -varLabel :: Int -> Label -varLabel = LVar - -wildPatt :: Patt -wildPatt = PW - -type Trm = Term - -mkProd :: Context -> Type -> Type -mkProd = flip (foldr (uncurry Prod)) - --- type constants - -typeType :: Type -typeType = Sort "Type" - -typePType :: Type -typePType = Sort "PType" - -typeStr :: Type -typeStr = Sort "Str" - -typeTok :: Type ---- deprecated -typeTok = Sort "Tok" - -cPredef :: Ident -cPredef = identC "Predef" - -cPredefAbs :: Ident -cPredefAbs = identC "PredefAbs" - -typeString, typeFloat, typeInt :: Term -typeInts :: Integer -> Term - -typeString = constPredefRes "String" -typeInt = constPredefRes "Int" -typeFloat = constPredefRes "Float" -typeInts i = App (constPredefRes "Ints") (EInt i) - -isTypeInts :: Term -> Bool -isTypeInts ty = case ty of - App c _ -> c == constPredefRes "Ints" - _ -> False - -cnPredef = constPredefRes - -constPredefRes :: String -> Term -constPredefRes s = Q (IC "Predef") (identC s) - -isPredefConstant :: Term -> Bool -isPredefConstant t = case t of - Q (IC "Predef") _ -> True - Q (IC "PredefAbs") _ -> True - _ -> False - - diff --git a/src/GF/Devel/Grammar/GFtoSource.hs b/src/GF/Devel/Grammar/GFtoSource.hs deleted file mode 100644 index 292f5b826..000000000 --- a/src/GF/Devel/Grammar/GFtoSource.hs +++ /dev/null @@ -1,223 +0,0 @@ -module GF.Devel.Grammar.GFtoSource ( - trGrammar, - trModule, - trAnyDef, - trLabel, - trt, - tri, - trp - ) where - - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Devel.Grammar.Macros (contextOfType) -import qualified GF.Devel.Compile.AbsGF as P -import GF.Infra.Ident - -import GF.Data.Operations - -import qualified Data.Map as Map - --- From internal source syntax to BNFC-generated (used for printing). --- | AR 13\/5\/2003 --- --- translate internal to parsable and printable source - -trGrammar :: GF -> P.Grammar -trGrammar = P.Gr . map trModule . listModules -- no includes - -trModule :: (Ident,Module) -> P.ModDef -trModule (i,mo) = P.MModule compl typ body where - compl = case isCompleteModule mo of - False -> P.CMIncompl - _ -> P.CMCompl - i' = tri i - typ = case mtype mo of - MTGrammar -> P.MGrammar i' - MTAbstract -> P.MAbstract i' - MTConcrete a -> P.MConcrete i' (tri a) - MTInterface -> P.MInterface i' - MTInstance a -> P.MInstance i' (tri a) - body = P.MBody - (trExtends (mextends mo)) - (mkOpens (map trOpen (mopens mo))) - (concatMap trAnyDef [(c,j) | (c,j) <- listJudgements mo] ++ - map trFlag (Map.assocs (mflags mo))) - -trExtends :: [(Ident,MInclude)] -> P.Extend -trExtends [] = P.NoExt -trExtends es = (P.Ext $ map tre es) where - tre (i,c) = case c of - MIAll -> P.IAll (tri i) - MIOnly is -> P.ISome (tri i) (map tri is) - MIExcept is -> P.IMinus (tri i) (map tri is) - -trOpen :: (Ident,Ident) -> P.Open -trOpen (i,j) = P.OQual (tri i) (tri j) - -mkOpens ds = if null ds then P.NoOpens else P.OpenIn ds - -trAnyDef :: (Ident,Judgement) -> [P.TopDef] -trAnyDef (i,ju) = let - i' = mkName i - i0 = tri i - in case jform ju of - JCat -> [P.DefCat [P.SimpleCatDef i0 []]] ---- (map trDecl co)]] - JFun -> [P.DefFun [P.FDecl [i'] (trt (jtype ju))]] - ---- ++ case pt of - ---- Yes t -> [P.DefDef [P.DDef [mkName i'] (trt t)]] - ---- _ -> [] - ---- JFun ty EData -> [P.DefFunData [P.FunDef [i'] (trt ty)]] - JParam -> [P.DefPar [ - P.ParDefDir i0 [ - P.ParConstr (tri c) (map trDecl co) | let EParam _ cos = jdef ju, (c,co) <- cos] - ]] - JOper -> case jdef ju of - Overload tysts -> - [P.DefOper [P.DDef [i'] ( - P.EApp (P.EPIdent $ ppIdent "overload") - (P.ERecord [P.LDFull [i0] (trt ty) (trt fu) | (ty,fu) <- tysts]))]] - tr -> [P.DefOper [trDef i (jtype ju) tr]] - JLincat -> [P.DefLincat [P.DDef [i'] (trt (jtype ju))]] - ---- CncCat pty ptr ppr -> - ---- [P.DefLindef [trDef i' pty ptr]] - ---- ++ [P.DefPrintCat [P.DDef [mkName i] (trt pr)] | Yes pr <- [ppr]] - JLin -> - [P.DefLin [trDef i (Meta 0) (jdef ju)]] - ---- ++ [P.DefPrintFun [P.DDef [mkName i] (trt pr)] | Yes pr <- [ppr]] - JLink -> [] - -trDef :: Ident -> Type -> Term -> P.Def -trDef i pty ptr = case (pty,ptr) of - (Meta _, Meta _) -> P.DDef [mkName i] (P.EMeta) --- - (_, Meta _) -> P.DDecl [mkName i] (trPerh pty) - (Meta _, _) -> P.DDef [mkName i] (trPerh ptr) - (_, _) -> P.DFull [mkName i] (trPerh pty) (trPerh ptr) - -trPerh p = case p of - Meta _ -> P.EMeta - _ -> trt p - -trFlag :: (Ident,String) -> P.TopDef -trFlag (f,x) = P.DefFlag [P.DDef [mkName f] (P.EString x)] - -trt :: Term -> P.Exp -trt trm = case trm of - Vr s -> P.EPIdent $ tri s ----- Cn s -> P.ECons $ tri s - Con s -> P.EConstr $ tri s - 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 -> P.EEqs [P.Equ (map trp ps) (trt t) | (ps,t) <- pts] - 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) - - Example t s -> P.EExample (trt t) s - R [] -> P.ETuple [] --- to get correct parsing when read back - 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) - PI 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) - V ty cc -> P.EVTable (trt ty) (map trt cc) - - Typed tr ty -> P.ETyped (trt tr) (trt ty) - Table x v -> P.ETType (trt x) (trt v) - S f x -> P.ESelect (trt f) (trt x) - 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 i - EFloat i -> P.EFloat i - - EPatt p -> P.EPatt (trp p) - EPattType t -> P.EPattType (trt t) - - 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 - EData -> P.EData - EParam t _ -> trt t - - _ -> error $ "not yet" +++ show trm ---- - -trp :: Patt -> P.Patt -trp p = case p of - PChar -> P.PChar - PChars s -> P.PChars s - PM m c -> P.PM (tri m) (tri c) - PW -> P.PW - 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] - PString s -> P.PStr s - PInt i -> P.PInt i - PFloat i -> P.PFloat i - PT t p -> trp p ---- prParenth (prt p +++ ":" +++ prt t) - - PAs x p -> P.PAs (tri x) (trp p) - - PAlt p q -> P.PDisj (trp p) (trp q) - PSeq p q -> P.PSeq (trp p) (trp q) - PRep p -> P.PRep (trp p) - PNeg p -> P.PNeg (trp p) - - -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 (trp patt) (trt trm) -trCases (patts,trm) = P.Case (foldl1 P.PDisj (map trp patts)) (trt trm) - -trDecl (x,ty) = P.DDDec [trb x] (trt ty) - -tri :: Ident -> P.PIdent -tri i = ppIdent (prIdent i) - -ppIdent i = P.PIdent ((0,0),i) - -trb i = if isWildIdent i then P.BWild else P.BPIdent (tri i) - -trLabel :: Label -> P.Label -trLabel i = case i of - LIdent s -> P.LPIdent $ ppIdent s - LVar i -> P.LVar $ toInteger i - -trLabelIdent i = ppIdent $ case i of - LIdent s -> s - LVar i -> "v" ++ show i --- should not happen - -mkName :: Ident -> P.Name -mkName = P.PIdentName . tri - diff --git a/src/GF/Devel/Grammar/Grammar.hs b/src/GF/Devel/Grammar/Grammar.hs deleted file mode 100644 index df5a3907e..000000000 --- a/src/GF/Devel/Grammar/Grammar.hs +++ /dev/null @@ -1,172 +0,0 @@ -module GF.Devel.Grammar.Grammar where - -import GF.Infra.Ident - -import GF.Data.Operations - -import Data.Map - - ------------------- --- definitions -- ------------------- - -data GF = GF { - gfabsname :: Maybe Ident , - gfcncnames :: [Ident] , - gflags :: Map Ident String , -- value of a global flag - gfmodules :: Map Ident Module - } - -data Module = Module { - mtype :: ModuleType, - miscomplete :: Bool, - minterfaces :: [(Ident,Ident)], -- non-empty for functors - minstances :: [((Ident,MInclude),[(Ident,Ident)])], -- non-empty for inst'ions - mextends :: [(Ident,MInclude)], - mopens :: [(Ident,Ident)], -- used name, original name - mflags :: Map Ident String, - mjments :: Map Ident Judgement - } - -data ModuleType = - MTAbstract - | MTConcrete Ident - | MTInterface - | MTInstance Ident - | MTGrammar - deriving Eq - -data MInclude = - MIAll - | MIExcept [Ident] - | MIOnly [Ident] - -type Indirection = (Ident,Bool) -- module of origin, whether canonical - -data Judgement = Judgement { - jform :: JudgementForm, -- cat fun lincat lin oper param - jtype :: Type, -- context type lincat - type PType - jdef :: Term, -- lindef def lindef lin def constrs - jprintname :: Term, -- - - prname prname - - - jlink :: Ident, -- if inherited, the supermodule name, else # - jposition :: Int -- line number where def begins - } - deriving Show - -data JudgementForm = - JCat - | JFun - | JLincat - | JLin - | JOper - | JParam - | JLink - deriving (Eq,Show) - -type Type = Term - -data Term = - Vr Ident -- ^ variable - | Con Ident -- ^ constructor - | EData -- ^ to mark in definition that a fun is a constructor - | Sort String -- ^ predefined type - | EInt Integer -- ^ integer literal - | EFloat Double -- ^ floating point literal - | K String -- ^ string literal or token: @\"foo\"@ - | Empty -- ^ the empty string @[]@ - - | App Term Term -- ^ application: @f a@ - | Abs Ident Term -- ^ abstraction: @\x -> b@ - | Meta MetaSymb -- ^ metavariable: @?i@ (only parsable: ? = ?0) - | Prod Ident Term Term -- ^ function type: @(x : A) -> B@ - | Eqs [Equation] -- ^ abstraction by cases: @fn {x y -> b ; z u -> c}@ - -- only used in internal representation - | Typed Term Term -- ^ type-annotated term --- --- /below this, the constructors are only for concrete syntax/ - | Example Term String -- ^ example-based term: @in M.C "foo" - | RecType [Labelling] -- ^ record type: @{ p : A ; ...}@ - | R [Assign] -- ^ record: @{ p = a ; ...}@ - | P Term Label -- ^ projection: @r.p@ - | PI Term Label Int -- ^ index-annotated projection - | ExtR Term Term -- ^ extension: @R ** {x : A}@ (both types and terms) - - | Table Term Term -- ^ table type: @P => A@ - | T TInfo [Case] -- ^ table: @table {p => c ; ...}@ - | V Type [Term] -- ^ course of values: @table T [c1 ; ... ; cn]@ - | S Term Term -- ^ selection: @t ! p@ - | Val Type Int -- ^ parameter value number: @T # i# - - | Let LocalDef Term -- ^ local definition: @let {t : T = a} in b@ - - | Q Ident Ident -- ^ qualified constant from a module - | QC Ident Ident -- ^ qualified constructor from a module - - | C Term Term -- ^ concatenation: @s ++ t@ - | Glue Term Term -- ^ agglutination: @s + t@ - - | EPatt Patt - | EPattType Term - - | EParam Term [(Ident,Context)] -- to encode parameter constructor sets - - | FV [Term] -- ^ free variation: @variants { s ; ... }@ - - | Alts (Term, [(Term, Term)]) -- ^ prefix-dependent: @pre {t ; s\/c ; ...}@ - - | Overload [(Type,Term)] - - deriving (Read, Show, Eq, Ord) - -data Patt = - PC Ident [Patt] -- ^ constructor pattern: @C p1 ... pn@ @C@ - | PP Ident Ident [Patt] -- ^ qualified constr patt: @P.C p1 ... pn@ @P.C@ - | PV Ident -- ^ variable pattern: @x@ - | PW -- ^ wild card pattern: @_@ - | PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@ - | PString String -- ^ string literal pattern: @\"foo\"@ - | PInt Integer -- ^ integer literal pattern: @12@ - | PFloat Double -- ^ float literal pattern: @1.2@ - | PT Type Patt -- ^ type-annotated pattern - | PAs Ident Patt -- ^ as-pattern: x@p - - -- regular expression patterns - | PNeg Patt -- ^ negated pattern: -p - | PAlt Patt Patt -- ^ disjunctive pattern: p1 | p2 - | PSeq Patt Patt -- ^ sequence of token parts: p + q - | PRep Patt -- ^ repetition of token part: p* - | PChar -- ^ string of length one: ? - | PChars String -- ^ list of characters: ["aeiou"] - - | PMacro Ident -- #p - | PM Ident Ident -- #m.p - - deriving (Read, Show, Eq, Ord) - --- | to guide computation and type checking of tables -data TInfo = - TRaw -- ^ received from parser; can be anything - | TTyped Type -- ^ type annotated, but can be anything - | TComp Type -- ^ expanded - | TWild Type -- ^ just one wild card pattern, no need to expand - deriving (Read, Show, Eq, Ord) - --- | record label -data Label = - LIdent String - | LVar Int - deriving (Read, Show, Eq, Ord) - -type MetaSymb = Int - -type Decl = (Ident,Term) -- (x:A) (_:A) A -type Context = [Decl] -- (x:A)(y:B) (x,y:A) (_,_:A) -type Substitution = [(Ident, Term)] -type Equation = ([Patt],Term) - -type Labelling = (Label, Term) -type Assign = (Label, (Maybe Type, Term)) -type Case = (Patt, Term) -type LocalDef = (Ident, (Maybe Type, Term)) - diff --git a/src/GF/Devel/Grammar/Lookup.hs b/src/GF/Devel/Grammar/Lookup.hs deleted file mode 100644 index 689996760..000000000 --- a/src/GF/Devel/Grammar/Lookup.hs +++ /dev/null @@ -1,168 +0,0 @@ -module GF.Devel.Grammar.Lookup where - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Devel.Grammar.Macros -import GF.Devel.Grammar.PrGF -import GF.Infra.Ident - -import GF.Data.Operations - -import Control.Monad (liftM) -import Data.Map -import Data.List (sortBy) ---- - --- look up fields for a constant in a grammar - -lookupJField :: (Judgement -> a) -> GF -> Ident -> Ident -> Err a -lookupJField field gf m c = do - j <- lookupJudgement gf m c - return $ field j - -lookupJForm :: GF -> Ident -> Ident -> Err JudgementForm -lookupJForm = lookupJField jform - --- the following don't (need to) check that the jment form is adequate - -lookupCatContext :: GF -> Ident -> Ident -> Err Context -lookupCatContext gf m c = do - ty <- lookupJField jtype gf m c - return $ contextOfType ty - -lookupFunType :: GF -> Ident -> Ident -> Err Term -lookupFunType = lookupJField jtype - -lookupLin :: GF -> Ident -> Ident -> Err Term -lookupLin = lookupJField jdef - -lookupLincat :: GF -> Ident -> Ident -> Err Term -lookupLincat = lookupJField jtype - -lookupOperType :: GF -> Ident -> Ident -> Err Term -lookupOperType gr m c = do - ju <- lookupJudgement gr m c - case jform ju of - JParam -> return typePType - _ -> case jtype ju of - Meta _ -> fail ("no type given to " ++ prIdent m ++ "." ++ prIdent c) - ty -> return ty ----- can't be just lookupJField jtype - -lookupOperDef :: GF -> Ident -> Ident -> Err Term -lookupOperDef = lookupJField jdef - -lookupOverload :: GF -> Ident -> Ident -> Err [([Type],(Type,Term))] -lookupOverload gr m c = do - tr <- lookupJField jdef gr m c - case tr of - Overload tysts -> return - [(lmap snd args,(val,tr)) | (ty,tr) <- tysts, let (args,val) = prodForm ty] - _ -> Bad $ prt c +++ "is not an overloaded operation" - -lookupParams :: GF -> Ident -> Ident -> Err [(Ident,Context)] -lookupParams gf m c = do - EParam _ ty <- lookupJField jdef gf m c - return ty - -lookupParamConstructor :: GF -> Ident -> Ident -> Err Type -lookupParamConstructor = lookupJField jtype - -lookupParamValues :: GF -> Ident -> Ident -> Err [Term] -lookupParamValues gf m c = do - ps <- lookupParams gf m c - liftM concat $ mapM mkPar ps - where - mkPar (f,co) = do - vs <- liftM combinations $ mapM (\ (_,ty) -> allParamValues gf ty) co - return $ lmap (mkApp (QC m f)) vs - -lookupFlags :: GF -> Ident -> [(Ident,String)] -lookupFlags gf m = errVal [] $ do - mo <- lookupModule gf m - return $ toList $ mflags mo - -allParamValues :: GF -> Type -> Err [Term] -allParamValues cnc ptyp = case ptyp of - App (Q (IC "Predef") (IC "Ints")) (EInt n) -> - return [EInt i | i <- [0..n]] - QC p c -> lookupParamValues cnc p c - Q p c -> lookupParamValues cnc p c ---- - - RecType r -> do - let (ls,tys) = unzip $ sortByFst r - tss <- mapM allPV tys - return [R (zipAssign ls ts) | ts <- combinations tss] - _ -> prtBad "cannot find parameter values for" ptyp - where - allPV = allParamValues cnc - -- to normalize records and record types - sortByFst = sortBy (\ x y -> compare (fst x) (fst y)) - -abstractOfConcrete :: GF -> Ident -> Err Ident -abstractOfConcrete gf m = do - mo <- lookupModule gf m - case mtype mo of - MTConcrete a -> return a - MTInstance a -> return a - MTGrammar -> return m - _ -> prtBad "not concrete module" m - -allOrigJudgements :: GF -> Ident -> [(Ident,Judgement)] -allOrigJudgements gf m = errVal [] $ do - mo <- lookupModule gf m - return [ju | ju@(_,j) <- listJudgements mo, jform j /= JLink] - -allConcretes :: GF -> Ident -> [Ident] -allConcretes gf m = - [c | (c,mo) <- toList (gfmodules gf), mtype mo == MTConcrete m] - --- | select just those modules that a given one depends on, including itself -partOfGrammar :: GF -> (Ident,Module) -> GF -partOfGrammar gr (i,mo) = gr { - gfmodules = fromList [m | m@(j,_) <- mos, elem j modsFor] - } - where - mos = toList $ gfmodules gr - modsFor = i : allDepsModule gr mo - -allDepsModule :: GF -> Module -> [Ident] -allDepsModule gr m = iterFix add os0 where - os0 = depPathModule m - add os = [m | o <- os, Just n <- [llookup o mods], m <- depPathModule n] - mods = toList $ gfmodules gr - --- | initial dependency list -depPathModule :: Module -> [Ident] -depPathModule mo = fors ++ lmap fst (mextends mo) ++ lmap snd (mopens mo) where - fors = case mtype mo of - MTConcrete i -> [i] - MTInstance i -> [i] - _ -> [] - --- infrastructure for lookup - -lookupModule :: GF -> Ident -> Err Module -lookupModule gf m = do - maybe (raiseIdent "module not found:" m) return $ mlookup m (gfmodules gf) - --- this finds the immediate definition, which can be a link -lookupIdent :: GF -> Ident -> Ident -> Err Judgement -lookupIdent gf m c = do - mo <- lookupModule gf m - maybe (raiseIdent "constant not found:" c) return $ mlookup c (mjments mo) - --- this follows the link -lookupJudgement :: GF -> Ident -> Ident -> Err Judgement -lookupJudgement gf m c = do - ju <- lookupIdent gf m c - case jform ju of - JLink -> lookupJudgement gf (jlink ju) c - _ -> return ju - -mlookup = Data.Map.lookup - -raiseIdent msg i = raise (msg +++ prIdent i) - -lmap = Prelude.map -llookup = Prelude.lookup - diff --git a/src/GF/Devel/Grammar/Macros.hs b/src/GF/Devel/Grammar/Macros.hs deleted file mode 100644 index 1a7a3582c..000000000 --- a/src/GF/Devel/Grammar/Macros.hs +++ /dev/null @@ -1,434 +0,0 @@ -module GF.Devel.Grammar.Macros where - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Infra.Ident - -import GF.Data.Str -import GF.Data.Operations - -import qualified Data.Map as Map -import Control.Monad (liftM,liftM2) - - --- analyse types and terms - -contextOfType :: Type -> Context -contextOfType ty = co where (co,_,_) = typeForm ty - -typeForm :: Type -> (Context,Term,[Term]) -typeForm t = (co,f,a) where - (co,t2) = prodForm t - (f,a) = appForm t2 - -termForm :: Term -> ([Ident],Term,[Term]) -termForm t = (co,f,a) where - (co,t2) = absForm t - (f,a) = appForm t2 - -prodForm :: Type -> (Context,Term) -prodForm t = case t of - Prod x ty val -> ((x,ty):co,t2) where (co,t2) = prodForm val - _ -> ([],t) - -absForm :: Term -> ([Ident],Term) -absForm t = case t of - Abs x val -> (x:co,t2) where (co,t2) = absForm val - _ -> ([],t) - - -appForm :: Term -> (Term,[Term]) -appForm tr = (f,reverse xs) where - (f,xs) = apps tr - apps t = case t of - App f a -> (f2,a:a2) where (f2,a2) = appForm f - _ -> (t,[]) - -valCat :: Type -> Err (Ident,Ident) -valCat typ = case typeForm typ of - (_,Q m c,_) -> return (m,c) - -typeRawSkeleton :: Type -> Err ([(Int,Type)],Type) -typeRawSkeleton typ = do - let (cont,typ) = prodForm typ - args <- mapM (typeRawSkeleton . snd) cont - return ([(length c, v) | (c,v) <- args], typ) - -type MCat = (Ident,Ident) - -sortMCat :: String -> MCat -sortMCat s = (identC "_", identC s) - ---- hack for Editing.actCat in empty state -errorCat :: MCat -errorCat = (identC "?", identC "?") - -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 - _ -> error $ "no qualified constant" +++ show t - -typeSkeleton :: Type -> Err ([(Int,MCat)],MCat) -typeSkeleton typ = do - (cont,val) <- typeRawSkeleton typ - cont' <- mapPairsM getMCat cont - val' <- getMCat val - return (cont',val') - --- construct types and terms - -mkFunType :: [Type] -> Type -> Type -mkFunType tt t = mkProd ([(wildIdent, ty) | ty <- tt]) t -- nondep prod - -mkApp :: Term -> [Term] -> Term -mkApp = foldl App - -mkAbs :: [Ident] -> Term -> Term -mkAbs xs t = foldr Abs t xs - -mkCTable :: [Ident] -> Term -> Term -mkCTable ids v = foldr ccase v ids where - ccase x t = T TRaw [(PV x,t)] - -appCons :: Ident -> [Term] -> Term -appCons = mkApp . Con - -appc :: String -> [Term] -> Term -appc = appCons . identC - -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] - -tupleLabel :: Int -> Label -tupleLabel i = LIdent $ "p" ++ show i - -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 - -mkDecl :: Term -> Decl -mkDecl typ = (wildIdent, typ) - -mkLet :: [LocalDef] -> Term -> Term -mkLet defs t = foldr Let t defs - -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 - -plusRecType :: Type -> Type -> Err Type -plusRecType t1 t2 = case (t1, t2) of - (RecType r1, RecType r2) -> case - filter (`elem` (map fst r1)) (map fst r2) of - [] -> return (RecType (r1 ++ r2)) - ls -> Bad $ "clashing labels" +++ unwords (map show ls) - _ -> Bad ("cannot add record types" +++ show t1 +++ "and" +++ show t2) - -plusRecord :: Term -> Term -> Err Term -plusRecord t1 t2 = - case (t1,t2) of - (R r1, R r2 ) -> return (R ([(l,v) | -- overshadowing of old fields - (l,v) <- r1, not (elem l (map fst r2)) ] ++ r2)) - (_, FV rs) -> mapM (plusRecord t1) rs >>= return . FV - (FV rs,_ ) -> mapM (`plusRecord` t2) rs >>= return . FV - _ -> Bad ("cannot add records" +++ show t1 +++ "and" +++ show t2) - -zipAssign :: [Label] -> [Term] -> [Assign] -zipAssign ls ts = [assign l t | (l,t) <- zip ls ts] - - -defLinType :: Type -defLinType = RecType [(LIdent "s", typeStr)] - -meta0 :: Term -meta0 = Meta 0 - -ident2label :: Ident -> Label -ident2label c = LIdent (prIdent c) - -label2ident :: Label -> Ident -label2ident (LIdent c) = identC c - -----label2ident :: Label -> Ident -----label2ident = identC . prLabel - --- to apply a term operation to every term in a judgement, module, grammar - -termOpGF :: Monad m => (Term -> m Term) -> GF -> m GF -termOpGF f = moduleOpGF (termOpModule f) - -moduleOpGF :: Monad m => (Module -> m Module) -> GF -> m GF -moduleOpGF f g = do - ms <- mapMapM f (gfmodules g) - return g {gfmodules = ms} - -termOpModule :: Monad m => (Term -> m Term) -> Module -> m Module -termOpModule f = judgementOpModule fj where - fj = termOpJudgement f - -judgementOpModule :: Monad m => (Judgement -> m Judgement) -> Module -> m Module -judgementOpModule f m = do - mjs <- mapMapM f (mjments m) - return m {mjments = mjs} - -entryOpModule :: Monad m => - (Ident -> Judgement -> m Judgement) -> Module -> m Module -entryOpModule f m = do - mjs <- liftM Map.fromAscList $ mapm $ Map.assocs $ mjments m - return $ m {mjments = mjs} - where - mapm = mapM (\ (i,j) -> liftM ((,) i) (f i j)) - -termOpJudgement :: Monad m => (Term -> m Term) -> Judgement -> m Judgement -termOpJudgement f j = do - jtyp <- f (jtype j) - jde <- f (jdef j) - jpri <- f (jprintname j) - return $ j { - jtype = jtyp, - jdef = jde, - jprintname = jpri - } - --- | to define compositional term functions -composSafeOp :: (Term -> Term) -> Term -> Term -composSafeOp op trm = case composOp (mkMonadic op) trm of - Ok t -> t - _ -> error "the operation is safe isn't it ?" - where - mkMonadic f = return . f - --- | to define compositional monadic term functions -composOp :: Monad m => (Term -> m Term) -> Term -> m Term -composOp co trm = case trm of - App c a -> - do c' <- co c - a' <- co a - return (App c' a') - Abs x b -> - do b' <- co b - return (Abs x b') - Prod x a b -> - do a' <- co a - b' <- co b - return (Prod x a' b') - S c a -> - do c' <- co c - a' <- co a - return (S c' a') - Table a c -> - do a' <- co a - c' <- co c - return (Table a' c') - R r -> - do r' <- mapAssignM co r - return (R r') - RecType r -> - do r' <- mapPairListM (co . snd) r - return (RecType r') - P t i -> - do t' <- co t - return (P t' i) - PI t i j -> - do t' <- co t - return (PI t' i j) - ExtR a c -> - do a' <- co a - c' <- co c - return (ExtR a' c') - T i cc -> - do cc' <- mapPairListM (co . snd) cc - i' <- changeTableType co i - return (T i' cc') - Eqs cc -> - do cc' <- mapPairListM (co . snd) cc - return (Eqs cc') - EParam ty cos -> - do ty' <- co ty - cos' <- mapPairListM (mapPairListM (co . snd) . snd) cos - return (EParam ty' cos') - V ty vs -> - do ty' <- co ty - vs' <- mapM co vs - return (V ty' vs') - Let (x,(mt,a)) b -> - do a' <- co a - mt' <- case mt of - Just t -> co t >>= (return . Just) - _ -> return mt - b' <- co b - return (Let (x,(mt',a')) b') - C s1 s2 -> - do v1 <- co s1 - v2 <- co s2 - return (C v1 v2) - Glue s1 s2 -> - do v1 <- co s1 - v2 <- co s2 - return (Glue v1 v2) - Alts (t,aa) -> - do t' <- co t - aa' <- mapM (pairM co) aa - return (Alts (t',aa')) - FV ts -> mapM co ts >>= return . FV - Overload tts -> do - tts' <- mapM (pairM co) tts - return $ Overload tts' - - EPattType ty -> - do ty' <- co ty - return (EPattType ty') - - _ -> return trm -- covers K, Vr, Cn, Sort - - ----- should redefine using composOp -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 - V _ cc -> concatMap co cc --- 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 - _ -> [] -- covers K, Vr, Cn, Sort, Ready - ---- just aux to composOp? - -mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))] -mapAssignM f = mapM (\ (ls,tv) -> liftM ((,) ls) (g tv)) - where g (t,v) = liftM2 (,) (maybe (return Nothing) (liftM Just . f) t) (f v) - -changeTableType :: Monad m => (Type -> m Type) -> TInfo -> m TInfo -changeTableType co i = case i of - TTyped ty -> co ty >>= return . TTyped - TComp ty -> co ty >>= return . TComp - TWild ty -> co ty >>= return . TWild - _ -> return i - - -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 - PFloat i -> EFloat i - PString s -> K s - - PAs x p -> appc "@" [Vr x, patt2term p] --- an encoding - PSeq a b -> appc "+" [(patt2term a), (patt2term b)] --- an encoding - PAlt a b -> appc "|" [(patt2term a), (patt2term b)] --- an encoding - PRep a -> appc "*" [(patt2term a)] --- an encoding - PNeg a -> appc "-" [(patt2term a)] --- an encoding - - -term2patt :: Term -> Err Patt -term2patt trm = case Ok (termForm trm) of - Ok ([], Vr x, []) -> return (PV x) - 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 ([],EFloat i,[]) -> return $ PFloat i - Ok ([],K s, []) -> return $ PString s - ---- encodings due to excessive use of term-patt convs. AR 7/1/2005 - Ok ([], Con (IC "@"), [Vr a,b]) -> do - b' <- term2patt b - return (PAs a b') - Ok ([], Con (IC "-"), [a]) -> do - a' <- term2patt a - return (PNeg a') - Ok ([], Con (IC "*"), [a]) -> do - a' <- term2patt a - return (PRep a') - Ok ([], Con (IC "+"), [a,b]) -> do - a' <- term2patt a - b' <- term2patt b - return (PSeq a' b') - Ok ([], Con (IC "|"), [a,b]) -> do - a' <- term2patt a - b' <- term2patt b - return (PAlt a' b') - - Ok ([], Con c, aa) -> do - aa' <- mapM term2patt aa - return (PC c aa') - - _ -> Bad $ "no pattern corresponds to term" +++ show trm - -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" - --- | to get a string from a term that represents a sequence of terminals -strsFromTerm :: Term -> Err [Str] -strsFromTerm t = case t of - K s -> return [str s] - Empty -> return [str []] - 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 - _ -> Bad $ "cannot get Str from term" +++ show t - - - ----- given in lib? - -mapMapM :: (Monad m, Ord k) => (v -> m v) -> Map.Map k v -> m (Map.Map k v) -mapMapM f = - liftM Map.fromAscList . mapM (\ (x,y) -> liftM ((,) x) $ f y) . Map.assocs - diff --git a/src/GF/Devel/Grammar/PatternMatch.hs b/src/GF/Devel/Grammar/PatternMatch.hs deleted file mode 100644 index ec64d7802..000000000 --- a/src/GF/Devel/Grammar/PatternMatch.hs +++ /dev/null @@ -1,146 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PatternMatch --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/12 12:38:29 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.7 $ --- --- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003 ------------------------------------------------------------------------------ - -module GF.Devel.Grammar.PatternMatch (matchPattern, - testOvershadow, - findMatch - ) where - - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Macros -import GF.Devel.Grammar.PrGF -import GF.Infra.Ident - -import GF.Data.Operations - -import Data.List -import Control.Monad - - -matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution) -matchPattern pts term = - if not (isInConstantForm term) - then prtBad "variables occur in" term - else - 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 - let t' = termForm t - trym p t' - where - isInConstantFormt = True -- tested already - trym p t' = - case (p,t') of - (_,(x,Empty,y)) -> trym p (x,K [],y) -- because "" = [""] = [] - (PV IW, _) | isInConstantFormt -> return [] -- optimization with wildcard - (PV x, _) | isInConstantFormt -> return [(x,t)] - (PString s, ([],K i,[])) | s==i -> return [] - (PInt s, ([],EInt i,[])) | s==i -> return [] - (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding? - (PC p pp, ([], Con f, tt)) | - p `eqStrIdent` f && length pp == length tt -> - do matches <- mapM tryMatch (zip pp tt) - return (concat matches) - - (PP q p pp, ([], QC r f, tt)) | - -- q `eqStrIdent` r && --- not for inherited AR 10/10/2005 - p `eqStrIdent` f && length pp == length tt -> - do matches <- mapM tryMatch (zip pp tt) - return (concat matches) - ---- hack for AppPredef bug - (PP q p pp, ([], Q r f, tt)) | - -- q `eqStrIdent` r && --- - p `eqStrIdent` f && length pp == length tt -> - do matches <- mapM tryMatch (zip pp tt) - return (concat matches) - - (PR r, ([],R r',[])) | - all (`elem` map fst r') (map fst r) -> - do matches <- mapM tryMatch - [(p,snd a) | (l,p) <- r, let Just a = lookup l r'] - return (concat matches) - (PT _ p',_) -> trym p' t' - --- (PP (IC "Predef") (IC "CC") [p1,p2], ([],K s, [])) -> do - - (PAs x p',_) -> do - subst <- trym p' t' - return $ (x,t) : subst - - (PAlt p1 p2,_) -> checks [trym p1 t', trym p2 t'] - - (PNeg p',_) -> case tryMatch (p',t) of - Bad _ -> return [] - _ -> prtBad "no match with negative pattern" p - - (PSeq p1 p2, ([],K s, [])) -> do - let cuts = [splitAt n s | n <- [0 .. length s]] - matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts] - return (concat matches) - - (PRep p1, ([],K s, [])) -> checks [ - trym (foldr (const (PSeq p1)) (PString "") - [1..n]) t' | n <- [0 .. length s] - ] >> - return [] - - (PChar, ([],K [_], [])) -> return [] - (PChars cs, ([],K [c], [])) | elem c cs -> return [] - - _ -> prtBad "no match in case expr for" t - -eqStrIdent = (==) ---- - -isInConstantForm :: Term -> Bool -isInConstantForm trm = case trm of - Con _ -> True - Q _ _ -> True - QC _ _ -> True - Abs _ _ -> True - App c a -> isInConstantForm c && isInConstantForm a - R r -> all (isInConstantForm . snd . snd) r - K _ -> True - Empty -> True - EInt _ -> True - _ -> 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 - _ -> [] - diff --git a/src/GF/Devel/Grammar/PrGF.hs b/src/GF/Devel/Grammar/PrGF.hs deleted file mode 100644 index 221a0ac61..000000000 --- a/src/GF/Devel/Grammar/PrGF.hs +++ /dev/null @@ -1,246 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PrGrammar --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/09/04 11:45:38 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.16 $ --- --- AR 7\/12\/1999 - 1\/4\/2000 - 10\/5\/2003 - 4/12/2007 --- --- printing and prettyprinting class for source grammar --- --- 8\/1\/2004: --- Usually followed principle: 'prt_' for displaying in the editor, 'prt' --- in writing grammars to a file. For some constructs, e.g. 'prMarkedTree', --- only the former is ever needed. ------------------------------------------------------------------------------ - -module GF.Devel.Grammar.PrGF where - -import qualified GF.Devel.Compile.PrintGF as P -import GF.Devel.Grammar.GFtoSource -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -----import GF.Grammar.Values - -----import GF.Infra.Option -import GF.Infra.Ident -import GF.Infra.CompactPrint -----import GF.Data.Str - -import GF.Data.Operations -----import GF.Data.Zipper - -import Data.List (intersperse) - -class Print a where - prt :: a -> String - -- | printing with parentheses, if needed - prt2 :: a -> String - -- | pretty printing - prpr :: a -> [String] - -- | printing without ident qualifications - prt_ :: a -> String - prt2 = prt - prt_ = prt - prpr = return . prt - --- 8/1/2004 ---- Usually followed principle: prt_ for displaying in the editor, prt ---- in writing grammars to a file. For some constructs, e.g. prMarkedTree, ---- only the former is ever needed. - -cprintTree :: P.Print a => a -> String -cprintTree = compactPrint . P.printTree - --- | to show terms etc in error messages -prtBad :: Print a => String -> a -> Err b -prtBad s a = Bad (s +++ prt a) - -prGF :: GF -> String -prGF = cprintTree . trGrammar - -instance Print GF where - prt = cprintTree . trGrammar - -prModule :: SourceModule -> String -prModule = cprintTree . trModule - -instance Print Judgement where - prt j = cprintTree $ trAnyDef (wildIdent, j) ----- prt_ = prExp - -instance Print Term where - prt = cprintTree . trt ----- prt_ = prExp - -instance Print Ident where - prt = cprintTree . 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] - - --- 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 - 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)) - --- | a pretty-printer for parsable output -tree2string :: Tree -> String -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 - prt VType = "Type" - -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) = prQuotedString s - prt (AtI i) = show i - prt (AtF i) = show i - prt_ (AtC (_,f)) = prt f - prt_ a = prt a - -prQIdent :: QIdent -> String -prQIdent (m,f) = prt m ++ "." ++ prt f - -prQIdent_ :: QIdent -> String -prQIdent_ (_,f) = 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 - --- | option @-strip@ strips qualifications -prTermOpt :: Options -> Term -> String -prTermOpt opts = if oElem nostripQualif opts then prt else prExp - --- | to get rid of brackets in the editor -prRefinement :: Term -> String -prRefinement t = case t of - Q m c -> prQIdent (m,c) - QC m c -> prQIdent (m,c) - _ -> prt t - -prOperSignature :: (QIdent,Type) -> String -prOperSignature (f, t) = prQIdent f +++ ":" +++ prt t - --- to look up a constant etc in a search tree - -lookupIdent :: Ident -> BinTree Ident b -> Err b -lookupIdent c t = case lookupTree prt c t of - Ok v -> return v - _ -> prtBad "unknown identifier" c - -lookupIdentInfo :: Module Ident f a -> Ident -> Err a -lookupIdentInfo mo i = lookupIdent i (jments mo) --} diff --git a/src/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs deleted file mode 100644 index 2c1bbc169..000000000 --- a/src/GF/Devel/GrammarToGFCC.hs +++ /dev/null @@ -1,545 +0,0 @@ -module GF.Devel.GrammarToGFCC (prGrammar2gfcc,mkCanon2gfcc,addParsers) where - -import GF.Devel.OptimizeGF (unshareModule) - -import GF.Grammar.Grammar -import qualified GF.Grammar.Lookup as Look - -import qualified GF.GFCC.Macros as CM -import qualified GF.GFCC.DataGFCC as C -import qualified GF.GFCC.DataGFCC as D -import GF.GFCC.CId -import qualified GF.Grammar.Abstract as A -import qualified GF.Grammar.Macros as GM ---import qualified GF.Grammar.Compute as Compute -import qualified GF.Infra.Modules as M -import qualified GF.Infra.Option as O - -import GF.Conversion.SimpleToFCFG (convertConcrete) -import GF.Parsing.FCFG.PInfo (buildFCFPInfo) -import GF.Devel.PrGrammar -import GF.Devel.PrintGFCC -import GF.Devel.ModDeps -import GF.Infra.Ident -import GF.Infra.Option -import GF.Data.Operations -import GF.Text.UTF8 - -import Data.List -import Data.Char (isDigit,isSpace) -import qualified Data.Map as Map -import Debug.Trace ---- - --- when developing, swap commenting - ---traceD s t = trace s t -traceD s t = t - - --- the main function: generate GFCC from GF. - -prGrammar2gfcc :: Options -> String -> SourceGrammar -> (String,String) -prGrammar2gfcc opts cnc gr = (abs,printGFCC gc) where - (abs,gc) = mkCanon2gfcc opts cnc gr - -mkCanon2gfcc :: Options -> String -> SourceGrammar -> (String,D.GFCC) -mkCanon2gfcc opts cnc gr = - (prIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon abs) gr) - where - abs = err error id $ M.abstractOfConcrete gr (identC cnc) - pars = mkParamLincat gr - --- Adds parsers for all concretes -addParsers :: D.GFCC -> D.GFCC -addParsers gfcc = gfcc { D.concretes = Map.map conv (D.concretes gfcc) } - where - conv cnc = cnc { D.parser = Just (buildFCFPInfo (convertConcrete (D.abstract gfcc) cnc)) } - --- Generate GFCC from GFCM. --- this assumes a grammar translated by canon2canon - -canon2gfcc :: Options -> (Ident -> Ident -> C.Term) -> SourceGrammar -> D.GFCC -canon2gfcc opts pars cgr@(M.MGrammar ((a,M.ModMod abm):cms)) = - (if (oElem (iOpt "show_canon") opts) then trace (prGrammar cgr) else id) $ - D.GFCC an cns gflags abs cncs - where - -- abstract - an = (i2i a) - cns = map (i2i . fst) cms - abs = D.Abstr aflags funs cats catfuns - gflags = Map.fromList [(CId fg,x) | Just x <- [getOptVal opts (aOpt fg)]] - where fg = "firstlang" - aflags = Map.fromList [(CId f,x) | Opt (f,[x]) <- M.flags abm] - mkDef pty = case pty of - Yes t -> mkExp t - _ -> CM.primNotion - - -- concretes - lfuns = [(f', (mkType ty, mkDef pty)) | - (f,AbsFun (Yes ty) pty) <- tree2list (M.jments abm), let f' = i2i f] - funs = Map.fromAscList lfuns - lcats = [(i2i c, mkContext cont) | - (c,AbsCat (Yes cont) _) <- tree2list (M.jments abm)] - cats = Map.fromAscList lcats - catfuns = Map.fromList - [(cat,[f | (f, (C.DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats] - - cncs = Map.fromList [mkConcr lang (i2i lang) mo | (lang,M.ModMod mo) <- cms] - mkConcr lang0 lang mo = - (lang,D.Concr flags lins opers lincats lindefs printnames params fcfg) - where - js = tree2list (M.jments mo) - flags = Map.fromList [(CId f,x) | Opt (f,[x]) <- M.flags mo] - opers = Map.fromAscList [] -- opers will be created as optimization - utf = if elem (Opt ("coding",["utf8"])) (M.flags mo) - then D.convertStringsInTerm decodeUTF8 else id - lins = Map.fromAscList - [(i2i f, utf (mkTerm tr)) | (f,CncFun _ (Yes tr) _) <- js] - lincats = Map.fromAscList - [(i2i c, mkCType ty) | (c,CncCat (Yes ty) _ _) <- js] - lindefs = Map.fromAscList - [(i2i c, mkTerm tr) | (c,CncCat _ (Yes tr) _) <- js] - printnames = Map.union - (Map.fromAscList [(i2i f, mkTerm tr) | (f,CncFun _ _ (Yes tr)) <- js]) - (Map.fromAscList [(i2i f, mkTerm tr) | (f,CncCat _ _ (Yes tr)) <- js]) - params = Map.fromAscList - [(i2i c, pars lang0 c) | (c,CncCat (Yes ty) _ _) <- js] - fcfg = Nothing - -i2i :: Ident -> CId -i2i = CId . prIdent - -mkType :: A.Type -> C.Type -mkType t = case GM.typeForm t of - Ok (hyps,(_,cat),args) -> C.DTyp (mkContext hyps) (i2i cat) (map mkExp args) - -mkExp :: A.Term -> C.Exp -mkExp t = case t of - A.Eqs eqs -> C.EEq [C.Equ (map mkPatt ps) (mkExp e) | (ps,e) <- eqs] - _ -> case GM.termForm t of - Ok (xx,c,args) -> C.DTr [i2i x | x <- xx] (mkAt c) (map mkExp args) - where - mkAt c = case c of - Q _ c -> C.AC $ i2i c - QC _ c -> C.AC $ i2i c - Vr x -> C.AV $ i2i x - EInt i -> C.AI i - EFloat f -> C.AF f - K s -> C.AS s - Meta (MetaSymb i) -> C.AM $ toInteger i - _ -> C.AM 0 - mkPatt p = uncurry CM.tree $ case p of - A.PP _ c ps -> (C.AC (i2i c), map mkPatt ps) - A.PV x -> (C.AV (i2i x), []) - A.PW -> (C.AV CM.wildCId, []) - A.PInt i -> (C.AI i, []) - -mkContext :: A.Context -> [C.Hypo] -mkContext hyps = [C.Hyp (i2i x) (mkType ty) | (x,ty) <- hyps] - -mkTerm :: Term -> C.Term -mkTerm tr = case tr of - Vr (IA (_,i)) -> C.V i - Vr (IAV (_,_,i)) -> C.V i - Vr (IC s) | isDigit (last s) -> - C.V (read (reverse (takeWhile (/='_') (reverse s)))) - ---- from gf parser of gfc - EInt i -> C.C $ fromInteger i - R rs -> C.R [mkTerm t | (_, (_,t)) <- rs] - P t l -> C.P (mkTerm t) (C.C (mkLab l)) - TSh _ _ -> error $ show tr - T _ cs -> C.R [mkTerm t | (_,t) <- cs] ------ - V _ cs -> C.R [mkTerm t | t <- cs] - S t p -> C.P (mkTerm t) (mkTerm p) - C s t -> C.S $ concatMap flats [mkTerm x | x <- [s,t]] - FV ts -> C.FV [mkTerm t | t <- ts] - K s -> C.K (C.KS s) ------ K (KP ss _) -> C.K (C.KP ss []) ---- TODO: prefix variants - Empty -> C.S [] - App _ _ -> prtTrace tr $ C.C 66661 ---- for debugging - Abs _ t -> mkTerm t ---- only on toplevel - Alts (td,tvs) -> - C.K (C.KP (strings td) [C.Var (strings u) (strings v) | (u,v) <- tvs]) - _ -> prtTrace tr $ C.S [C.K (C.KS (A.prt tr +++ "66662"))] ---- for debugging - where - mkLab (LIdent l) = case l of - '_':ds -> (read ds) :: Int - _ -> prtTrace tr $ 66663 - strings t = case t of - K s -> [s] - C u v -> strings u ++ strings v - Strs ss -> concatMap strings ss - _ -> prtTrace tr $ ["66660"] - flats t = case t of - C.S ts -> concatMap flats ts - _ -> [t] - --- encoding GFCC-internal lincats as terms -mkCType :: Type -> C.Term -mkCType t = case t of - EInt i -> C.C $ fromInteger i - RecType rs -> C.R [mkCType t | (_, t) <- rs] - Table pt vt -> case pt of - EInt i -> C.R $ replicate (1 + fromInteger i) $ mkCType vt - RecType rs -> mkCType $ foldr Table vt (map snd rs) - Sort "Str" -> C.S [] --- Str only - App (Q (IC "Predef") (IC "Ints")) (EInt i) -> C.C $ fromInteger i - _ -> error $ "mkCType " ++ show t - --- encoding showable lincats (as in source gf) as terms -mkParamLincat :: SourceGrammar -> Ident -> Ident -> C.Term -mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do - typ <- Look.lookupLincat sgr lang cat - mkPType typ - where - mkPType typ = case typ of - RecType lts -> do - ts <- mapM (mkPType . snd) lts - return $ C.R [ C.P (kks $ prt_ l) t | ((l,_),t) <- zip lts ts] - Table (RecType lts) v -> do - ps <- mapM (mkPType . snd) lts - v' <- mkPType v - return $ foldr (\p v -> C.S [p,v]) v' ps - Table p v -> do - p' <- mkPType p - v' <- mkPType v - return $ C.S [p',v'] - Sort "Str" -> return $ C.S [] - _ -> return $ - C.FV $ map (kks . filter showable . prt_) $ - errVal [] $ Look.allParamValues sgr typ - showable c = not (isSpace c) ---- || (c == ' ') -- to eliminate \n in records - kks = C.K . C.KS - --- return just one module per language - -reorder :: Ident -> SourceGrammar -> SourceGrammar -reorder abs cg = M.MGrammar $ - (abs, M.ModMod $ - M.Module M.MTAbstract M.MSComplete aflags [] [] adefs): - [(c, M.ModMod $ - M.Module (M.MTConcrete abs) M.MSComplete fs [] [] (sorted2tree js)) - | (c,(fs,js)) <- cncs] - where - mos = M.allModMod cg - adefs = sorted2tree $ sortIds $ - predefADefs ++ Look.allOrigInfos cg abs - predefADefs = - [(IC c, AbsCat (Yes []) Nope) | c <- ["Float","Int","String"]] - aflags = nubFlags $ - concat [M.flags mo | (_,mo) <- M.allModMod cg, M.isModAbs mo] - - cncs = sortIds [(lang, concr lang) | lang <- M.allConcretes cg abs] - concr la = (nubFlags flags, - sortIds (predefCDefs ++ jments)) where - jments = Look.allOrigInfos cg la - flags = concat [M.flags mo | - (i,mo) <- mos, M.isModCnc mo, - Just r <- [lookup i (M.allExtendSpecs cg la)]] - - predefCDefs = - (IC "Int", CncCat (Yes Look.linTypeInt) Nope Nope) : - [(IC c, CncCat (Yes GM.defLinType) Nope Nope) | - ---- lindef,printname - c <- ["Float","String"]] - - sortIds = sortBy (\ (f,_) (g,_) -> compare f g) - nubFlags = nubBy (\ (Opt (f,_)) (Opt (g,_)) -> f == g) - - --- one grammar per language - needed for symtab generation -repartition :: Ident -> SourceGrammar -> [SourceGrammar] -repartition abs cg = [M.partOfGrammar cg (lang,mo) | - let mos = M.allModMod cg, - lang <- M.allConcretes cg abs, - let mo = errVal - (error ("no module found for " ++ A.prt lang)) $ M.lookupModule cg lang - ] - - --- translate tables and records to arrays, parameters and labels to indices - -canon2canon :: Ident -> SourceGrammar -> SourceGrammar -canon2canon abs = - recollect . map cl2cl . repartition abs . purgeGrammar abs - where - recollect = M.MGrammar . nubBy (\ (i,_) (j,_) -> i==j) . concatMap M.modules - cl2cl = M.MGrammar . js2js . map (c2c p2p) . M.modules - - js2js ms = map (c2c (j2j (M.MGrammar ms))) ms - - c2c f2 (c,m) = case m of - M.ModMod mo@(M.Module _ _ _ _ _ js) -> - (c, M.ModMod $ M.replaceJudgements mo $ mapTree f2 js) - _ -> (c,m) - j2j cg (f,j) = case j of - CncFun x (Yes tr) z -> (f,CncFun x (Yes (t2t tr)) z) - CncCat (Yes ty) (Yes x) y -> (f,CncCat (Yes (ty2ty ty)) (Yes (t2t x)) y) - _ -> (f,j) - where - t2t = term2term cg pv - ty2ty = type2type cg pv - pv@(labels,untyps,typs) = trs $ paramValues cg - - -- flatten record arguments of param constructors - p2p (f,j) = case j of - ResParam (Yes (ps,v)) -> - (f,ResParam (Yes ([(c,concatMap unRec cont) | (c,cont) <- ps],Nothing))) - _ -> (f,j) - unRec (x,ty) = case ty of - RecType fs -> [ity | (_,typ) <- fs, ity <- unRec (identW,typ)] - _ -> [(x,ty)] - ----- - trs v = traceD (tr v) v - - tr (labels,untyps,typs) = - ("LABELS:" ++++ - unlines [A.prt c ++ "." ++ unwords (map A.prt l) +++ "=" +++ show i | - ((c,l),i) <- Map.toList labels]) ++++ - ("UNTYPS:" ++++ unlines [A.prt t +++ "=" +++ show i | - (t,i) <- Map.toList untyps]) ++++ - ("TYPS:" ++++ unlines [A.prt t +++ "=" +++ show (Map.assocs i) | - (t,i) <- Map.toList typs]) ----- - -purgeGrammar :: Ident -> SourceGrammar -> SourceGrammar -purgeGrammar abstr gr = - (M.MGrammar . list . map unopt . filter complete . purge . M.modules) gr - where - list ms = traceD ("MODULES" +++ unwords (map (prt . fst) ms)) ms - purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst) - needed = nub $ concatMap (requiredCanModules isSingle gr) acncs - acncs = abstr : M.allConcretes gr abstr - isSingle = True - complete (i,M.ModMod m) = M.isCompleteModule m --- not . isIncompleteCanon - unopt = unshareModule gr -- subexp elim undone when compiled - -type ParamEnv = - (Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels - Map.Map Term Integer, -- untyped terms to values - Map.Map Type (Map.Map Term Integer)) -- types to their terms to values - ---- gathers those param types that are actually used in lincats and lin terms -paramValues :: SourceGrammar -> ParamEnv -paramValues cgr = (labels,untyps,typs) where - partyps = nub $ - --- [App (Q (IC "Predef") (IC "Ints")) (EInt i) | i <- [1,9]] ---linTypeInt -{- - [ty | - (_,(_,CncCat (Yes (RecType ls)) _ _)) <- jments, - ty0 <- [ty | (_, ty) <- unlockTyp ls], - ty <- typsFrom ty0 --} - [ty | - (_,(_,CncCat (Yes ty0) _ _)) <- jments, - ty <- typsFrom ty0 - ] ++ [ - Q m ty | - (m,(ty,ResParam _)) <- jments - ] ++ [ty | - (_,(_,CncFun _ (Yes tr) _)) <- jments, - ty <- err (const []) snd $ appSTM (typsFromTrm tr) [] - ] - params = [(ty, errVal (traceD ("UNKNOWN PARAM TYPE" +++ show ty) []) $ - Look.allParamValues cgr ty) | ty <- partyps] - typsFrom ty = unlockTy ty : case ty of - Table p t -> typsFrom p ++ typsFrom t - RecType ls -> concat [typsFrom t | (_, t) <- ls] - _ -> [] - - typsFromTrm :: Term -> STM [Type] Term - typsFromTrm tr = case tr of - R fs -> mapM_ (typsFromField . snd) fs >> return tr - where - typsFromField (mty, t) = case mty of - Just x -> updateSTM (x:) >> typsFromTrm t - _ -> typsFromTrm t - V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr - T (TTyped ty) cs -> - updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr - T (TComp ty) cs -> - updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr - _ -> GM.composOp typsFromTrm tr - - jments = - [(m,j) | (m,mo) <- M.allModMod cgr, j <- tree2list $ M.jments mo] - typs = - Map.fromList [(ci,Map.fromList (zip vs [0..])) | (ci,vs) <- params] - untyps = - Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs] - lincats = - [(IC "Int",[f | let RecType fs = Look.linTypeInt, f <- fs])] ++ - [(IC cat,[(LIdent "s",GM.typeStr)]) | cat <- ["Float", "String"]] ++ - reverse ---- TODO: really those lincats that are reached - ---- reverse is enough to expel overshadowed ones... - [(cat,ls) | (_,(cat,CncCat (Yes ty) _ _)) <- jments, - RecType ls <- [unlockTy ty]] ----- [(cat,(unlockTyp ls)) | (_,(cat,CncCat (Yes (RecType ls)) _ _)) <- jments] - labels = Map.fromList $ concat - [((cat,[lab]),(typ,i)): - [((cat,[LVar v]),(typ,toInteger (mx + v))) | v <- [0,1]] ++ ---- 1 or 2 vars - [((cat,[lab,lab2]),(ty,j)) | - rs <- getRec typ, ((lab2, ty),j) <- zip rs [0..]] - | - (cat,ls) <- lincats, ((lab, typ),i) <- zip ls [0..], let mx = length ls] - -- go to tables recursively - ---- TODO: even go to deeper records - where - getRec typ = case typ of - RecType rs -> [rs] ---- [unlockTyp rs] -- (sort (unlockTyp ls)) - Table _ t -> getRec t - _ -> [] - -type2type :: SourceGrammar -> ParamEnv -> Type -> Type -type2type cgr env@(labels,untyps,typs) ty = case ty of - RecType rs -> - RecType [(mkLab i, t2t t) | (i,(l, t)) <- zip [0..] (unlockTyp rs)] - Table pt vt -> Table (t2t pt) (t2t vt) - QC _ _ -> look ty - _ -> ty - where - t2t = type2type cgr env - look ty = EInt $ (+ (-1)) $ toInteger $ case Map.lookup ty typs of - Just vs -> length $ Map.assocs vs - _ -> trace ("unknown partype " ++ show ty) 66669 - -term2term :: SourceGrammar -> ParamEnv -> Term -> Term -term2term cgr env@(labels,untyps,typs) tr = case tr of - App _ _ -> mkValCase (unrec tr) - QC _ _ -> mkValCase tr - R rs -> R [(mkLab i, (Nothing, t2t t)) | - (i,(l,(_,t))) <- zip [0..] (sort (unlock rs))] - P t l -> r2r tr - PI t l i -> EInt $ toInteger i - - T (TWild _) _ -> error $ "wild" +++ prt tr - T (TComp ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc - T (TTyped ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc - V ty ts -> mkCurry $ V ty [t2t t | t <- ts] - S t p -> mkCurrySel (t2t t) (t2t p) - - _ -> GM.composSafeOp t2t tr - where - t2t = term2term cgr env - - unrec t = case t of - App f (R fs) -> GM.mkApp (unrec f) [unrec u | (_,(_,u)) <- fs] - _ -> GM.composSafeOp unrec t - - mkValCase tr = case appSTM (doVar tr) [] of - Ok (tr', st@(_:_)) -> t2t $ comp $ foldr mkCase tr' st - _ -> valNum $ comp tr - - --- this is mainly needed for parameter record projections - ---- was: errVal t $ Compute.computeConcreteRec cgr t - comp t = case t of - T (TComp typ) ts -> comp $ V typ (map (comp . snd) ts) ---- should... - T (TTyped typ) ts -> comp $ V typ (map (comp . snd) ts) ---- should - V typ ts -> V typ (map comp ts) - S tb (FV ts) -> FV $ map (comp . S tb) ts - S (V typ ts) v0 -> err error id $ do - let v = comp v0 - return $ maybe t (comp . (ts !!) . fromInteger) $ Map.lookup v untyps - R r -> R [(l,(ty,comp t)) | (l,(ty,t)) <- r] - P (R r) l -> maybe t (comp . snd) $ lookup l r - _ -> GM.composSafeOp comp t - - doVar :: Term -> STM [((Type,[Term]),(Term,Term))] Term - doVar tr = case getLab tr of - Ok (cat, lab) -> do - k <- readSTM >>= return . length - let tr' = Vr $ identC $ show k ----- - - let tyvs = case Map.lookup (cat,lab) labels of - Just (ty,_) -> case Map.lookup ty typs of - Just vs -> (ty,[t | - (t,_) <- sortBy (\x y -> compare (snd x) (snd y)) - (Map.assocs vs)]) - _ -> error $ "doVar1" +++ A.prt ty - _ -> error $ "doVar2" +++ A.prt tr +++ show (cat,lab) ---- debug - updateSTM ((tyvs, (tr', tr)):) - return tr' - _ -> GM.composOp doVar tr - - r2r tr@(P (S (V ty ts) v) l) = t2t $ S (V ty [comp (P t l) | t <- ts]) v - - r2r tr@(P p _) = case getLab tr of - Ok (cat,labs) -> P (t2t p) . mkLab $ - maybe (prtTrace tr $ 66664) snd $ - Map.lookup (cat,labs) labels - _ -> K ((A.prt tr +++ prtTrace tr "66665")) - - -- this goes recursively into tables (ignored) and records (accumulated) - getLab tr = case tr of - Vr (IA (cat, _)) -> return (identC cat,[]) - Vr (IAV (cat,_,_)) -> return (identC cat,[]) - Vr (IC s) -> return (identC cat,[]) where - cat = takeWhile (/='_') s ---- also to match IAVs; no _ in a cat tolerated - ---- init (reverse (dropWhile (/='_') (reverse s))) ---- from gf parser ----- Vr _ -> error $ "getLab " ++ show tr - P p lab2 -> do - (cat,labs) <- getLab p - return (cat,labs++[lab2]) - S p _ -> getLab p - _ -> Bad "getLab" - - - mkCase ((ty,vs),(x,p)) tr = - S (V ty [mkBranch x v tr | v <- vs]) p - mkBranch x t tr = case tr of - _ | tr == x -> t - _ -> GM.composSafeOp (mkBranch x t) tr - - valNum tr = maybe (valNumFV $ tryFV tr) EInt $ Map.lookup tr untyps - where - tryFV tr = case GM.appForm tr of - (c@(QC _ _), ts) -> [GM.mkApp c ts' | ts' <- combinations (map tryFV ts)] - (FV ts,_) -> ts - _ -> [tr] - valNumFV ts = case ts of - [tr] -> prtTrace tr $ K "66667" - _ -> FV $ map valNum ts - - mkCurry trm = case trm of - V (RecType [(_,ty)]) ts -> V ty ts - V (RecType ((_,ty):ltys)) ts -> - V ty [mkCurry (V (RecType ltys) cs) | - cs <- chop (product (map (lengthtyp . snd) ltys)) ts] - _ -> trm - lengthtyp ty = case Map.lookup ty typs of - Just m -> length (Map.assocs m) - _ -> error $ "length of type " ++ show ty - chop i xs = case splitAt i xs of - (xs1,[]) -> [xs1] - (xs1,xs2) -> xs1:chop i xs2 - - - mkCurrySel t p = S t p -- done properly in CheckGFCC - - -mkLab k = LIdent (("_" ++ show k)) - --- remove lock fields; in fact, any empty records and record types -unlock = filter notlock where - notlock (l,(_, t)) = case t of --- need not look at l - R [] -> False - RecType [] -> False - _ -> True - -unlockTyp = filter notlock - -notlock (l, t) = case t of --- need not look at l - RecType [] -> False - _ -> True - -unlockTy ty = case ty of - RecType ls -> RecType $ sort [(l, unlockTy t) | (l,t) <- ls, notlock (l,t)] - _ -> GM.composSafeOp unlockTy ty - - -prtTrace tr n = - trace ("-- INTERNAL COMPILER ERROR" +++ A.prt tr ++++ show n) n -prTrace tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n - - diff --git a/src/GF/Devel/Infra/ReadFiles.hs b/src/GF/Devel/Infra/ReadFiles.hs deleted file mode 100644 index dd8cbe5a9..000000000 --- a/src/GF/Devel/Infra/ReadFiles.hs +++ /dev/null @@ -1,348 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ReadFiles --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 23:24:34 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.26 $ --- --- Decide what files to read as function of dependencies and time stamps. --- --- make analysis for GF grammar modules. AR 11\/6\/2003--24\/2\/2004 --- --- 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.gfo@ otherwise. ------------------------------------------------------------------------------ - -module GF.Devel.Infra.ReadFiles (-- * Heading 1 - getAllFiles,fixNewlines,ModName,getOptionsFromFile, - -- * Heading 2 - gfoFile,gfFile,isGFO,resModName,isOldFile - ) where - -import GF.Devel.Arch (selectLater, modifiedFiles, ModTime, getModTime,laterModTime) - -import GF.Infra.Option -import GF.Data.Operations -import GF.Devel.UseIO - -import System -import Data.Char -import Control.Monad -import Data.List -import System.Directory - -type ModName = String -type ModEnv = [(ModName,ModTime)] - -getAllFiles :: Options -> [InitPath] -> ModEnv -> FileName -> IOE [FullPath] -getAllFiles opts ps env file = do - - -- read module headers from all files recursively - ds0 <- getImports ps file - let ds = [((snd m,map fst ms),p) | ((m,ms),p) <- ds0] - if oElem beVerbose opts - then ioeIO $ putStrLn $ "all modules:" +++ show (map (fst . fst) ds) - else return () - -- get a topological sorting of files: returns file names --- deletes paths - ds1 <- ioeErr $ either - return - (\ms -> Bad $ "circular modules" +++ - unwords (map show (head ms))) $ topoTest $ map fst ds - - -- associate each file name with its path --- more optimal: save paths in ds1 - let paths = [(f,p) | ((f,_),p) <- ds] - let pds1 = [(p,f) | f <- ds1, Just p <- [lookup f paths]] - if oElem fromSource opts - then return [gfFile (p </> f) | (p,f) <- pds1] - else do - - - ds2 <- ioeIO $ mapM (selectFormat opts env) pds1 - - let ds4 = needCompile opts (map fst ds0) ds2 - return ds4 - --- to decide whether to read gf or gfo, or if in env; returns full file path - -data CompStatus = - CSComp -- compile: read gf - | CSRead -- read gfo - | CSEnv -- gfo is in env - | CSEnvR -- also gfr is in env - | CSDont -- don't read at all - | CSRes -- read gfr - deriving (Eq,Show) - --- for gfo, we also return ModTime to cope with earlier compilation of libs - -selectFormat :: Options -> ModEnv -> (InitPath,ModName) -> - IO (ModName,(InitPath,(CompStatus,Maybe ModTime))) - -selectFormat opts env (p,f) = do - let pf = p </> f - let mtenv = lookup f env -- Nothing if f is not in env - let rtenv = lookup (resModName f) env - let fromComp = oElem isCompiled opts -- i -gfo - mtgfc <- getModTime $ gfoFile pf - mtgf <- getModTime $ gfFile pf - let stat = case (rtenv,mtenv,mtgfc,mtgf) of - (_,Just tenv,_,_) | fromComp -> (CSEnv, Just tenv) - (_,_,Just tgfc,_) | fromComp -> (CSRead,Just tgfc) - (Just tenv,_,_,Just tgf) | laterModTime tenv tgf -> (CSEnvR,Just tenv) - (_,Just tenv,_,Just tgf) | laterModTime tenv tgf -> (CSEnv, Just tenv) - (_,_,Just tgfc,Just tgf) | laterModTime tgfc tgf -> (CSRead,Just tgfc) - (_,Just tenv,_,Nothing) -> (CSEnv,Just tenv) -- source does not exist - (_,_,_, Nothing) -> (CSRead,Nothing) -- source does not exist - _ -> (CSComp,Nothing) - return $ (f, (p,stat)) - -needCompile :: Options -> - [ModuleHeader] -> - [(ModName,(InitPath,(CompStatus,Maybe ModTime)))] -> [FullPath] -needCompile opts headers sfiles0 = paths $ res $ mark $ iter changed where - - deps = [(snd m,map fst ms) | (m,ms) <- headers] - typ m = maybe MTyOther id $ lookup m [(m,t) | ((t,m),_) <- headers] - uses m = [(n,u) | ((_,n),ms) <- headers, (k,u) <- ms, k==m] - stat0 m = maybe CSComp (fst . snd) $ lookup m sfiles0 - - allDeps = [(m,iterFix add ms) | (m,ms) <- deps] where - add os = [m | o <- os, Just n <- [lookup o deps],m <- n] - - -- only treat reused, interface, or instantiation if needed - sfiles = sfiles0 ---- map relevant sfiles0 - relevant fp@(f,(p,(st,_))) = - let us = uses f - isUsed = not (null us) - in - if not (isUsed && all noComp us) then - fp else - if (elem (typ f) [] ---- MTyIncomplete, MTyIncResource] - || - (isUsed && all isAux us)) then - (f,(p,(CSDont,Nothing))) else - fp - - isAux = flip elem [MUReuse,MUInstance,MUComplete] . snd - noComp = flip elem [CSRead,CSEnv,CSEnvR] . stat0 . fst - - -- mark as to be compiled those whose gfo is earlier than a deeper gfo - sfiles1 = map compTimes sfiles - compTimes fp@(f,(p,(_, Just t))) = - if any (> t) [t' | Just fs <- [lookup f deps], - f0 <- fs, - Just (_,(_,Just t')) <- [lookup f0 sfiles]] - then (f,(p,(CSComp, Nothing))) - else fp - compTimes fp = fp - - -- start with the changed files themselves; returns [ModName] - changed = [f | (f,(_,(CSComp,_))) <- sfiles1] - - -- 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, compile if depends on what needs compile - -- returns [FullPath] - mark cs = [(f,(path,st)) | - (f,(path,(st0,_))) <- sfiles1, - let st = if (elem f cs) then CSComp else st0] - - - -- Also read res if the option "retain" is present - -- Also, if a "with" file has to be compiled, read its mother file from source - - res cs = map mkRes cs where - mkRes x@(f,(path,st)) | elem st [CSRead,CSEnv] = case typ f of - t | (not (null [m | (m,(_,CSComp)) <- cs, - Just ms <- [lookup m allDeps], elem f ms]) - || oElem retainOpers opts) - -> if elem t [MTyResource,MTyIncResource] - then (f,(path,CSRes)) else - if t == MTyIncomplete - then (f,(path,CSComp)) else - x - _ -> x - mkRes x = x - - - - -- construct list of paths to read - paths cs = [mkName f p st | (f,(p,st)) <- cs, elem st [CSComp, CSRead,CSRes]] - - mkName f p st = mk (p </> f) where - mk = case st of - CSComp -> gfFile - CSRead -> gfoFile - CSRes -> gfoFile ---- gfr - -isGFO :: FilePath -> Bool -isGFO = (== ".gfn") . takeExtensions - -gfoFile :: FilePath -> FilePath -gfoFile f = addExtension f "gfn" - -gfFile :: FilePath -> FilePath -gfFile f = addExtension f "gf" - -resModName :: ModName -> ModName -resModName = ('#':) - --- to get imports without parsing the whole files - -getImports :: [InitPath] -> FileName -> IOE [(ModuleHeader,InitPath)] -getImports ps = get [] where - get ds file0 = do - let name = dropExtension file0 ---- dropExtension file0 - (p,s) <- tryRead name - let ((typ,mname),imps) = importsOfFile s - let namebody = takeFileName name - ioeErr $ testErr (mname == namebody) $ - "module name" +++ mname +++ "differs from file name" +++ namebody - case imps of - _ | elem name (map (snd . fst . fst) ds) -> return ds --- file already read - [] -> return $ (((typ,name),[]),p):ds - _ -> do - let files = map (gfFile . fst) imps - foldM get ((((typ,name),imps),p):ds) files - tryRead name = do - file <- do - let file_gf = gfFile name - b <- doesFileExistPath ps file_gf -- try gf file first - if b then return file_gf else do - return (gfoFile name) -- gfo next - - readFileIfPath ps $ file - - - --- internal module dep information - -data ModUse = - MUReuse - | MUInstance - | MUComplete - | MUOther - deriving (Eq,Show) - -data ModTyp = - MTyResource - | MTyIncomplete - | MTyIncResource -- interface, incomplete resource - | MTyOther - deriving (Eq,Show) - -type ModuleHeader = ((ModTyp,ModName),[(ModName,ModUse)]) - -importsOfFile :: String -> ModuleHeader -importsOfFile = - getModuleHeader . -- analyse into mod header - filter (not . spec) . -- ignore keywords and special symbols - unqual . -- take away qualifiers - unrestr . -- take away union restrictions - takeWhile (not . term) . -- read until curly or semic - lexs . -- analyse into lexical tokens - unComm -- ignore comments before the headed line - where - term = flip elem ["{",";"] - spec = flip elem ["of", "open","in",":", "->","=", "-","(", ")",",","**","union"] - unqual ws = case ws of - "(":q:ws' -> unqual ws' - w:ws' -> w:unqual ws' - _ -> ws - unrestr ws = case ws of - "[":ws' -> unrestr $ tail $ dropWhile (/="]") ws' - w:ws' -> w:unrestr ws' - _ -> ws - -getModuleHeader :: [String] -> ModuleHeader -- with, reuse -getModuleHeader ws = case ws of - "incomplete":ws2 -> let ((ty,name),us) = getModuleHeader ws2 in - case ty of - MTyResource -> ((MTyIncResource,name),us) - _ -> ((MTyIncomplete,name),us) - "interface":ws2 -> let ((_,name),us) = getModuleHeader ("resource":ws2) in - ((MTyIncResource,name),us) - - "resource":name:ws2 -> case ws2 of - "reuse":m:_ -> ((MTyResource,name),[(m,MUReuse)]) - m:"with":ms -> ((MTyResource,name),(m,MUOther):[(n,MUComplete) | n <- ms]) - ms -> ((MTyResource,name),[(n,MUOther) | n <- ms]) - - "instance":name:m:ws2 -> case ws2 of - "reuse":n:_ -> ((MTyResource,name),(m,MUInstance):[(n,MUReuse)]) - n:"with":ms -> - ((MTyResource,name),(m,MUInstance):(n,MUComplete):[(n,MUOther) | n <- ms]) - ms -> ((MTyResource,name),(m,MUInstance):[(n,MUOther) | n <- ms]) - - "concrete":name:a:ws2 -> case span (/= "with") ws2 of - - (es,_:ms) -> ((MTyOther,name), - [(m,MUOther) | m <- es] ++ - [(n,MUComplete) | n <- ms]) - --- m:"with":ms -> ((MTyOther,name),(m,MUOther):[(n,MUComplete) | n <- ms]) - (ms,[]) -> ((MTyOther,name),[(n,MUOther) | n <- a:ms]) - - _:name:ws2 -> case ws2 of - "reuse":m:_ -> ((MTyOther,name),[(m,MUReuse)]) - ---- m:n:"with":ms -> - ---- ((MTyOther,name),(m,MUInstance):(n,MUOther):[(n,MUComplete) | n <- ms]) - m:"with":ms -> ((MTyOther,name),(m,MUOther):[(n,MUComplete) | n <- ms]) - ms -> ((MTyOther,name),[(n,MUOther) | n <- ms]) - _ -> error "the file is empty" - -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 - --- | options can be passed to the compiler by comments in @--#@, in the main file -getOptionsFromFile :: FilePath -> IO Options -getOptionsFromFile file = do - s <- readFileIfStrict file - let ls = filter (isPrefixOf "--#") $ lines s - return $ fst $ getOptions "-" $ map (unwords . words . drop 3) ls - --- | check if old GF file -isOldFile :: FilePath -> IO Bool -isOldFile f = do - s <- readFileIfStrict f - let s' = unComm s - return $ not (null s') && old (head (words s')) - where - old = flip elem $ words - "cat category data def flags fun include lin lincat lindef lintype oper param pattern printname rule" - - - --- | old GF tolerated newlines in quotes. No more supported! -fixNewlines :: String -> String -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/Devel/ModDeps.hs b/src/GF/Devel/ModDeps.hs deleted file mode 100644 index ec5702910..000000000 --- a/src/GF/Devel/ModDeps.hs +++ /dev/null @@ -1,153 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ModDeps --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 23:24:34 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.14 $ --- --- Check correctness of module dependencies. Incomplete. --- --- AR 13\/5\/2003 ------------------------------------------------------------------------------ - -module GF.Devel.ModDeps (mkSourceGrammar, - moduleDeps, - openInterfaces, - requiredCanModules - ) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Option -import GF.Devel.PrGrammar -import GF.Compile.Update -import GF.Grammar.Lookup -import GF.Infra.Modules - -import GF.Data.Operations - -import Control.Monad -import Data.List - --- | 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] - _ -> return () --- Bad $ "bug: ModDeps does not treat" +++ show mo - where - - test ms = testErr (all (`notElem` ns) ms) - ("import names clashing with module names among" +++ - unwords (map prt ms)) - -type Dependencies = [(IdentM Ident,[IdentM Ident])] - --- | to decide what modules immediately depend on what, and check if the --- dependencies are appropriate -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 of-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 <- mapM (lookupModuleType gr) es - testErr (all (compatMType ety) ests) "inappropriate extension module type" ----- osts <- mapM (lookupModuleType gr . openedModule) os ----- testErr (all (compatOType oty) osts) "inappropriate open module type" - let ab = case it of - IdentM _ (MTConcrete a) -> [IdentM a MTAbstract] - _ -> [] ---- - return (it, ab ++ - [IdentM e ety | e <- es] ++ - [IdentM (openedModule o) oty | o <- os]) - - -- check for superficial compatibility, not submodule relation etc: what can be extended - compatMType mt0 mt = case (mt0,mt) of - (MTResource, MTConcrete _) -> True - (MTInstance _, MTConcrete _) -> True - (MTInterface, MTAbstract) -> True - (MTConcrete _, MTConcrete _) -> True - (MTInstance _, MTInstance _) -> True - (MTReuse _, MTReuse _) -> True - (MTInstance _, MTResource) -> True - (MTResource, MTInstance _) -> True - ---- some more? - _ -> mt0 == mt - -- in the same way; this defines what can be opened - compatOType mt0 mt = case mt0 of - MTAbstract -> mt == MTAbstract - MTTransfer _ _ -> mt == MTAbstract - _ -> case mt of - MTResource -> True - MTReuse _ -> True - MTInterface -> True - MTInstance _ -> True - _ -> False - - gr = MGrammar ms --- hack - -openInterfaces :: Dependencies -> Ident -> Err [Ident] -openInterfaces ds m = do - let deps = [(i,ds) | (IdentM i _,ds) <- ds] - let more (c,_) = [(i,mt) | Just is <- [lookup c deps], IdentM i mt <- is] - let mods = iterFix (concatMap more) (more (m,undefined)) - return $ [i | (i,MTInterface) <- mods] - --- | this function finds out what modules are really needed in the canonical gr. --- its argument is typically a concrete module name -requiredCanModules :: (Ord i, Show i) => Bool -> MGrammar i f a -> i -> [i] -requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where - exts = allExtends gr c - ops = if isSingle - then map fst (modules gr) - else iterFix (concatMap more) $ exts - more i = errVal [] $ do - m <- lookupModMod gr i - return $ extends m ++ [o | o <- map openedModule (opens m)] - notReuse i = errVal True $ do - m <- lookupModMod gr i - return $ isModRes m -- to exclude reused Cnc and Abs from required - - -{- --- to test -exampleDeps = [ - (ir "Nat",[ii "Gen", ir "Adj"]), - (ir "Adj",[ii "Num", ii "Gen", ir "Nou"]), - (ir "Nou",[ii "Cas"]) - ] - -ii s = IdentM (IC s) MTInterface -ir s = IdentM (IC s) MTResource --} - diff --git a/src/GF/Devel/Optimize.hs b/src/GF/Devel/Optimize.hs deleted file mode 100644 index b44f6a53d..000000000 --- a/src/GF/Devel/Optimize.hs +++ /dev/null @@ -1,299 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Optimize --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/09/16 13:56:13 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.18 $ --- --- Top-level partial evaluation for GF source modules. ------------------------------------------------------------------------------ - -module GF.Devel.Optimize (optimizeModule) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Grammar.PrGrammar -import GF.Grammar.Macros -import GF.Grammar.Lookup -import GF.Grammar.Refresh -import GF.Devel.Compute -import GF.Compile.BackOpt -import GF.Devel.CheckGrammar -import GF.Compile.Update ---import GF.Compile.Evaluate - -import GF.Data.Operations -import GF.Infra.CheckM -import GF.Infra.Option - -import Control.Monad -import Data.List - -import Debug.Trace - - --- conditional trace - -prtIf :: (Print a) => Bool -> a -> a -prtIf b t = if b then trace (" " ++ prt t) t else t - --- experimental evaluation, option to import -oEval = iOpt "eval" - --- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005. - -type EEnv = () --- not used - --- only do this for resource: concrete is optimized in gfc form -optimizeModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> - (Ident,SourceModInfo) -> Err ((Ident,SourceModInfo),EEnv) -optimizeModule opts mse@(ms,eenv) mo@(_,mi) = case mi of - ModMod m0@(Module mt st fs me ops js) | - st == MSComplete && isModRes m0 && not (oElem oEval oopts)-> do - (mo1,_) <- evalModule oopts mse mo - let - mo2 = case optim of - "parametrize" -> shareModule paramOpt mo1 -- parametrization and sharing - "values" -> shareModule valOpt mo1 -- tables as courses-of-values - "share" -> shareModule shareOpt mo1 -- sharing of branches - "all" -> shareModule allOpt mo1 -- first parametrize then values - "none" -> mo1 -- no optimization - _ -> mo1 -- none; default for src - return (mo2,eenv) - _ -> evalModule oopts mse mo - where - oopts = addOptions opts (iOpts (flagsModule mo)) - optim = maybe "all" id $ getOptVal oopts useOptimizer - -evalModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> (Ident,SourceModInfo) -> - Err ((Ident,SourceModInfo),EEnv) -evalModule oopts (ms,eenv) mo@(name,mod) = case mod of - - ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of - _ | isModRes m0 && not (oElem oEval oopts) -> do - let deps = allOperDependencies name js - ids <- topoSortOpers deps - MGrammar (mod' : _) <- foldM evalOp gr ids - return $ (mod',eenv) - - MTConcrete a -> do - js' <- mapMTree (evalCncInfo oopts gr name a) js ---- <- gr0 6/12/2005 - return $ ((name, ModMod (Module mt st fs me ops js')),eenv) - - _ -> return $ ((name,mod),eenv) - _ -> return $ ((name,mod),eenv) - where - gr0 = MGrammar $ ms - gr = MGrammar $ (name,mod) : ms - - evalOp g@(MGrammar ((_, ModMod m) : _)) i = do - info <- lookupTree prt i $ jments m - info' <- evalResInfo oopts 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 :: Options -> SourceGrammar -> (Ident,Info) -> Err Info -evalResInfo oopts gr (c,info) = case info of - - ResOper pty pde -> eIn "operation" $ do - pde' <- case pde of - Yes de | optres -> liftM yes $ comp de - _ -> return pde - return $ ResOper pty pde' - - _ -> return info - where - comp = if optres then computeConcrete gr else computeConcreteRec gr - eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":") - optim = maybe "all" id $ getOptVal oopts useOptimizer - optres = case optim of - "noexpand" -> False - _ -> True - - -evalCncInfo :: - Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info) -evalCncInfo opts gr cnc abs (c,info) = do - - seq (prtIf (oElem beVerbose opts) c) $ return () - - errIn ("optimizing" +++ prt c) $ 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 >>= partEval noOptions gr ([(strVar, typeStr)],typ) - (May b, Nope) -> - return $ May b - _ -> return pde -- indirection - - ppr' <- liftM yes $ evalPrintname gr c ppr (yes $ K $ prt c) - - return (c, CncCat ptyp pde' ppr') - - CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr -> - eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do - pde' <- case pde of - Yes de | notNewEval -> do - liftM yes $ pEval ty de - - _ -> return pde - ppr' <- liftM yes $ evalPrintname gr c ppr pde' - return $ (c, CncFun mt pde' ppr') -- only cat in type actually needed - - _ -> return (c,info) - where - pEval = partEval opts gr - eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":") - notNewEval = not (oElem oEval opts) - --- | the main function for compiling linearizations -partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term -partEval opts gr (context, val) trm = errIn ("parteval" +++ prt_ trm) $ do - let vars = map fst context - args = map Vr vars - subst = [(v, Vr v) | v <- vars] - trm1 = mkApp trm args - trm3 <- if globalTable - then etaExpand subst trm1 >>= outCase subst - else etaExpand subst trm1 - return $ mkAbs vars trm3 - - where - - globalTable = oElem showAll opts --- i -all - - comp g t = {- refreshTerm t >>= -} computeTerm gr g t - - etaExpand su t = do - t' <- comp su t - case t' of - R _ | rightType t' -> comp su t' --- return t' wo noexpand... - _ -> recordExpand val t' >>= comp su - -- don't eta expand records of right length (correct by type checking) - rightType t = case (t,val) of - (R rs, RecType ts) -> length rs == length ts - _ -> False - - outCase subst t = do - pts <- getParams context - let (args,ptyps) = unzip $ filter (flip occur t . fst) pts - if null args - then return t - else do - let argtyp = RecType $ tuple2recordType ptyps - let pvars = map (Vr . zIdent . prt) args -- gets eliminated - patt <- term2patt $ R $ tuple2record $ pvars - let t' = replace (zip args pvars) t - t1 <- comp subst $ T (TTyped argtyp) [(patt, t')] - return $ S t1 $ R $ tuple2record args - - --- notice: this assumes that all lin types follow the "old JFP style" - getParams = liftM concat . mapM getParam - getParam (argv,RecType rs) = return - [(P (Vr argv) lab, ptyp) | (lab,ptyp) <- rs, not (isLinLabel lab)] - ---getParam (_,ty) | ty==typeStr = return [] --- in lindef - getParam (av,ty) = - Bad ("record type expected not" +++ prt ty +++ "for" +++ prt av) - --- all lin types are rec types - - replace :: [(Term,Term)] -> Term -> Term - replace reps trm = case trm of - -- this is the important case - P _ _ -> maybe trm id $ lookup trm reps - _ -> composSafeOp (replace reps) trm - - occur t trm = case trm of - - -- this is the important case - P _ _ -> t == trm - S x y -> occur t y || occur t x - App f x -> occur t x || occur t f - Abs _ f -> occur t f - R rs -> any (occur t) (map (snd . snd) rs) - T _ cs -> any (occur t) (map snd cs) - C x y -> occur t x || occur t y - Glue x y -> occur t x || occur t y - ExtR x y -> occur t x || occur t y - FV ts -> any (occur t) ts - V _ ts -> any (occur t) ts - Let (_,(_,x)) y -> occur t x || occur t y - _ -> False - - --- 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 - -mkLinDefault :: SourceGrammar -> Type -> Err Term -mkLinDefault gr typ = do - case unComputed typ of - RecType lts -> mapPairsM mkDefField lts >>= (return . Abs strVar . R . mkAssign) - _ -> liftM (Abs strVar) $ mkDefField typ ----- _ -> 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'] - _ | isTypeInts typ -> return $ EInt 0 -- exists in all as first val - _ -> prtBad "linearization type field cannot be" typ - --- | Form the printname: if given, compute. If not, use the computed --- lin for functions, cat name for cats (dispatch made in evalCncDef above). ---- We cannot use linearization at this stage, since we do not know the ---- defaults we would need for question marks - and we're not yet in canon. -evalPrintname :: SourceGrammar -> Ident -> MPr -> Perh Term -> Err Term -evalPrintname gr c ppr lin = - case ppr of - Yes pr -> comp pr - _ -> case lin of - Yes t -> return $ K $ clean $ prt $ oneBranch t ---- stringFromTerm - _ -> return $ K $ prt c ---- - where - comp = computeConcrete gr - - oneBranch t = case t of - Abs _ b -> oneBranch b - R (r:_) -> oneBranch $ snd $ snd r - T _ (c:_) -> oneBranch $ snd c - V _ (c:_) -> oneBranch c - FV (t:_) -> oneBranch t - C x y -> C (oneBranch x) (oneBranch y) - S x _ -> oneBranch x - P x _ -> oneBranch x - Alts (d,_) -> oneBranch d - _ -> t - - --- very unclean cleaner - clean s = case s of - '+':'+':' ':cs -> clean cs - '"':cs -> clean cs - c:cs -> c: clean cs - _ -> s - diff --git a/src/GF/Devel/OptimizeGF.hs b/src/GF/Devel/OptimizeGF.hs deleted file mode 100644 index 99e33941f..000000000 --- a/src/GF/Devel/OptimizeGF.hs +++ /dev/null @@ -1,271 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : OptimizeGF --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:21:33 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- Optimizations on GF source code: sharing, parametrization, value sets. --- --- optimization: sharing branches in tables. AR 25\/4\/2003. --- following advice of Josef Svenningsson ------------------------------------------------------------------------------ - -module GF.Devel.OptimizeGF ( - optModule,unshareModule,unsubexpModule,unoptModule,subexpModule,shareModule - ) where - -import GF.Grammar.Grammar -import GF.Grammar.Lookup -import GF.Infra.Ident -import qualified GF.Grammar.Macros as C -import GF.Grammar.PrGrammar (prt) -import qualified GF.Infra.Modules as M -import GF.Data.Operations - -import Control.Monad -import Data.Map (Map) -import qualified Data.Map as Map -import Data.List - -optModule :: (Ident, SourceModInfo) -> (Ident, SourceModInfo) -optModule = subexpModule . shareModule - -shareModule = processModule optim - -unoptModule :: SourceGrammar -> (Ident, SourceModInfo) -> (Ident, SourceModInfo) -unoptModule gr = unshareModule gr . unsubexpModule - -unshareModule :: SourceGrammar -> (Ident, SourceModInfo) -> (Ident, SourceModInfo) -unshareModule gr = processModule (const (unoptim gr)) - -processModule :: - (Ident -> Term -> Term) -> (Ident, SourceModInfo) -> (Ident, SourceModInfo) -processModule opt (i,m) = case m of - M.ModMod (M.Module mt st fs me ops js) -> - (i,M.ModMod (M.Module mt st fs me ops (mapTree (shareInfo opt) js))) - _ -> (i,m) - -shareInfo opt (c, CncCat ty (Yes t) m) = (c,CncCat ty (Yes (opt c t)) m) -shareInfo opt (c, CncFun kxs (Yes t) m) = (c,CncFun kxs (Yes (opt c t)) m) -shareInfo opt (c, ResOper ty (Yes t)) = (c,ResOper ty (Yes (opt c t))) -shareInfo _ i = i - --- the function putting together optimizations -optim :: Ident -> Term -> Term -optim c = values . factor c 0 - --- we need no counter to create new variable names, since variables are --- local to tables (only true in GFC) --- - --- factor parametric branches - -factor :: Ident -> Int -> Term -> Term -factor c i t = case t of - T _ [_] -> t - T _ [] -> t - T (TComp ty) cs -> - T (TTyped ty) $ factors i [(p, factor c (i+1) v) | (p, v) <- cs] - _ -> C.composSafeOp (factor c i) t - where - - factors i psvs = -- we know psvs has at least 2 elements - let p = qqIdent c i - vs' = map (mkFun p) psvs - in if allEqs vs' - then mkCase p vs' - else psvs - - mkFun p (patt, val) = replace (C.patt2term patt) (Vr p) val - - allEqs (v:vs) = all (==v) vs - - mkCase p (v:_) = [(PV p, v)] - ---- we hope this will be fresh and don't check... in GFC would be safe - -qqIdent c i = identC ("q_" ++ prt c ++ "__" ++ show i) - - --- we need to replace subterms - -replace :: Term -> Term -> Term -> Term -replace old new trm = case trm of - - -- these are the important cases, since they can correspond to patterns - QC _ _ | trm == old -> new - App t ts | trm == old -> new - App t ts -> App (repl t) (repl ts) - R _ | isRec && trm == old -> new - _ -> C.composSafeOp repl trm - where - repl = replace old new - isRec = case trm of - R _ -> True - _ -> False - --- It is very important that this is performed only after case --- expansion since otherwise the order and number of values can --- be incorrect. Guaranteed by the TComp flag. - -values :: Term -> Term -values t = case t of - T ty [(ps,t)] -> T ty [(ps,values t)] -- don't destroy parametrization - T (TComp ty) cs -> V ty [values t | (_, t) <- cs] - T (TTyped ty) cs -> V ty [values t | (_, t) <- cs] - ---- why are these left? - ---- printing with GrammarToSource does not preserve the distinction - _ -> C.composSafeOp values t - - --- to undo the effect of factorization - -unoptim :: SourceGrammar -> Term -> Term -unoptim gr = unfactor gr - -unfactor :: SourceGrammar -> Term -> Term -unfactor gr t = case t of - T (TTyped ty) [(PV x,u)] -> V ty [restore x v (unfac u) | v <- vals ty] - _ -> C.composSafeOp unfac t - where - unfac = unfactor gr - vals = err error id . allParamValues gr - restore x u t = case t of - Vr y | y == x -> u - _ -> C.composSafeOp (restore x u) t - - ----------------------------------------------------------------------- - -{- -This module implements a simple common subexpression elimination - for gfc grammars, to factor out shared subterms in lin rules. -It works in three phases: - - (1) collectSubterms collects recursively all subterms of forms table and (P x..y) - from lin definitions (experience shows that only these forms - tend to get shared) and counts how many times they occur - (2) addSubexpConsts takes those subterms t that occur more than once - and creates definitions of form "oper A''n = t" where n is a - fresh number; notice that we assume no ids of this form are in - scope otherwise - (3) elimSubtermsMod goes through lins and the created opers by replacing largest - possible subterms by the newly created identifiers - -The optimization is invoked in gf by the flag i -subs. - -If an application does not support GFC opers, the effect of this -optimization can be undone by the function unSubelimCanon. - -The function unSubelimCanon can be used to diagnostisize how much -cse is possible in the grammar. It is used by the flag pg -printer=subs. - --} - -subexpModule :: SourceModule -> SourceModule -subexpModule (mo,m) = errVal (mo,m) $ case m of - M.ModMod (M.Module mt st fs me ops js) -> do - (tree,_) <- appSTM (getSubtermsMod mo (tree2list js)) (Map.empty,0) - js2 <- liftM buildTree $ addSubexpConsts mo tree $ tree2list js - return (mo,M.ModMod (M.Module mt st fs me ops js2)) - _ -> return (mo,m) - -unsubexpModule :: SourceModule -> SourceModule -unsubexpModule mo@(i,m) = case m of - M.ModMod (M.Module mt st fs me ops js) | hasSub ljs -> - (i, M.ModMod (M.Module mt st fs me ops - (rebuild (map unparInfo ljs)))) - where ljs = tree2list js - _ -> (i,m) - where - -- perform this iff the module has opers - hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs] - unparInfo (c,info) = case info of - CncFun xs (Yes t) m -> [(c, CncFun xs (Yes (unparTerm t)) m)] - ResOper (Yes (EInt 8)) _ -> [] -- subexp-generated opers - ResOper pty (Yes t) -> [(c, ResOper pty (Yes (unparTerm t)))] - _ -> [(c,info)] - unparTerm t = case t of - Q m c@(IC ('A':'\'':'\'':_)) -> --- name convention of subexp opers - errVal t $ liftM unparTerm $ lookupResDef gr m c - _ -> C.composSafeOp unparTerm t - gr = M.MGrammar [mo] - rebuild = buildTree . concat - --- implementation - -type TermList = Map Term (Int,Int) -- number of occs, id -type TermM a = STM (TermList,Int) a - -addSubexpConsts :: - Ident -> Map Term (Int,Int) -> [(Ident,Info)] -> Err [(Ident,Info)] -addSubexpConsts mo tree lins = do - let opers = [oper id trm | (trm,(_,id)) <- list] - mapM mkOne $ opers ++ lins - where - - mkOne (f,def) = case def of - CncFun xs (Yes trm) pn -> do - trm' <- recomp f trm - return (f,CncFun xs (Yes trm') pn) - ResOper ty (Yes trm) -> do - trm' <- recomp f trm - return (f,ResOper ty (Yes trm')) - _ -> return (f,def) - recomp f t = case Map.lookup t tree of - Just (_,id) | ident id /= f -> return $ Q mo (ident id) - _ -> C.composOp (recomp f) t - - list = Map.toList tree - - oper id trm = (ident id, ResOper (Yes (EInt 8)) (Yes trm)) - --- impossible type encoding generated opers - -getSubtermsMod :: Ident -> [(Ident,Info)] -> TermM (Map Term (Int,Int)) -getSubtermsMod mo js = do - mapM (getInfo (collectSubterms mo)) js - (tree0,_) <- readSTM - return $ Map.filter (\ (nu,_) -> nu > 1) tree0 - where - getInfo get fi@(f,i) = case i of - CncFun xs (Yes trm) pn -> do - get trm - return $ fi - ResOper ty (Yes trm) -> do - get trm - return $ fi - _ -> return fi - -collectSubterms :: Ident -> Term -> TermM Term -collectSubterms mo t = case t of - App f a -> do - collect f - collect a - add t - T ty cs -> do - let (_,ts) = unzip cs - mapM collect ts - add t - V ty ts -> do - mapM collect ts - add t ----- K (KP _ _) -> add t - _ -> C.composOp (collectSubterms mo) t - where - collect = collectSubterms mo - add t = do - (ts,i) <- readSTM - let - ((count,id),next) = case Map.lookup t ts of - Just (nu,id) -> ((nu+1,id), i) - _ -> ((1, i ), i+1) - writeSTM (Map.insert t (count,id) ts, next) - return t --- only because of composOp - -ident :: Int -> Ident -ident i = identC ("A''" ++ show i) --- - diff --git a/src/GF/Devel/Options.hs b/src/GF/Devel/Options.hs deleted file mode 100644 index 9a4087096..000000000 --- a/src/GF/Devel/Options.hs +++ /dev/null @@ -1,269 +0,0 @@ -module GF.Devel.Options - ( - Err(..), -- FIXME: take from somewhere else - - Options(..), - Mode(..), Phase(..), OutputFormat(..), Optimization(..), - parseOptions, helpMessage - ) where - -import Control.Monad -import Data.Char (toLower) -import Data.List -import Data.Maybe -import System.Console.GetOpt -import System.FilePath - - - - - -usageHeader :: String -usageHeader = unlines - ["Usage: gfc [OPTIONS] [FILE [...]]", - "", - "How each FILE is handled depends on the file name suffix:", - "", - ".gf Normal or old GF source, will be compiled.", - ".gfc Compiled GF source, will be loaded as is.", - ".gfe Example-based GF source, will be converted to .gf and compiled.", - ".ebnf Extended BNF format, will be converted to .gf and compiled.", - ".cf Context-free (BNF) format, will be converted to .gf and compiled.", - "", - "If multiple FILES are given, they must be normal GF source, .gfc or .gfe files.", - "For the other input formats, only one file can be given.", - "", - "Command-line options:"] - - -helpMessage :: String -helpMessage = usageInfo usageHeader optDescr - --- Error monad - -type ErrorMsg = String - -data Err a = Ok a | Errors [ErrorMsg] - deriving (Read, Show, Eq) - -instance Monad Err where - return = Ok - fail e = Errors [e] - Ok a >>= f = f a - Errors s >>= f = Errors s - -errors :: [ErrorMsg] -> Err a -errors = Errors - --- Types - -data Mode = Version | Help | Interactive | Compiler - deriving (Show,Eq,Ord) - -data Phase = Preproc | Convert | Compile | Link - deriving (Show,Eq,Ord) - -data Encoding = UTF_8 | ISO_8859_1 - deriving (Show,Eq,Ord) - -data OutputFormat = FmtGFCC | FmtJS - deriving (Show,Eq,Ord) - -data Optimization = OptStem | OptCSE - deriving (Show,Eq,Ord) - -data Warning = WarnMissingLincat - deriving (Show,Eq,Ord) - -data Dump = DumpRebuild | DumpExtend | DumpRename | DumpTypecheck | DumpRefresh | DumpOptimize | DumpCanon - deriving (Show,Eq,Ord) - -data ModuleOptions = ModuleOptions { - optPreprocessors :: [String], - optEncoding :: Encoding, - optOptimizations :: [Optimization], - optLibraryPath :: [FilePath], - optSpeechLanguage :: Maybe String, - optBuildParser :: Bool, - optWarnings :: [Warning], - optDump :: [Dump] - } - deriving (Show) - -data Options = Options { - optMode :: Mode, - optStopAfterPhase :: Phase, - optVerbosity :: Int, - optShowCPUTime :: Bool, - optEmitGFO :: Bool, - optGFODir :: FilePath, - optOutputFormats :: [OutputFormat], - optOutputName :: Maybe String, - optOutputFile :: Maybe FilePath, - optOutputDir :: FilePath, - optForceRecomp :: Bool, - optProb :: Bool, - optStartCategory :: Maybe String, - optModuleOptions :: ModuleOptions - } - deriving (Show) - --- Option parsing - -parseOptions :: [String] -> Err (Options, [FilePath]) -parseOptions args = case errs of - [] -> do o <- foldM (\o f -> f o) defaultOptions opts - return (o, files) - _ -> errors errs - where (opts, files, errs) = getOpt RequireOrder optDescr args - -parseModuleFlags :: Options -> [(String,String)] -> Err ModuleOptions -parseModuleFlags opts flags = foldr setOpt (optModuleOptions opts) moduleOptDescr - where - setOpt (Option _ ss arg _) d - | null values = d - | otherwise = case arg of - NoArg a -> - ReqArg (String -> a) _ -> -OptArg (Maybe String -> a) String -last values - where values = [v | (k,v) <- flags, k `elem` ss ] - --- Default options - -defaultModuleOptions :: ModuleOptions -defaultModuleOptions = ModuleOptions { - optPreprocessors = [], - optEncoding = ISO_8859_1, - optOptimizations = [OptStem,OptCSE], - optLibraryPath = [], - optSpeechLanguage = Nothing, - optBuildParser = True, - optWarnings = [], - optDump = [] - } - -defaultOptions :: Options -defaultOptions = Options { - optMode = Interactive, - optStopAfterPhase = Link, - optVerbosity = 1, - optShowCPUTime = False, - optEmitGFO = True, - optGFODir = ".", - optOutputFormats = [FmtGFCC], - optOutputName = Nothing, - optOutputFile = Nothing, - optOutputDir = ".", - optForceRecomp = False, - optProb = False, - optStartCategory = Nothing, - optModuleOptions = defaultModuleOptions - } - --- Option descriptions - -moduleOptDescr :: [OptDescr (ModuleOptions -> Err ModuleOptions)] -moduleOptDescr = - [ - Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.", - Option [] ["path"] (ReqArg setLibPath "DIR:DIR:...") "Set the library search path.", - Option [] ["preproc"] (ReqArg preproc "CMD") - (unlines ["Use CMD to preprocess input files.", - "Multiple preprocessors can be used by giving this option multiple times."]), - Option [] ["stem"] (onOff (optimize OptStem) True) "Perform stem-suffix analysis (default on).", - Option [] ["cse"] (onOff (optimize OptCSE) True) "Perform common sub-expression elimination (default on).", - Option [] ["parser"] (onOff parser True) "Build parser (default on).", - Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar." - ] - where - addLibDir x o = return $ o { optLibraryPath = x:optLibraryPath o } - setLibPath x o = return $ o { optLibraryPath = splitInModuleSearchPath x } - preproc x o = return $ o { optPreprocessors = optPreprocessors o ++ [x] } - optimize x b o = return $ o { optOptimizations = (if b then (x:) else delete x) (optOptimizations o) } - parser x o = return $ o { optBuildParser = x } - language x o = return $ o { optSpeechLanguage = Just x } - -optDescr :: [OptDescr (Options -> Err Options)] -optDescr = - [ - Option ['E'] [] (NoArg (phase Preproc)) "Stop after preprocessing (with --preproc).", - Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.", - Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo.", - Option ['V'] ["version"] (NoArg (mode Version)) "Display GF version number.", - Option ['?','h'] ["help"] (NoArg (mode Help)) "Show help message.", - Option ['v'] ["verbose"] (OptArg verbosity "N") "Set verbosity (default 1). -v alone is the same as -v 3.", - Option ['q'] ["quiet"] (NoArg (verbosity (Just "0"))) "Quiet, same as -v 0.", - Option [] ["batch"] (NoArg (mode Compiler)) "Run in batch compiler mode.", - Option [] ["interactive"] (NoArg (mode Interactive)) "Run in interactive mode (default).", - Option [] ["cpu"] (NoArg (cpu True)) "Show compilation CPU time statistics.", - Option [] ["no-cpu"] (NoArg (cpu False)) "Don't show compilation CPU time statistics (default).", - Option [] ["emit-gfo"] (NoArg (emitGFO True)) "Create .gfo files (default).", - Option [] ["no-emit-gfo"] (NoArg (emitGFO False)) "Do not create .gfo files.", - Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').", - Option ['f'] ["output-format"] (ReqArg outFmt "FMT") - (unlines ["Output format. FMT can be one of:", - "Multiple concrete: gfcc (default), gar, js, ...", - "Single concrete only: cf, bnf, lbnf, gsl, srgs_xml, srgs_abnf, ...", - "Abstract only: haskell, ..."]), - Option ['n'] ["output-name"] (ReqArg outName "NAME") - ("Use NAME as the name of the output. This is used in the output file names, " - ++ "with suffixes depending on the formats, and, when relevant, " - ++ "internally in the output."), - Option ['o'] ["output-file"] (ReqArg outFile "FILE") - "Save output in FILE (default is out.X, where X depends on output format.", - Option ['D'] ["output-dir"] (ReqArg outDir "DIR") - "Save output files (other than .gfc files) in DIR.", - Option [] ["src","force-recomp"] (NoArg (forceRecomp True)) - "Always recompile from source, i.e. disable recompilation checking.", - Option [] ["prob"] (NoArg (prob True)) "Read probabilities from '--# prob' pragmas.", - Option [] ["startcat"] (ReqArg startcat "CAT") "Use CAT as the start category in the generated grammar." - ] ++ map (fmap onModuleOptions) moduleOptDescr - where phase x o = return $ o { optStopAfterPhase = x } - mode x o = return $ o { optMode = x } - verbosity mv o = case mv of - Nothing -> return $ o { optVerbosity = 3 } - Just v -> case reads v of - [(i,"")] | i >= 0 -> return $ o { optVerbosity = i } - _ -> fail $ "Bad verbosity: " ++ show v - cpu x o = return $ o { optShowCPUTime = x } - emitGFO x o = return $ o { optEmitGFO = x } - gfoDir x o = return $ o { optGFODir = x } - outFmt x o = readOutputFormat x >>= \f -> - return $ o { optOutputFormats = optOutputFormats o ++ [f] } - outName x o = return $ o { optOutputName = Just x } - outFile x o = return $ o { optOutputFile = Just x } - outDir x o = return $ o { optOutputDir = x } - forceRecomp x o = return $ o { optForceRecomp = x } - prob x o = return $ o { optProb = x } - startcat x o = return $ o { optStartCategory = Just x } - -onModuleOptions :: Monad m => (ModuleOptions -> m ModuleOptions) -> Options -> m Options -onModuleOptions f o = do mo' <- f (optModuleOptions o) - return $ o { optModuleOptions = mo' } - -instance Functor OptDescr where - fmap f (Option cs ss d s) = Option cs ss (fmap f d) s - -instance Functor ArgDescr where - fmap f (NoArg x) = NoArg (f x) - fmap f (ReqArg g s) = ReqArg (f . g) s - fmap f (OptArg g s) = OptArg (f . g) s - -outputFormats :: [(String,OutputFormat)] -outputFormats = - [("gfcc", FmtGFCC), - ("js", FmtJS)] - -onOff :: Monad m => (Bool -> (a -> m a)) -> Bool -> ArgDescr (a -> m a) -onOff f def = OptArg g "[on,off]" - where g ma x = do b <- maybe (return def) readOnOff ma - f b x - readOnOff x = case map toLower x of - "on" -> return True - "off" -> return False - _ -> fail $ "Expected [on,off], got: " ++ show x - -readOutputFormat :: Monad m => String -> m OutputFormat -readOutputFormat s = - maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats diff --git a/src/GF/Devel/PrGrammar.hs b/src/GF/Devel/PrGrammar.hs deleted file mode 100644 index 44d1c3200..000000000 --- a/src/GF/Devel/PrGrammar.hs +++ /dev/null @@ -1,233 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PrGrammar --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/09/04 11:45:38 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.16 $ --- --- AR 7\/12\/1999 - 1\/4\/2000 - 10\/5\/2003 --- --- printing and prettyprinting class --- --- 8\/1\/2004: --- Usually followed principle: 'prt_' for displaying in the editor, 'prt' --- in writing grammars to a file. For some constructs, e.g. 'prMarkedTree', --- only the former is ever needed. ------------------------------------------------------------------------------ - -module GF.Devel.PrGrammar where - -import GF.Data.Operations -import GF.Data.Zipper -import GF.Grammar.Grammar -import GF.Infra.Modules -import qualified GF.Source.PrintGF as P -import GF.Grammar.Values -import GF.Source.GrammarToSource ---- import GFC (CanonGrammar) --- cycle of modules - -import GF.Infra.Option -import GF.Infra.Ident -import GF.Data.Str - -import Data.List (intersperse) - -class Print a where - prt :: a -> String - -- | printing with parentheses, if needed - prt2 :: a -> String - -- | pretty printing - prpr :: a -> [String] - -- | printing without ident qualifications - prt_ :: a -> String - prt2 = prt - prt_ = prt - prpr = return . prt - --- 8/1/2004 ---- Usually followed principle: prt_ for displaying in the editor, prt ---- in writing grammars to a file. For some constructs, e.g. prMarkedTree, ---- only the former is ever needed. - --- | to show terms etc in error messages -prtBad :: Print a => String -> a -> Err b -prtBad s a = Bad (s +++ prt a) - -prGrammar :: SourceGrammar -> String -prGrammar = P.printTree . trGrammar - -prModule :: (Ident, SourceModInfo) -> String -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] - - --- 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 - 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)) - --- | a pretty-printer for parsable output -tree2string :: Tree -> String -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 - prt VType = "Type" - -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) = prQuotedString s - prt (AtI i) = show i - prt (AtF i) = show i - prt_ (AtC (_,f)) = prt f - prt_ a = prt a - -prQIdent :: QIdent -> String -prQIdent (m,f) = prt m ++ "." ++ prt f - -prQIdent_ :: QIdent -> String -prQIdent_ (_,f) = 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 - --- | option @-strip@ strips qualifications -prTermOpt :: Options -> Term -> String -prTermOpt opts = if oElem nostripQualif opts then prt else prExp - --- | to get rid of brackets in the editor -prRefinement :: Term -> String -prRefinement t = case t of - Q m c -> prQIdent (m,c) - QC m c -> prQIdent (m,c) - _ -> prt t - -prOperSignature :: (QIdent,Type) -> String -prOperSignature (f, t) = prQIdent f +++ ":" +++ prt t - --- to look up a constant etc in a search tree - -lookupIdent :: Ident -> BinTree Ident b -> Err b -lookupIdent c t = case lookupTree prt c t of - Ok v -> return v - _ -> prtBad "unknown identifier" c - -lookupIdentInfo :: Module Ident f a -> Ident -> Err a -lookupIdentInfo mo i = lookupIdent i (jments mo) diff --git a/src/GF/Devel/PrintGFCC.hs b/src/GF/Devel/PrintGFCC.hs deleted file mode 100644 index c7e668884..000000000 --- a/src/GF/Devel/PrintGFCC.hs +++ /dev/null @@ -1,21 +0,0 @@ -module GF.Devel.PrintGFCC where - -import GF.GFCC.DataGFCC (GFCC) -import GF.GFCC.Raw.ConvertGFCC (fromGFCC) -import GF.GFCC.Raw.PrintGFCCRaw (printTree) -import GF.Devel.GFCCtoHaskell -import GF.Devel.GFCCtoJS -import GF.Text.UTF8 - --- top-level access to code generation - -prGFCC :: String -> GFCC -> String -prGFCC printer gr = case printer of - "haskell" -> grammar2haskell gr - "haskell_gadt" -> grammar2haskellGADT gr - "js" -> gfcc2js gr - _ -> printGFCC gr - -printGFCC :: GFCC -> String -printGFCC = encodeUTF8 . printTree . fromGFCC - diff --git a/src/GF/Devel/README-testgf3 b/src/GF/Devel/README-testgf3 deleted file mode 100644 index 0d1b6e80a..000000000 --- a/src/GF/Devel/README-testgf3 +++ /dev/null @@ -1,49 +0,0 @@ -GF3, the next version of GF -Aarne Ranta - - -Version 1: 20/2/2008 - -To compile: - - make testgf3 - -To run: - - testgf3 <options> - -Options: - - -src -- read from source - -doemit -- emit gfn files - -More options (debugging flags): - - -show_gf -- show compiled source module after parsing - -show_extend -- ... after extension - -show_rename -- ... after renaming - -show_typecheck -- ... after type checking - -show_refreshing -- ... after refreshing variables - -show_optimize -- ... after partial evaluation - -show_factorize -- ... after factoring optimization - -show_all -- show all phases - - -1 -- stop after parsing - -2 -- ... extending - -3 -- ... renaming - -4 -- ... type checking - -5 -- ... refreshing - -==Compiler Phases== - -LexGF -ParGF -SourceToGF -Extend -Rename -CheckGrammar -Refresh -Optimize -Factorize -GFtoGFCC - diff --git a/src/GF/Devel/ReadFiles.hs b/src/GF/Devel/ReadFiles.hs deleted file mode 100644 index a10ee1991..000000000 --- a/src/GF/Devel/ReadFiles.hs +++ /dev/null @@ -1,196 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ReadFiles --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 23:24:34 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.26 $ --- --- Decide what files to read as function of dependencies and time stamps. --- --- make analysis for GF grammar modules. AR 11\/6\/2003--24\/2\/2004 --- --- 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.gfo@ otherwise. ------------------------------------------------------------------------------ - -module GF.Devel.ReadFiles - ( getAllFiles,ModName,ModEnv,getOptionsFromFile,importsOfModule, - gfoFile,gfFile,isGFO ) where - -import GF.Infra.Option -import GF.Data.Operations -import GF.Devel.UseIO -import GF.Source.AbsGF hiding (FileName) -import GF.Source.LexGF -import GF.Source.ParGF - -import Control.Monad -import Data.Char -import Data.List -import qualified Data.ByteString.Char8 as BS -import qualified Data.Map as Map -import System -import System.Time -import System.Directory -import System.FilePath - -type ModName = String -type ModEnv = Map.Map ModName (ClockTime,[ModName]) - - --- | Returns a list of all files to be compiled in topological order i.e. --- the low level (leaf) modules are first. -getAllFiles :: Options -> [InitPath] -> ModEnv -> FileName -> IOE [FullPath] -getAllFiles opts ps env file = do - -- read module headers from all files recursively - ds <- liftM reverse $ get [] [] (justModuleName file) - if oElem beVerbose opts - then ioeIO $ putStrLn $ "all modules:" +++ show [name | (name,_,_,_,_) <- ds] - else return () - return $ paths ds - where - -- construct list of paths to read - paths cs = [mk (p </> f) | (f,st,_,_,p) <- cs, mk <- mkFile st] - where - mkFile CSComp = [gfFile ] - mkFile CSRead = [gfoFile] - mkFile _ = [] - - -- | traverses the dependency graph and returns a topologicaly sorted - -- list of ModuleInfo. An error is raised if there is circular dependency - get :: [ModName] -- ^ keeps the current path in the dependency graph to avoid cycles - -> [ModuleInfo] -- ^ a list of already traversed modules - -> ModName -- ^ the current module - -> IOE [ModuleInfo] -- ^ the final - get trc ds name - | name `elem` trc = ioeErr $ Bad $ "circular modules" +++ unwords trc - | (not . null) [n | (n,_,_,_,_) <- ds, name == n] --- file already read - = return ds - | otherwise = do - (name,st0,t0,imps,p) <- findModule name - ds <- foldM (get (name:trc)) ds imps - let (st,t) | (not . null) [f | (f,CSComp,_,_,_) <- ds, elem f imps] - = (CSComp,Nothing) - | otherwise = (st0,t0) - return ((name,st,t,imps,p):ds) - - -- searches for module in the search path and if it is found - -- returns 'ModuleInfo'. It fails if there is no such module - findModule :: ModName -> IOE ModuleInfo - findModule name = do - (file,gfTime,gfoTime) <- do - mb_gfFile <- ioeIO $ getFilePathMsg "" ps (gfFile name) - case mb_gfFile of - Just gfFile -> do gfTime <- ioeIO $ getModificationTime gfFile - mb_gfoTime <- ioeIO $ catch (liftM Just $ getModificationTime (replaceExtension gfFile "gfo")) - (\_->return Nothing) - return (gfFile, Just gfTime, mb_gfoTime) - Nothing -> do mb_gfoFile <- ioeIO $ getFilePathMsg "" ps (gfoFile name) - case mb_gfoFile of - Just gfoFile -> do gfoTime <- ioeIO $ getModificationTime gfoFile - return (gfoFile, Nothing, Just gfoTime) - Nothing -> ioeErr $ Bad ("File " ++ gfFile name ++ " does not exist.") - - - let mb_envmod = Map.lookup name env - (st,t) = selectFormat opts (fmap fst mb_envmod) gfTime gfoTime - - imps <- if st == CSEnv - then return (maybe [] snd mb_envmod) - else do s <- ioeIO $ BS.readFile file - (mname,imps) <- ioeErr ((liftM importsOfModule . pModHeader . myLexer) s) - ioeErr $ testErr (mname == name) - ("module name" +++ mname +++ "differs from file name" +++ name) - return imps - - return (name,st,t,imps,dropFileName file) - - -isGFO :: FilePath -> Bool -isGFO = (== ".gfo") . takeExtensions - -gfoFile :: FilePath -> FilePath -gfoFile f = addExtension f "gfo" - -gfFile :: FilePath -> FilePath -gfFile f = addExtension f "gf" - - --- From the given Options and the time stamps computes --- whether the module have to be computed, read from .gfo or --- the environment version have to be used -selectFormat :: Options -> Maybe ClockTime -> Maybe ClockTime -> Maybe ClockTime -> (CompStatus,Maybe ClockTime) -selectFormat opts mtenv mtgf mtgfo = - case (mtenv,mtgfo,mtgf) of - (_,_,Just tgf) | fromSrc -> (CSComp,Nothing) - (Just tenv,_,_) | fromComp -> (CSEnv, Just tenv) - (_,Just tgfo,_) | fromComp -> (CSRead,Just tgfo) - (Just tenv,_,Just tgf) | tenv > tgf -> (CSEnv, Just tenv) - (_,Just tgfo,Just tgf) | tgfo > tgf -> (CSRead,Just tgfo) - (Just tenv,_,Nothing) -> (CSEnv,Just tenv) -- source does not exist - (_,_, Nothing) -> (CSRead,Nothing) -- source does not exist - _ -> (CSComp,Nothing) - where - fromComp = oElem isCompiled opts -- i -gfo - fromSrc = oElem fromSource opts - - --- internal module dep information - - -data CompStatus = - CSComp -- compile: read gf - | CSRead -- read gfo - | CSEnv -- gfo is in env - deriving Eq - -type ModuleInfo = (ModName,CompStatus,Maybe ClockTime,[ModName],InitPath) - - -importsOfModule :: ModDef -> (ModName,[ModName]) -importsOfModule (MModule _ typ body) = modType typ (modBody body []) - where - modType (MTAbstract m) xs = (modName m,xs) - modType (MTResource m) xs = (modName m,xs) - modType (MTInterface m) xs = (modName m,xs) - modType (MTConcrete m m2) xs = (modName m,modName m2:xs) - modType (MTInstance m m2) xs = (modName m,modName m2:xs) - modType (MTTransfer m o1 o2) xs = (modName m,open o1 (open o2 xs)) - - modBody (MBody e o _) xs = extend e (opens o xs) - modBody (MNoBody is) xs = foldr include xs is - modBody (MWith i os) xs = include i (foldr open xs os) - modBody (MWithBody i os o _) xs = include i (foldr open (opens o xs) os) - modBody (MWithE is i os) xs = foldr include (include i (foldr open xs os)) is - modBody (MWithEBody is i os o _) xs = foldr include (include i (foldr open (opens o xs) os)) is - modBody (MReuse m) xs = modName m:xs - modBody (MUnion is) xs = foldr include xs is - - include (IAll m) xs = modName m:xs - include (ISome m _) xs = modName m:xs - include (IMinus m _) xs = modName m:xs - - open (OName n) xs = modName n:xs - open (OQualQO _ n) xs = modName n:xs - open (OQual _ _ n) xs = modName n:xs - - extend NoExt xs = xs - extend (Ext is) xs = foldr include xs is - - opens NoOpens xs = xs - opens (OpenIn os) xs = foldr open xs os - - modName (PIdent (_,s)) = s - - --- | options can be passed to the compiler by comments in @--#@, in the main file -getOptionsFromFile :: FilePath -> IO Options -getOptionsFromFile file = do - s <- readFileIfStrict file - let ls = filter (BS.isPrefixOf (BS.pack "--#")) $ BS.lines s - return $ fst $ getOptions "-" $ map (BS.unpack . BS.unwords . BS.words . BS.drop 3) ls diff --git a/src/GF/Devel/TC.hs b/src/GF/Devel/TC.hs deleted file mode 100644 index 5c439f671..000000000 --- a/src/GF/Devel/TC.hs +++ /dev/null @@ -1,299 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : TC --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/02 20:50:19 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.11 $ --- --- Thierry Coquand's type checking algorithm that creates a trace ------------------------------------------------------------------------------ - -module GF.Devel.TC (AExp(..), - Theory, - checkExp, - inferExp, - checkEqs, - eqVal, - whnf - ) where - -import GF.Data.Operations -import GF.Grammar.Abstract -import GF.Devel.AbsCompute - -import Control.Monad -import Data.List (sortBy) - -data AExp = - AVr Ident Val - | ACn QIdent Val - | AType - | AInt Integer - | AFloat Double - | AStr String - | AMeta MetaSymb Val - | AApp AExp AExp Val - | AAbs Ident Val AExp - | AProd Ident AExp AExp - | AEqs [([Exp],AExp)] --- not used - | AData Val - 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) - QC m c -> return $ VCn (m,c) ---- == Q ? - 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] - (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j] - --- thus ignore qualifications; valid because inheritance cannot - --- be qualified. Simplifies annotation. AR 17/3/2005 - _ -> 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,[]) - EData -> return $ (AData 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 - --- {- --- to get deprec when checkEqs works (15/9/2005) - 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 - | m == cPredefAbs && (elem c (map identC ["Int","String","Float"])) -> - return (ACn (m,c) vType, vType, []) - | otherwise -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c) - QC m c -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c) ---- - EInt i -> return (AInt i, valAbsInt, []) - EFloat i -> return (AFloat i, valAbsFloat, []) - K i -> return (AStr i, valAbsString, []) - 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 - where - predefAbs c s = case c of - IC "Int" -> return $ const $ Q cPredefAbs cInt - IC "Float" -> return $ const $ Q cPredefAbs cFloat - IC "String" -> return $ const $ Q cPredefAbs cString - _ -> Bad s - -checkEqs :: Theory -> TCEnv -> (Fun,Trm) -> Val -> Err [(Val,Val)] -checkEqs th tenv@(k,rho,gamma) (fun@(m,f),def) val = case def of - Eqs es -> liftM concat $ mapM checkBranch es - _ -> liftM snd $ checkExp th tenv def val - where - checkBranch (ps,df) = - let - (ps',_,vars) = foldr p2t ([],0,[]) ps - fps = mkApp (Q m f) ps' - in errIn ("branch" +++ prt fps) $ do - (aexp, typ, cs1) <- inferExp th tenv fps - let - bds = binds vars aexp - tenv' = (k, rho, bds ++ gamma) - (_,cs2) <- errIn (show bds) $ checkExp th tenv' df typ - return $ (cs1 ++ cs2) - p2t p (ps,i,g) = case p of - PW -> (meta (MetaSymb i) : ps, i+1, g) - PV IW -> (meta (MetaSymb i) : ps, i+1, g) - PV x -> (meta (MetaSymb i) : ps, i+1,upd x i g) - PString s -> ( K s : ps, i, g) - PInt n -> (EInt n : ps, i, g) - PFloat n -> (EFloat n : ps, i, g) - PP m c xs -> (mkApp (qq (m,c)) xss : ps, i', g') - where (xss,i',g') = foldr p2t ([],i,g) xs - _ -> error $ "undefined p2t case" +++ prt p +++ "in checkBranch" - upd x i g = (x,i) : g --- to annotate pattern variables: treat as metas - - -- notice: in vars, the sequence 0.. is sorted. In subst aexp, all - -- this occurs and nothing else. - binds vars aexp = [(x,v) | ((x,_),v) <- zip vars metas] where - metas = map snd $ sortBy (\ (x,_) (y,_) -> compare x y) $ subst aexp - subst aexp = case aexp of - AMeta (MetaSymb i) v -> [(i,v)] - AApp c a _ -> subst c ++ subst a - _ -> [] -- never matter in patterns - -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,k') = ps2ts k ps - tenv' = (k, rho2++rho, gamma) ---- k' ? - (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 - PW -> (meta (MetaSymb i) : ps, i+1,g,k) - PV IW -> (meta (MetaSymb i) : ps, i+1,g,k) - PV x -> (vr x : ps, i, upd x k g,k+1) - PString s -> (K s : ps, i, g, k) - PInt n -> (EInt n : ps, i, g, k) - PFloat n -> (EFloat n : 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, []) - EInt i -> return (AInt i, valAbsInt, []) - EFloat i -> return (AFloat i, valAbsFloat, []) - K s -> return (AStr s, valAbsString, []) - - Q m c -> do - typ <- lookupConst th (m,c) - return $ (ACn (m,c) typ, typ, []) - QC 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/Devel/TestGF3.hs b/src/GF/Devel/TestGF3.hs deleted file mode 100644 index da4b5c8f6..000000000 --- a/src/GF/Devel/TestGF3.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Main where - -import GF.Devel.Compile.GFC - -import System (getArgs) - -main = do - xx <- getArgs - mainGFC xx diff --git a/src/GF/Devel/TypeCheck.hs b/src/GF/Devel/TypeCheck.hs deleted file mode 100644 index 818b48a10..000000000 --- a/src/GF/Devel/TypeCheck.hs +++ /dev/null @@ -1,311 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : TypeCheck --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/09/15 16:22:02 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.16 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Devel.TypeCheck (-- * top-level type checking functions; TC should not be called directly. - annotate, annotateIn, - justTypeCheck, checkIfValidExp, - reduceConstraints, - splitConstraints, - possibleConstraints, - reduceConstraintsNode, - performMetaSubstNode, - -- * some top-level batch-mode checkers for the compiler - justTypeCheckSrc, - grammar2theorySrc, - checkContext, - checkTyp, - checkEquation, - checkConstrs, - editAsTermCommand, - exp2termCommand, - exp2termlistCommand, - tree2termlistCommand - ) where - -import GF.Data.Operations -import GF.Data.Zipper - -import GF.Grammar.Abstract -import GF.Devel.AbsCompute -import GF.Grammar.Refresh -import GF.Grammar.LookAbs -import qualified GF.Grammar.Lookup as Lookup --- - -import GF.Devel.TC - -import GF.Grammar.Unify --- - -import Control.Monad (foldM, liftM, liftM2) -import Data.List (nub) --- - --- 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 (lookupAbsDef gr) 0 constrs0 - return $ fst $ splitConstraints gr 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 (lookupAbsDef 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 (lookupAbsDef 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 :: LookDef -> Int -> Constraints -> Err Constraints -reduceConstraints look i = liftM concat . mapM redOne where - redOne (u,v) = do - u' <- computeVal look u - v' <- computeVal look v - eqVal i u' v' - -computeVal :: LookDef -> Val -> Err Val -computeVal look v = case v of - VClos g@(_:_) e -> do - e' <- compt (map fst g) e --- bindings of g in e? - whnf $ VClos g e' -{- ---- - _ -> do ---- how to compute a Val, really?? - e <- val2exp v - e' <- compt [] e - whnf $ vClos e' --} - VApp f c -> liftM2 VApp (compv f) (compv c) >>= whnf - _ -> whnf v - where - compt = computeAbsTermIn look - compv = computeVal look - --- | take apart constraints that have the form (? <> t), usable as solutions -splitConstraints :: GFCGrammar -> Constraints -> (Constraints,MetaSubst) -splitConstraints gr = splitConstraintsGen (lookupAbsDef gr) - -splitConstraintsSrc :: Grammar -> Constraints -> (Constraints,MetaSubst) -splitConstraintsSrc gr = splitConstraintsGen (Lookup.lookupAbsDef gr) - -splitConstraintsGen :: LookDef -> Constraints -> (Constraints,MetaSubst) -splitConstraintsGen look cs = csmsu where - - csmsu = (nub [(a,b) | (a,b) <- csf1,a /= b],msf1) - (csf1,msf1) = unif (csf,msf) -- alternative: filter first - (csf,msf) = foldr mkOne ([],[]) cs - - csmsf = foldr mkOne ([],msu) csu - (csu,msu) = unif (cs1,[]) -- alternative: unify first - - cs1 = errVal cs $ reduceConstraints look 0 cs - - 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 - -reduceConstraintsNode :: GFCGrammar -> TrNode -> TrNode -reduceConstraintsNode gr = changeConstrs red where - red cs = errVal cs $ reduceConstraints (lookupAbsDef gr) 0 cs - --- | 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 = isUnknown t || isUnknown u || case (t,u) of - (Q m c, Q n d) -> c == d || notCan (m,c) || notCan (n,d) - (QC m c, QC n d) -> c == 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 - (_ , _) -> False - - 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',[]) - AInt i -> do - return ([],AtI i,valAbsInt,[]) - AFloat i -> do - return ([],AtF i,valAbsFloat,[]) - AStr s -> do - return ([],AtL s,valAbsString,[]) - 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 - return $ filter notJustMeta constrs0 ----- return $ fst $ splitConstraintsSrc gr constrs0 ----- this change was to force proper tc of abstract modules. ----- May not be quite right. AR 13/9/2005 - -notJustMeta (c,k) = case (c,k) of - (VClos g1 (Meta m1), VClos g2 (Meta m2)) -> False - _ -> True - -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 <- checkEqs (grammar2theorySrc gr) (initTCEnv []) ((m,fun),def) (vClos typ) - cs <- justTypeCheckSrc gr def (vClos typ) - let cs1 = filter notJustMeta 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' - -exp2termCommand :: GFCGrammar -> (Exp -> Err Exp) -> Tree -> Err Tree -exp2termCommand gr f t = errIn ("modifying term" +++ prt t) $ do - let exp = tree2exp t - exp2 <- f exp - annotate gr exp2 - -exp2termlistCommand :: GFCGrammar -> (Exp -> [Exp]) -> Tree -> [Tree] -exp2termlistCommand gr f = err (const []) fst . mapErr (annotate gr) . f . tree2exp - -tree2termlistCommand :: GFCGrammar -> (Tree -> [Exp]) -> Tree -> [Tree] -tree2termlistCommand gr f = err (const []) fst . mapErr (annotate gr) . f diff --git a/src/GF/Devel/UseIO.hs b/src/GF/Devel/UseIO.hs deleted file mode 100644 index afbf00efd..000000000 --- a/src/GF/Devel/UseIO.hs +++ /dev/null @@ -1,298 +0,0 @@ -{-# OPTIONS -cpp #-} ----------------------------------------------------------------------- --- | --- Module : UseIO --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/08/08 09:01:25 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.17 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Devel.UseIO where - -import GF.Data.Operations -import GF.Infra.Option -import GF.Today (libdir) - -import System.Directory -import System.FilePath -import System.IO -import System.IO.Error -import System.Environment -import System.CPUTime -import Control.Monad -import Control.Exception(evaluate) -import qualified Data.ByteString.Char8 as BS - -#ifdef mingw32_HOST_OS -import System.Win32.DLL -import Foreign.Ptr -#endif - -putShow' :: Show a => (c -> a) -> c -> IO () -putShow' f = putStrLn . show . length . show . f - -putIfVerb :: Options -> String -> IO () -putIfVerb opts msg = - if oElem beVerbose opts - then putStrLn msg - else return () - -putIfVerbW :: Options -> String -> IO () -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 - -readFileIf f = catch (readFile f) (\_ -> reportOn f) where - reportOn f = do - putStrLnFlush ("File " ++ f ++ " does not exist. Returned empty string") - return "" - -readFileIfStrict f = catch (BS.readFile f) (\_ -> reportOn f) where - reportOn f = do - putStrLnFlush ("File " ++ f ++ " does not exist. Returned empty string") - return BS.empty - -type FileName = String -type InitPath = String -type FullPath = String - -getFilePath :: [FilePath] -> String -> IO (Maybe FilePath) -getFilePath ps file = getFilePathMsg ("file" +++ file +++ "not found\n") ps file - -getFilePathMsg :: String -> [FilePath] -> String -> IO (Maybe FilePath) -getFilePathMsg msg paths file = get paths where - get [] = putStrFlush msg >> return Nothing - get (p:ps) = do - let pfile = p </> file - exist <- doesFileExist pfile - if not exist - then get ps - else do pfile <- canonicalizePath pfile - return (Just pfile) - -readFileIfPath :: [FilePath] -> String -> IOE (FilePath,BS.ByteString) -readFileIfPath paths file = do - mpfile <- ioeIO $ getFilePath paths file - case mpfile of - Just pfile -> do - s <- ioeIO $ BS.readFile pfile - return (dropFileName pfile,s) - _ -> ioeErr $ Bad ("File " ++ file ++ " does not exist.") - -doesFileExistPath :: [FilePath] -> String -> IOE Bool -doesFileExistPath paths file = do - mpfile <- ioeIO $ getFilePathMsg "" paths file - return $ maybe False (const True) mpfile - -gfLibraryPath = "GF_LIB_PATH" -gfGrammarPathVar = "GF_GRAMMAR_PATH" - -getLibraryPath :: IO FilePath -getLibraryPath = - catch - (getEnv gfLibraryPath) -#ifdef mingw32_HOST_OS - (\_ -> do exepath <- getModuleFileName nullPtr - let (path,_) = splitFileName exepath - canonicalizePath (combine path "../lib")) -#else - (const (return libdir)) -#endif - --- | extends the search path with the --- 'gfLibraryPath' and 'gfGrammarPathVar' --- environment variables. Returns only existing paths. -extendPathEnv :: [FilePath] -> IO [FilePath] -extendPathEnv ps = do - b <- getLibraryPath -- e.g. GF_LIB_PATH - s <- catch (getEnv gfGrammarPathVar) (const (return "")) -- e.g. GF_GRAMMAR_PATH - let ss = ps ++ splitSearchPath s - liftM concat $ mapM allSubdirs $ ss ++ [b </> s | s <- ss ++ ["prelude"]] - where - allSubdirs :: FilePath -> IO [FilePath] - allSubdirs [] = return [[]] - allSubdirs p = case last p of - '*' -> do let path = init p - fs <- getSubdirs path - return [path </> f | f <- fs] - _ -> do exists <- doesDirectoryExist p - if exists - then return [p] - else return [] - -getSubdirs :: FilePath -> IO [FilePath] -getSubdirs dir = do - fs <- catch (getDirectoryContents dir) (const $ return []) - foldM (\fs f -> do let fpath = dir </> f - p <- getPermissions fpath - if searchable p && not (take 1 f==".") - then return (fpath:fs) - else return fs ) [] fs - -justModuleName :: FilePath -> String -justModuleName = dropExtension . takeFileName - -splitInModuleSearchPath :: String -> [FilePath] -splitInModuleSearchPath s = case break isPathSep s of - (f,_:cs) -> f : splitInModuleSearchPath cs - (f,_) -> [f] - where - isPathSep :: Char -> Bool - isPathSep c = c == ':' || c == ';' - --- - -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 - -foldIOE :: (a -> b -> IOE a) -> a -> [b] -> IOE (a, Maybe String) -foldIOE f s xs = case xs of - [] -> return (s,Nothing) - x:xx -> do - ev <- ioeIO $ appIOE (f s x) - case ev of - Ok v -> foldIOE f v xx - Bad m -> return $ (s, Just m) - -putStrLnE :: String -> IOE () -putStrLnE = ioeIO . putStrLnFlush - -putStrE :: String -> IOE () -putStrE = ioeIO . putStrFlush - --- this is more verbose -putPointE :: Options -> String -> IOE a -> IOE a -putPointE = putPointEgen (oElem beSilent) - --- this is less verbose -putPointEsil :: Options -> String -> IOE a -> IOE a -putPointEsil = putPointEgen (not . oElem beVerbose) - -putPointEgen :: (Options -> Bool) -> Options -> String -> IOE a -> IOE a -putPointEgen cond opts msg act = do - let ve x = if cond opts then return () else x - ve $ ioeIO $ putStrFlush msg - - t1 <- ioeIO $ getCPUTime - a <- act >>= ioeIO . evaluate - t2 <- ioeIO $ getCPUTime - - ve $ ioeIO $ putStrLnFlush (' ' : show ((t2 - t1) `div` 1000000000) ++ " msec") - 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 BS.ByteString -readFileIOE f = ioe $ catch (BS.readFile f >>= return . return) - (\e -> return (Bad (show e))) - --- | 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, BS.ByteString) -readFileLibraryIOE ini f = ioe $ do - lp <- getLibraryPath - tryRead ini $ \_ -> - tryRead lp $ \e -> - return (Bad (show e)) - where - tryRead path onError = - catch (BS.readFile fpath >>= \s -> return (return (fpath,s))) - onError - where - fpath = path </> f - --- | example -koeIOE :: IO () -koeIOE = useIOE () $ do - s <- ioeIO $ getLine - s2 <- ioeErr $ mapM (!? 2) $ words s - ioeIO $ putStrLn s2 - diff --git a/src/GF/Devel/gf-code.txt b/src/GF/Devel/gf-code.txt deleted file mode 100644 index e8954bedf..000000000 --- a/src/GF/Devel/gf-code.txt +++ /dev/null @@ -1,66 +0,0 @@ -Guide to GF Implementation Code -Aarne Ranta - - - -This document describes the code in GF grammar compiler and interactive -environment. It is aimed to cover well the implementation of the forthcoming -GF3. In comparison to GF 2.8, this implementation uses -- the same source language, GF (only slightly modified) -- a different run-time target language, GFCC (instead of GFCM) -- a different separate compilation target language (a fragment GF itself, - instead of GFC) -- a different internal representation of source code - - -Apart from GFCC, the goal of GF3 is simplification and consolidation, rather -than innovation. This is shown in particular in the abolition of GFC, and in -the streamlined internal source code format. The insight needed to achieve -these simplifications would not have been possible (at least for us) without -years of experimenting with the more messy formats; those formats moreover -grew organically when features were added to the GF language, and the old -implementation was thus a result of evolution rather than careful planning. - -GF3 is planned to be released in an Alpha version in the end of 2007, its -sources forming a part of GF release 2.9. - -There are currently two versions of GF3, as regards executables and ``make`` -items: -- ``gf3``, using the old internal representation of source language, and - integrating a compiler from GF to GFCC and an interpreter of GFCC -- ``testgf3``, using the new formats everywhere but implementing the compiler - only; this program does not yet yield reasonable output - - -The descriptions below will target the newest ideas, that is, ``textgf3`` -whenever it differs from ``gf3``. - - -==The structure of the code== - -Code that is not shared with GF 2.8 is located in subdirectories of -``GF/Devel/``. Those subdirectories will, however, be moved one level -up. Currently they include -- ``GF/Devel/Grammar``: the datatypes and basic operations of source code -- ``GF/Devel/Compile``: the phases of compiling GF to GFCC - - -The other directories involved are -- ``GF/GFCC``: data types and functionalities of GFCC -- ``GF/Infra``: infrastructure utilities for the implementation -- ``GF/Data``: datastructures belonging to infrastructure - - -==The source code implementation== - -==The compiler== - -==The GFCC interpreter== - -==The GF command interpreter== - - - - - - diff --git a/src/GF/Devel/gf3.txt b/src/GF/Devel/gf3.txt deleted file mode 100644 index 56feeba2a..000000000 --- a/src/GF/Devel/gf3.txt +++ /dev/null @@ -1,84 +0,0 @@ -GF Version 3.0 -Aarne Ranta -7 November 2007 - - -This document summarizes the goals and status of the forthcoming -GF version 3.0. - -==Overview== - -GF 3 results from the following needs: -- refactor GF to make it more maintainable -- provide a simple command-line batch compiler -- replace gfc by the much simpler gfcc format for embedded grammars - - -The current implementation of GF 3 has three binaries: -- gfc, batch compiler, for building grammar applications -- gfi, interpreter for gfcc grammars, for using grammars -- gf, interactive compiler with interpreter, for developing grammars - - -Thus, roughly, gf = gfc + gfi. - -Question: should we have, like current GF, just one binary, gf, and -implement the others by shell scripts calling gf with suitable options? -- +: one binary is less code altogether -- +: one binary is easier to distribute and update -- -: each of the components is less code by itself -- -: many users might only need either the compiler or the interpreter -- -: those users could avoid installation problems such as readline - - -There are some analogies in other languages: - - || GF | Haskell | Java || - | gfc | ghc | javac | - | gfi | ghci* | java | - | gf | ghci* | - | - -In Haskell, ghci makes more than gfi since it reads source files, but -less than gf since it does not compile them to externally usable target -code. - - - - -==Status of code and functionalities== - -GF executable v. 2.8 -- gf: 263 modules, executable 7+ MB (on MacOS i386) - - -Current status of GF 3.0 alpha: -- gf3: 94 modules, executable 4+ MB -- gfc: 71 modules, executable 3+ MB -- gfi: 35 modules, executable 1+ MB - - -Missing functionalities -- in gfc: - - input formats: cf, ebnf, gfe, old gf - - output formats: speech grammars, bnfc - - integrating options for input, output, and debugging information - (as described in Devel/GFC/Options.hs) - - -- in gfi: - - command cc (computing with resource) - - morphological analysis, linearization with tables - - quizzes, treebanks - - syntax editor - - readline - - -==Additional feature options== - -Native Haskell readline - -Binary formats for gfo and gfcc - -Parallel compilation on multicore machines - - |
