summaryrefslogtreecommitdiff
path: root/src/GF/Devel
diff options
context:
space:
mode:
authoraarne <aarne@cs.chalmers.se>2008-06-25 16:43:48 +0000
committeraarne <aarne@cs.chalmers.se>2008-06-25 16:43:48 +0000
commitb96b36f43de3e2f8b58d5f539daa6f6d47f25870 (patch)
tree0992334be13cec6538a1dea22fbbf26ad6bdf224 /src/GF/Devel
parentfe367412e0aeb4ad5c02de68e6eca382e0f96984 (diff)
removed src for 2.9
Diffstat (limited to 'src/GF/Devel')
-rw-r--r--src/GF/Devel/AbsCompute.hs145
-rw-r--r--src/GF/Devel/Arch.hs89
-rw-r--r--src/GF/Devel/CheckGrammar.hs1090
-rw-r--r--src/GF/Devel/CheckM.hs89
-rw-r--r--src/GF/Devel/Compile.hs203
-rw-r--r--src/GF/Devel/Compile/AbsGF.hs274
-rw-r--r--src/GF/Devel/Compile/CheckGrammar.hs1089
-rw-r--r--src/GF/Devel/Compile/Compile.hs205
-rw-r--r--src/GF/Devel/Compile/ErrM.hs26
-rw-r--r--src/GF/Devel/Compile/Extend.hs154
-rw-r--r--src/GF/Devel/Compile/Factorize.hs251
-rw-r--r--src/GF/Devel/Compile/GF.cf326
-rw-r--r--src/GF/Devel/Compile/GFC.hs72
-rw-r--r--src/GF/Devel/Compile/GFtoGFCC.hs542
-rw-r--r--src/GF/Devel/Compile/GetGrammar.hs56
-rw-r--r--src/GF/Devel/Compile/LexGF.hs343
-rw-r--r--src/GF/Devel/Compile/Optimize.hs333
-rw-r--r--src/GF/Devel/Compile/ParGF.hs3210
-rw-r--r--src/GF/Devel/Compile/PrintGF.hs481
-rw-r--r--src/GF/Devel/Compile/Refresh.hs118
-rw-r--r--src/GF/Devel/Compile/Rename.hs239
-rw-r--r--src/GF/Devel/Compile/SourceToGF.hs679
-rw-r--r--src/GF/Devel/Compute.hs455
-rw-r--r--src/GF/Devel/GF.hs14
-rw-r--r--src/GF/Devel/GFC.hs67
-rw-r--r--src/GF/Devel/GFC/Main.hs28
-rw-r--r--src/GF/Devel/GFCCInterpreter.hs28
-rw-r--r--src/GF/Devel/GFCCtoHaskell.hs213
-rw-r--r--src/GF/Devel/GFCCtoJS.hs132
-rw-r--r--src/GF/Devel/GFI.hs77
-rw-r--r--src/GF/Devel/GetGrammar.hs54
-rw-r--r--src/GF/Devel/Grammar/AppPredefined.hs166
-rw-r--r--src/GF/Devel/Grammar/Compute.hs380
-rw-r--r--src/GF/Devel/Grammar/Construct.hs221
-rw-r--r--src/GF/Devel/Grammar/GFtoSource.hs223
-rw-r--r--src/GF/Devel/Grammar/Grammar.hs172
-rw-r--r--src/GF/Devel/Grammar/Lookup.hs168
-rw-r--r--src/GF/Devel/Grammar/Macros.hs434
-rw-r--r--src/GF/Devel/Grammar/PatternMatch.hs146
-rw-r--r--src/GF/Devel/Grammar/PrGF.hs246
-rw-r--r--src/GF/Devel/GrammarToGFCC.hs545
-rw-r--r--src/GF/Devel/Infra/ReadFiles.hs348
-rw-r--r--src/GF/Devel/ModDeps.hs153
-rw-r--r--src/GF/Devel/Optimize.hs299
-rw-r--r--src/GF/Devel/OptimizeGF.hs271
-rw-r--r--src/GF/Devel/Options.hs269
-rw-r--r--src/GF/Devel/PrGrammar.hs233
-rw-r--r--src/GF/Devel/PrintGFCC.hs21
-rw-r--r--src/GF/Devel/README-testgf349
-rw-r--r--src/GF/Devel/ReadFiles.hs196
-rw-r--r--src/GF/Devel/TC.hs299
-rw-r--r--src/GF/Devel/TestGF3.hs9
-rw-r--r--src/GF/Devel/TypeCheck.hs311
-rw-r--r--src/GF/Devel/UseIO.hs298
-rw-r--r--src/GF/Devel/gf-code.txt66
-rw-r--r--src/GF/Devel/gf3.txt84
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
-
-