forked from GitHub/gf-core
"Committed_by_peb"
This commit is contained in:
@@ -9,10 +9,9 @@
|
|||||||
-- > CVS $Author $
|
-- > CVS $Author $
|
||||||
-- > CVS $Revision $
|
-- > CVS $Revision $
|
||||||
--
|
--
|
||||||
-- (Description of the module)
|
-- Handles printing a CFGrammar in CFGM format.
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
|
|
||||||
-- Handles printing a CFGrammar in CFGM format.
|
|
||||||
module PrintCFGrammar (prCanonAsCFGM) where
|
module PrintCFGrammar (prCanonAsCFGM) where
|
||||||
|
|
||||||
import AbsGFC
|
import AbsGFC
|
||||||
@@ -32,8 +31,7 @@ import ErrM
|
|||||||
import List (intersperse)
|
import List (intersperse)
|
||||||
import Maybe (listToMaybe, maybe)
|
import Maybe (listToMaybe, maybe)
|
||||||
|
|
||||||
-- FIXME: fix warning about bad -printer= value
|
-- | FIXME: fix warning about bad -printer= value
|
||||||
|
|
||||||
prCanonAsCFGM :: CanonGrammar -> String
|
prCanonAsCFGM :: CanonGrammar -> String
|
||||||
prCanonAsCFGM gr = unlines $ map (uncurry (prLangAsCFGM gr)) xs
|
prCanonAsCFGM gr = unlines $ map (uncurry (prLangAsCFGM gr)) xs
|
||||||
where
|
where
|
||||||
@@ -43,7 +41,7 @@ prCanonAsCFGM gr = unlines $ map (uncurry (prLangAsCFGM gr)) xs
|
|||||||
fromOk (Bad y) = error y
|
fromOk (Bad y) = error y
|
||||||
xs = [(i,getFlag fs "startcat") | (i,ModMod (Module{flags=fs})) <- cncms]
|
xs = [(i,getFlag fs "startcat") | (i,ModMod (Module{flags=fs})) <- cncms]
|
||||||
|
|
||||||
-- FIXME: need to look in abstract module too
|
-- | FIXME: need to look in abstract module too
|
||||||
getFlag :: [Flag] -> String -> Maybe String
|
getFlag :: [Flag] -> String -> Maybe String
|
||||||
getFlag fs x = listToMaybe [v | Flg (IC k) (IC v) <- fs, k == x]
|
getFlag fs x = listToMaybe [v | Flg (IC k) (IC v) <- fs, k == x]
|
||||||
|
|
||||||
|
|||||||
@@ -10,6 +10,9 @@
|
|||||||
-- > CVS $Revision $
|
-- > CVS $Revision $
|
||||||
--
|
--
|
||||||
-- Optimizations on GFC code: sharing, parametrization, value sets.
|
-- Optimizations on GFC code: sharing, parametrization, value sets.
|
||||||
|
--
|
||||||
|
-- optimization: sharing branches in tables. AR 25\/4\/2003.
|
||||||
|
-- following advice of Josef Svenningsson
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
|
|
||||||
module Share (shareModule, OptSpec, shareOpt, paramOpt, valOpt, allOpt) where
|
module Share (shareModule, OptSpec, shareOpt, paramOpt, valOpt, allOpt) where
|
||||||
@@ -23,9 +26,6 @@ import Operations
|
|||||||
import List
|
import List
|
||||||
import qualified Modules as M
|
import qualified Modules as M
|
||||||
|
|
||||||
-- optimization: sharing branches in tables. AR 25/4/2003
|
|
||||||
-- following advice of Josef Svenningsson
|
|
||||||
|
|
||||||
type OptSpec = [Integer] ---
|
type OptSpec = [Integer] ---
|
||||||
|
|
||||||
doOptFactor opt = elem 2 opt
|
doOptFactor opt = elem 2 opt
|
||||||
|
|||||||
@@ -10,6 +10,9 @@
|
|||||||
-- > CVS $Revision $
|
-- > CVS $Revision $
|
||||||
--
|
--
|
||||||
-- Optimizations on GF source code: sharing, parametrization, value sets.
|
-- Optimizations on GF source code: sharing, parametrization, value sets.
|
||||||
|
--
|
||||||
|
-- optimization: sharing branches in tables. AR 25\/4\/2003.
|
||||||
|
-- following advice of Josef Svenningsson
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
|
|
||||||
module BackOpt (shareModule, OptSpec, shareOpt, paramOpt, valOpt, allOpt) where
|
module BackOpt (shareModule, OptSpec, shareOpt, paramOpt, valOpt, allOpt) where
|
||||||
@@ -22,15 +25,24 @@ import Operations
|
|||||||
import List
|
import List
|
||||||
import qualified Modules as M
|
import qualified Modules as M
|
||||||
|
|
||||||
-- optimization: sharing branches in tables. AR 25/4/2003
|
|
||||||
-- following advice of Josef Svenningsson
|
|
||||||
|
|
||||||
type OptSpec = [Integer] ---
|
type OptSpec = [Integer] ---
|
||||||
|
|
||||||
|
doOptFactor :: OptSpec
|
||||||
doOptFactor opt = elem 2 opt
|
doOptFactor opt = elem 2 opt
|
||||||
|
|
||||||
|
doOptValues :: OptSpec
|
||||||
doOptValues opt = elem 3 opt
|
doOptValues opt = elem 3 opt
|
||||||
|
|
||||||
|
shareOpt :: OptSpec
|
||||||
shareOpt = []
|
shareOpt = []
|
||||||
|
|
||||||
|
paramOpt :: OptSpec
|
||||||
paramOpt = [2]
|
paramOpt = [2]
|
||||||
|
|
||||||
|
valOpt :: OptSpec
|
||||||
valOpt = [3]
|
valOpt = [3]
|
||||||
|
|
||||||
|
allOpt :: OptSpec
|
||||||
allOpt = [2,3]
|
allOpt = [2,3]
|
||||||
|
|
||||||
shareModule :: OptSpec -> (Ident, SourceModInfo) -> (Ident, SourceModInfo)
|
shareModule :: OptSpec -> (Ident, SourceModInfo) -> (Ident, SourceModInfo)
|
||||||
|
|||||||
@@ -9,7 +9,15 @@
|
|||||||
-- > CVS $Author $
|
-- > CVS $Author $
|
||||||
-- > CVS $Revision $
|
-- > CVS $Revision $
|
||||||
--
|
--
|
||||||
-- (Description of the module)
|
-- 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 CheckGrammar where
|
module CheckGrammar where
|
||||||
@@ -36,20 +44,12 @@ import CheckM
|
|||||||
import List
|
import List
|
||||||
import Monad
|
import Monad
|
||||||
|
|
||||||
-- AR 4/12/1999 -- 1/4/2000 -- 8/9/2001 -- 15/5/2002 -- 27/11/2002 -- 18/6/2003
|
|
||||||
|
|
||||||
-- type checking also does the following modifications:
|
|
||||||
-- * types of operations and local constants are inferred and put in place
|
|
||||||
-- * both these types and linearization types are computed
|
|
||||||
-- * tables are type-annotated
|
|
||||||
|
|
||||||
showCheckModule :: [SourceModule] -> SourceModule -> Err ([SourceModule],String)
|
showCheckModule :: [SourceModule] -> SourceModule -> Err ([SourceModule],String)
|
||||||
showCheckModule mos m = do
|
showCheckModule mos m = do
|
||||||
(st,(_,msg)) <- checkStart $ checkModule mos m
|
(st,(_,msg)) <- checkStart $ checkModule mos m
|
||||||
return (st, unlines $ reverse msg)
|
return (st, unlines $ reverse msg)
|
||||||
|
|
||||||
-- checking is performed in dependency order of modules
|
-- | checking is performed in dependency order of modules
|
||||||
|
|
||||||
checkModule :: [SourceModule] -> SourceModule -> Check [SourceModule]
|
checkModule :: [SourceModule] -> SourceModule -> Check [SourceModule]
|
||||||
checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod of
|
checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod of
|
||||||
|
|
||||||
@@ -79,8 +79,7 @@ checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod
|
|||||||
where
|
where
|
||||||
gr = MGrammar $ (name,mod):ms
|
gr = MGrammar $ (name,mod):ms
|
||||||
|
|
||||||
-- check if a term is typable
|
-- | check if a term is typable
|
||||||
|
|
||||||
justCheckLTerm :: SourceGrammar -> Term -> Err Term
|
justCheckLTerm :: SourceGrammar -> Term -> Err Term
|
||||||
justCheckLTerm src t = do
|
justCheckLTerm src t = do
|
||||||
((t',_),_) <- checkStart (inferLType src t)
|
((t',_),_) <- checkStart (inferLType src t)
|
||||||
@@ -131,9 +130,8 @@ checkCompleteGrammar abs cnc = mapM_ checkWarn $
|
|||||||
then id
|
then id
|
||||||
else (("Warning: no linearization of" +++ prt f):)
|
else (("Warning: no linearization of" +++ prt f):)
|
||||||
|
|
||||||
-- General Principle: only Yes-values are checked.
|
-- | General Principle: only Yes-values are checked.
|
||||||
-- A May-value has always been checked in its origin module.
|
-- A May-value has always been checked in its origin module.
|
||||||
|
|
||||||
checkResInfo :: SourceGrammar -> (Ident,Info) -> Check (Ident,Info)
|
checkResInfo :: SourceGrammar -> (Ident,Info) -> Check (Ident,Info)
|
||||||
checkResInfo gr (c,info) = do
|
checkResInfo gr (c,info) = do
|
||||||
checkReservedId c
|
checkReservedId c
|
||||||
@@ -289,7 +287,7 @@ checkPrintname :: SourceGrammar -> Perh Term -> Check ()
|
|||||||
checkPrintname st (Yes t) = checkLType st t typeStr >> return ()
|
checkPrintname st (Yes t) = checkLType st t typeStr >> return ()
|
||||||
checkPrintname _ _ = return ()
|
checkPrintname _ _ = return ()
|
||||||
|
|
||||||
-- for grammars obtained otherwise than by parsing ---- update!!
|
-- | for grammars obtained otherwise than by parsing ---- update!!
|
||||||
checkReservedId :: Ident -> Check ()
|
checkReservedId :: Ident -> Check ()
|
||||||
checkReservedId x = let c = prt x in
|
checkReservedId x = let c = prt x in
|
||||||
if isResWord c
|
if isResWord c
|
||||||
@@ -643,13 +641,13 @@ termWith t ct = do
|
|||||||
ty <- ct
|
ty <- ct
|
||||||
return (t,ty)
|
return (t,ty)
|
||||||
|
|
||||||
-- light-weight substitution for dep. types
|
-- | light-weight substitution for dep. types
|
||||||
substituteLType :: Context -> Type -> Check Type
|
substituteLType :: Context -> Type -> Check Type
|
||||||
substituteLType g t = case t of
|
substituteLType g t = case t of
|
||||||
Vr x -> return $ maybe t id $ lookup x g
|
Vr x -> return $ maybe t id $ lookup x g
|
||||||
_ -> composOp (substituteLType g) t
|
_ -> composOp (substituteLType g) t
|
||||||
|
|
||||||
-- compositional check/infer of binary operations
|
-- | compositional check\/infer of binary operations
|
||||||
check2 :: (Term -> Check Term) -> (Term -> Term -> Term) ->
|
check2 :: (Term -> Check Term) -> (Term -> Term -> Term) ->
|
||||||
Term -> Term -> Type -> Check (Term,Type)
|
Term -> Term -> Type -> Check (Term,Type)
|
||||||
check2 chk con a b t = do
|
check2 chk con a b t = do
|
||||||
@@ -707,8 +705,7 @@ checkEqLType env t u trm = do
|
|||||||
sTypes = [typeStr, typeTok, typeString]
|
sTypes = [typeStr, typeTok, typeString]
|
||||||
comp = computeLType env
|
comp = computeLType env
|
||||||
|
|
||||||
-- linearization types and defaults
|
-- | linearization types and defaults
|
||||||
|
|
||||||
linTypeOfType :: SourceGrammar -> Ident -> Type -> Check (Context,Type)
|
linTypeOfType :: SourceGrammar -> Ident -> Type -> Check (Context,Type)
|
||||||
linTypeOfType cnc m typ = do
|
linTypeOfType cnc m typ = do
|
||||||
(cont,cat) <- checkErr $ typeSkeleton typ
|
(cont,cat) <- checkErr $ typeSkeleton typ
|
||||||
|
|||||||
@@ -49,12 +49,10 @@ import Arch
|
|||||||
|
|
||||||
import Monad
|
import Monad
|
||||||
|
|
||||||
-- environment variable for grammar search path
|
-- | environment variable for grammar search path
|
||||||
|
|
||||||
gfGrammarPathVar = "GF_LIB_PATH"
|
gfGrammarPathVar = "GF_LIB_PATH"
|
||||||
|
|
||||||
-- in batch mode: write code in a file
|
-- | in batch mode: write code in a file
|
||||||
|
|
||||||
batchCompile f = liftM fst $ compileModule defOpts emptyShellState f
|
batchCompile f = liftM fst $ compileModule defOpts emptyShellState f
|
||||||
where
|
where
|
||||||
defOpts = options [beVerbose, emitCode]
|
defOpts = options [beVerbose, emitCode]
|
||||||
@@ -66,11 +64,10 @@ batchCompileOld f = compileOld defOpts f
|
|||||||
where
|
where
|
||||||
defOpts = options [beVerbose, emitCode]
|
defOpts = options [beVerbose, emitCode]
|
||||||
|
|
||||||
-- compile with one module as starting point
|
-- | compile with one module as starting point
|
||||||
-- command-line options override options (marked by --#) in the file
|
-- 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.
|
-- 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.
|
-- If from command line, it is used as it is.
|
||||||
|
|
||||||
compileModule :: Options -> ShellState -> FilePath -> IOE TimedCompileEnv
|
compileModule :: Options -> ShellState -> FilePath -> IOE TimedCompileEnv
|
||||||
---- IOE (GFC.CanonGrammar, (SourceGrammar,[(FilePath,ModTime)]))
|
---- IOE (GFC.CanonGrammar, (SourceGrammar,[(FilePath,ModTime)]))
|
||||||
|
|
||||||
@@ -147,8 +144,7 @@ keepResModules opts gr =
|
|||||||
else emptyMGrammar
|
else emptyMGrammar
|
||||||
|
|
||||||
|
|
||||||
-- the environment
|
-- | the environment
|
||||||
|
|
||||||
type CompileEnv = (Int,SourceGrammar, GFC.CanonGrammar)
|
type CompileEnv = (Int,SourceGrammar, GFC.CanonGrammar)
|
||||||
|
|
||||||
emptyCompileEnv :: TimedCompileEnv
|
emptyCompileEnv :: TimedCompileEnv
|
||||||
@@ -211,8 +207,7 @@ compileOne opts env@((_,srcgr,_),_) file = do
|
|||||||
|
|
||||||
extendCompileEnvInt env (k',sm',cm) ft
|
extendCompileEnvInt env (k',sm',cm) ft
|
||||||
|
|
||||||
-- dispatch reused resource at early stage
|
-- | dispatch reused resource at early stage
|
||||||
|
|
||||||
makeSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule)
|
makeSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule)
|
||||||
makeSourceModule opts env@(k,gr,can) mo@(i,mi) = case mi of
|
makeSourceModule opts env@(k,gr,can) mo@(i,mi) = case mi of
|
||||||
|
|
||||||
|
|||||||
@@ -9,7 +9,10 @@
|
|||||||
-- > CVS $Author $
|
-- > CVS $Author $
|
||||||
-- > CVS $Revision $
|
-- > CVS $Revision $
|
||||||
--
|
--
|
||||||
-- (Description of the module)
|
-- AR 14\/5\/2003 -- 11\/11
|
||||||
|
--
|
||||||
|
-- The top-level function 'extendModule'
|
||||||
|
-- extends a module symbol table by indirections to the module it extends
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
|
|
||||||
module Extend where
|
module Extend where
|
||||||
@@ -24,11 +27,6 @@ import Operations
|
|||||||
|
|
||||||
import Monad
|
import Monad
|
||||||
|
|
||||||
-- AR 14/5/2003 -- 11/11
|
|
||||||
|
|
||||||
-- The top-level function $extendModule$
|
|
||||||
-- extends a module symbol table by indirections to the module it extends
|
|
||||||
|
|
||||||
extendModule :: [SourceModule] -> SourceModule -> Err SourceModule
|
extendModule :: [SourceModule] -> SourceModule -> Err SourceModule
|
||||||
extendModule ms (name,mod) = case mod of
|
extendModule ms (name,mod) = case mod of
|
||||||
|
|
||||||
@@ -58,10 +56,9 @@ extendModule ms (name,mod) = case mod of
|
|||||||
let me' = if isCompl then es else (filter (/=n) es)
|
let me' = if isCompl then es else (filter (/=n) es)
|
||||||
return $ Module mt st fs me' ops js1
|
return $ Module mt st fs me' ops js1
|
||||||
|
|
||||||
-- When extending a complete module: new information is inserted,
|
-- | When extending a complete module: new information is inserted,
|
||||||
-- and the process is interrupted if unification fails.
|
-- and the process is interrupted if unification fails.
|
||||||
-- If the extended module is incomplete, its judgements are just copied.
|
-- If the extended module is incomplete, its judgements are just copied.
|
||||||
|
|
||||||
extendMod :: Bool -> Ident -> Ident -> BinTree (Ident,Info) -> BinTree (Ident,Info) ->
|
extendMod :: Bool -> Ident -> Ident -> BinTree (Ident,Info) -> BinTree (Ident,Info) ->
|
||||||
Err (BinTree (Ident,Info))
|
Err (BinTree (Ident,Info))
|
||||||
extendMod isCompl name base old new = foldM try new $ tree2list old where
|
extendMod isCompl name base old new = foldM try new $ tree2list old where
|
||||||
|
|||||||
@@ -9,7 +9,7 @@
|
|||||||
-- > CVS $Author $
|
-- > CVS $Author $
|
||||||
-- > CVS $Revision $
|
-- > CVS $Revision $
|
||||||
--
|
--
|
||||||
-- (Description of the module)
|
-- this module builds the internal GF grammar that is sent to the type checker
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
|
|
||||||
module GetGrammar where
|
module GetGrammar where
|
||||||
@@ -40,8 +40,6 @@ import Char (toUpper)
|
|||||||
import List (nub)
|
import List (nub)
|
||||||
import Monad (foldM)
|
import Monad (foldM)
|
||||||
|
|
||||||
-- this module builds the internal GF grammar that is sent to the type checker
|
|
||||||
|
|
||||||
getSourceModule :: FilePath -> IOE SourceModule
|
getSourceModule :: FilePath -> IOE SourceModule
|
||||||
getSourceModule file = do
|
getSourceModule file = do
|
||||||
string <- readFileIOE file
|
string <- readFileIOE file
|
||||||
@@ -90,10 +88,9 @@ err2err (E.Bad s) = Bad s
|
|||||||
|
|
||||||
ioeEErr = ioeErr . err2err
|
ioeEErr = ioeErr . err2err
|
||||||
|
|
||||||
-- To resolve the new reserved words:
|
-- | To resolve the new reserved words:
|
||||||
-- change them by turning the final letter to upper case.
|
-- change them by turning the final letter to upper case.
|
||||||
--- There is a risk of clash.
|
--- There is a risk of clash.
|
||||||
|
|
||||||
oldLexer :: String -> [L.Token]
|
oldLexer :: String -> [L.Token]
|
||||||
oldLexer = map change . L.tokens where
|
oldLexer = map change . L.tokens where
|
||||||
change t = case t of
|
change t = case t of
|
||||||
|
|||||||
@@ -32,15 +32,12 @@ import Monad
|
|||||||
|
|
||||||
-- compilation of optimized grammars to canonical GF. AR 5/10/2001 -- 12/5/2003
|
-- compilation of optimized grammars to canonical GF. AR 5/10/2001 -- 12/5/2003
|
||||||
|
|
||||||
-- This is the top-level function printing a gfc file
|
-- | This is the top-level function printing a gfc file
|
||||||
|
|
||||||
showGFC :: SourceGrammar -> String
|
showGFC :: SourceGrammar -> String
|
||||||
showGFC = err id id . liftM (P.printTree . grammar2canon) . redGrammar
|
showGFC = err id id . liftM (P.printTree . grammar2canon) . redGrammar
|
||||||
|
|
||||||
-- any grammar, first trying without dependent types
|
-- | any grammar, first trying without dependent types
|
||||||
|
|
||||||
-- abstract syntax without dependent types
|
-- abstract syntax without dependent types
|
||||||
|
|
||||||
redGrammar :: SourceGrammar -> Err C.CanonGrammar
|
redGrammar :: SourceGrammar -> Err C.CanonGrammar
|
||||||
redGrammar (MGrammar gr) = liftM MGrammar $ mapM redModInfo $ filter active gr where
|
redGrammar (MGrammar gr) = liftM MGrammar $ mapM redModInfo $ filter active gr where
|
||||||
active (_,m) = case typeOfModule m of
|
active (_,m) = case typeOfModule m of
|
||||||
|
|||||||
@@ -25,9 +25,8 @@ import Operations
|
|||||||
|
|
||||||
import Monad
|
import Monad
|
||||||
|
|
||||||
-- extracting resource r from abstract + concrete syntax
|
-- | extracting resource r from abstract + concrete syntax.
|
||||||
-- AR 21/8/2002 -- 22/6/2003 for GF with modules
|
-- AR 21\/8\/2002 -- 22\/6\/2003 for GF with modules
|
||||||
|
|
||||||
makeReuse :: SourceGrammar -> Ident -> [Ident] ->
|
makeReuse :: SourceGrammar -> Ident -> [Ident] ->
|
||||||
MReuseType Ident -> Err SourceRes
|
MReuseType Ident -> Err SourceRes
|
||||||
makeReuse gr r me mrc = do
|
makeReuse gr r me mrc = do
|
||||||
@@ -70,9 +69,8 @@ makeReuse gr r me mrc = do
|
|||||||
_ -> prtBad "expected concrete to be the type of" c
|
_ -> prtBad "expected concrete to be the type of" c
|
||||||
|
|
||||||
|
|
||||||
-- the first Boolean indicates if the type needs be given
|
-- | the first Boolean indicates if the type needs be given
|
||||||
-- the second Boolean indicates if the definition needs be given
|
-- the second Boolean indicates if the definition needs be given
|
||||||
|
|
||||||
mkResDefs :: Bool -> Bool ->
|
mkResDefs :: Bool -> Bool ->
|
||||||
SourceGrammar -> Ident -> Ident -> [Ident] -> [Ident] ->
|
SourceGrammar -> Ident -> Ident -> [Ident] -> [Ident] ->
|
||||||
BinTree (Ident,Info) -> BinTree (Ident,Info) ->
|
BinTree (Ident,Info) -> BinTree (Ident,Info) ->
|
||||||
@@ -119,8 +117,7 @@ mkResDefs hasT isC gr r a mext maext abs cnc = mapMTree (mkOne a maext) abs wher
|
|||||||
Q n c | n == a || [n] == mae -> return $ Q r c ---- FIX for non-singleton exts
|
Q n c | n == a || [n] == mae -> return $ Q r c ---- FIX for non-singleton exts
|
||||||
_ -> composOp (redirTyp always a mae) ty
|
_ -> composOp (redirTyp always a mae) ty
|
||||||
|
|
||||||
-- no reuse for functions of HO/dep types
|
-- | no reuse for functions of HO\/dep types
|
||||||
|
|
||||||
isHardType t = case t of
|
isHardType t = case t of
|
||||||
Prod x a b -> not (isWild x) || isHardType a || isHardType b
|
Prod x a b -> not (isWild x) || isHardType a || isHardType b
|
||||||
App _ _ -> True
|
App _ _ -> True
|
||||||
|
|||||||
@@ -9,7 +9,8 @@
|
|||||||
-- > CVS $Author $
|
-- > CVS $Author $
|
||||||
-- > CVS $Revision $
|
-- > CVS $Revision $
|
||||||
--
|
--
|
||||||
-- (Description of the module)
|
-- building union of modules.
|
||||||
|
-- AR 1\/3\/2004 --- OBSOLETE 15\/9\/2004 with multiple inheritance
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
|
|
||||||
module MkUnion (makeUnion) where
|
module MkUnion (makeUnion) where
|
||||||
@@ -26,9 +27,6 @@ import Option
|
|||||||
import List
|
import List
|
||||||
import Monad
|
import Monad
|
||||||
|
|
||||||
-- building union of modules
|
|
||||||
-- AR 1/3/2004 --- OBSOLETE 15/9/2004 with multiple inheritance
|
|
||||||
|
|
||||||
makeUnion :: SourceGrammar -> Ident -> ModuleType Ident -> [(Ident,[Ident])] ->
|
makeUnion :: SourceGrammar -> Ident -> ModuleType Ident -> [(Ident,[Ident])] ->
|
||||||
Err SourceModule
|
Err SourceModule
|
||||||
makeUnion gr m ty imps = do
|
makeUnion gr m ty imps = do
|
||||||
|
|||||||
@@ -10,6 +10,8 @@
|
|||||||
-- > CVS $Revision $
|
-- > CVS $Revision $
|
||||||
--
|
--
|
||||||
-- Check correctness of module dependencies. Incomplete.
|
-- Check correctness of module dependencies. Incomplete.
|
||||||
|
--
|
||||||
|
-- AR 13/5/2003
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
|
|
||||||
module ModDeps where
|
module ModDeps where
|
||||||
@@ -27,12 +29,9 @@ import Operations
|
|||||||
import Monad
|
import Monad
|
||||||
import List
|
import List
|
||||||
|
|
||||||
-- AR 13/5/2003
|
-- | to check uniqueness of module names and import names, the
|
||||||
|
|
||||||
-- to check uniqueness of module names and import names, the
|
|
||||||
-- appropriateness of import and extend types,
|
-- appropriateness of import and extend types,
|
||||||
-- to build a dependency graph of modules, and to sort them topologically
|
-- to build a dependency graph of modules, and to sort them topologically
|
||||||
|
|
||||||
mkSourceGrammar :: [(Ident,SourceModInfo)] -> Err SourceGrammar
|
mkSourceGrammar :: [(Ident,SourceModInfo)] -> Err SourceGrammar
|
||||||
mkSourceGrammar ms = do
|
mkSourceGrammar ms = do
|
||||||
let ns = map fst ms
|
let ns = map fst ms
|
||||||
@@ -50,8 +49,7 @@ checkUniqueErr ms = do
|
|||||||
let msg = checkUnique ms
|
let msg = checkUnique ms
|
||||||
if null msg then return () else Bad $ unlines msg
|
if null msg then return () else Bad $ unlines msg
|
||||||
|
|
||||||
-- check that import names don't clash with module names
|
-- | check that import names don't clash with module names
|
||||||
|
|
||||||
checkUniqueImportNames :: [Ident] -> SourceModInfo -> Err ()
|
checkUniqueImportNames :: [Ident] -> SourceModInfo -> Err ()
|
||||||
checkUniqueImportNames ns mo = case mo of
|
checkUniqueImportNames ns mo = case mo of
|
||||||
ModMod m -> test [n | OQualif _ n v <- opens m, n /= v]
|
ModMod m -> test [n | OQualif _ n v <- opens m, n /= v]
|
||||||
@@ -62,11 +60,10 @@ checkUniqueImportNames ns mo = case mo of
|
|||||||
("import names clashing with module names among" +++
|
("import names clashing with module names among" +++
|
||||||
unwords (map prt ms))
|
unwords (map prt ms))
|
||||||
|
|
||||||
-- to decide what modules immediately depend on what, and check if the
|
|
||||||
-- dependencies are appropriate
|
|
||||||
|
|
||||||
type Dependencies = [(IdentM Ident,[IdentM Ident])]
|
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 :: [(Ident,SourceModInfo)] -> Err Dependencies
|
||||||
moduleDeps ms = mapM deps ms where
|
moduleDeps ms = mapM deps ms where
|
||||||
deps (c,mi) = errIn ("checking dependencies of module" +++ prt c) $ case mi of
|
deps (c,mi) = errIn ("checking dependencies of module" +++ prt c) $ case mi of
|
||||||
@@ -119,9 +116,8 @@ openInterfaces ds m = do
|
|||||||
let mods = iterFix (concatMap more) (more (m,undefined))
|
let mods = iterFix (concatMap more) (more (m,undefined))
|
||||||
return $ [i | (i,MTInterface) <- mods]
|
return $ [i | (i,MTInterface) <- mods]
|
||||||
|
|
||||||
-- this function finds out what modules are really needed in the canoncal gr.
|
-- | this function finds out what modules are really needed in the canoncal gr.
|
||||||
-- its argument is typically a concrete module name
|
-- its argument is typically a concrete module name
|
||||||
|
|
||||||
requiredCanModules :: (Eq i, Show i) => MGrammar i f a -> i -> [i]
|
requiredCanModules :: (Eq i, Show i) => MGrammar i f a -> i -> [i]
|
||||||
requiredCanModules gr = nub . iterFix (concatMap more) . singleton where
|
requiredCanModules gr = nub . iterFix (concatMap more) . singleton where
|
||||||
more i = errVal [] $ do
|
more i = errVal [] $ do
|
||||||
|
|||||||
@@ -9,7 +9,18 @@
|
|||||||
-- > CVS $Author $
|
-- > CVS $Author $
|
||||||
-- > CVS $Revision $
|
-- > CVS $Revision $
|
||||||
--
|
--
|
||||||
-- (Description of the module)
|
-- AR 14/5/2003
|
||||||
|
--
|
||||||
|
-- The top-level function 'renameGrammar' does several things:
|
||||||
|
--
|
||||||
|
-- - extends each module symbol table by indirections to extended module
|
||||||
|
--
|
||||||
|
-- - changes unqualified and as-qualified imports to absolutely qualified
|
||||||
|
--
|
||||||
|
-- - goes through the definitions and resolves names
|
||||||
|
--
|
||||||
|
-- Dependency analysis between modules has been performed before this pass.
|
||||||
|
-- Hence we can proceed by @fold@ing "from left to right".
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
|
|
||||||
module Rename where
|
module Rename where
|
||||||
@@ -27,23 +38,14 @@ import Operations
|
|||||||
|
|
||||||
import Monad
|
import Monad
|
||||||
|
|
||||||
-- AR 14/5/2003
|
-- | this gives top-level access to renaming term input in the cc command
|
||||||
|
|
||||||
-- The top-level function $renameGrammar$ does several things:
|
|
||||||
-- * extends each module symbol table by indirections to extended module
|
|
||||||
-- * changes unqualified and as-qualified imports to absolutely qualified
|
|
||||||
-- * goes through the definitions and resolves names
|
|
||||||
-- Dependency analysis between modules has been performed before this pass.
|
|
||||||
-- Hence we can proceed by $fold$ing 'from left to right'.
|
|
||||||
|
|
||||||
-- this gives top-level access to renaming term input in the cc command
|
|
||||||
renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term
|
renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term
|
||||||
renameSourceTerm g m t = do
|
renameSourceTerm g m t = do
|
||||||
mo <- lookupErr m (modules g)
|
mo <- lookupErr m (modules g)
|
||||||
let status = (modules g,(m,mo)) --- <- buildStatus g m mo
|
let status = (modules g,(m,mo)) --- <- buildStatus g m mo
|
||||||
renameTerm status [] t
|
renameTerm status [] t
|
||||||
|
|
||||||
-- this is used in the compiler, separately for each module
|
-- | this is used in the compiler, separately for each module
|
||||||
renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule]
|
renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule]
|
||||||
renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of
|
renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of
|
||||||
ModMod m@(Module mt st fs me ops js) -> do
|
ModMod m@(Module mt st fs me ops js) -> do
|
||||||
@@ -114,7 +116,7 @@ renameIdentTerm env@(imps,act@(_,ModMod this)) t =
|
|||||||
IC "String" -> return $ Q cPredefAbs cString
|
IC "String" -> return $ Q cPredefAbs cString
|
||||||
_ -> Bad s
|
_ -> Bad s
|
||||||
|
|
||||||
--- would it make sense to optimize this by inlining?
|
-- | would it make sense to optimize this by inlining?
|
||||||
renameIdentPatt :: Status -> Patt -> Err Patt
|
renameIdentPatt :: Status -> Patt -> Err Patt
|
||||||
renameIdentPatt env p = do
|
renameIdentPatt env p = do
|
||||||
let t = patt2term p
|
let t = patt2term p
|
||||||
@@ -233,8 +235,7 @@ renameTerm env vars = ren vars where
|
|||||||
return (p',t')
|
return (p',t')
|
||||||
renpatt = renamePattern env
|
renpatt = renamePattern env
|
||||||
|
|
||||||
-- vars not needed in env, since patterns always overshadow old vars
|
-- | vars not needed in env, since patterns always overshadow old vars
|
||||||
|
|
||||||
renamePattern :: Status -> Patt -> Err (Patt,[Ident])
|
renamePattern :: Status -> Patt -> Err (Patt,[Ident])
|
||||||
renamePattern env patt = case patt of
|
renamePattern env patt = case patt of
|
||||||
|
|
||||||
@@ -286,8 +287,7 @@ renameContext b = renc [] where
|
|||||||
_ -> return cont
|
_ -> return cont
|
||||||
ren = renameTerm b
|
ren = renameTerm b
|
||||||
|
|
||||||
-- vars not needed in env, since patterns always overshadow old vars
|
-- | vars not needed in env, since patterns always overshadow old vars
|
||||||
|
|
||||||
renameEquation :: Status -> [Ident] -> Equation -> Err Equation
|
renameEquation :: Status -> [Ident] -> Equation -> Err Equation
|
||||||
renameEquation b vs (ps,t) = do
|
renameEquation b vs (ps,t) = do
|
||||||
(ps',vs') <- liftM unzip $ mapM (renamePattern b) ps
|
(ps',vs') <- liftM unzip $ mapM (renamePattern b) ps
|
||||||
|
|||||||
@@ -33,9 +33,8 @@ import Option
|
|||||||
import Monad
|
import Monad
|
||||||
import List
|
import List
|
||||||
|
|
||||||
-- partial evaluation of concrete syntax. AR 6/2001 -- 16/5/2003 -- 5/2/2005
|
-- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
|
||||||
-- only do this for resource: concrete is optimized in gfc form
|
-- only do this for resource: concrete is optimized in gfc form
|
||||||
|
|
||||||
optimizeModule :: Options -> [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) ->
|
optimizeModule :: Options -> [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) ->
|
||||||
Err (Ident,SourceModInfo)
|
Err (Ident,SourceModInfo)
|
||||||
optimizeModule opts ms mo@(_,mi) = case mi of
|
optimizeModule opts ms mo@(_,mi) = case mi of
|
||||||
@@ -77,9 +76,8 @@ evalModule ms mo@(name,mod) = case mod of
|
|||||||
info' <- evalResInfo gr (i,info)
|
info' <- evalResInfo gr (i,info)
|
||||||
return $ updateRes g name i info'
|
return $ updateRes g name i info'
|
||||||
|
|
||||||
-- only operations need be compiled in a resource, and this is local to each
|
-- | only operations need be compiled in a resource, and this is local to each
|
||||||
-- definition since the module is traversed in topological order
|
-- definition since the module is traversed in topological order
|
||||||
|
|
||||||
evalResInfo :: SourceGrammar -> (Ident,Info) -> Err Info
|
evalResInfo :: SourceGrammar -> (Ident,Info) -> Err Info
|
||||||
evalResInfo gr (c,info) = case info of
|
evalResInfo gr (c,info) = case info of
|
||||||
|
|
||||||
@@ -129,8 +127,7 @@ evalCncInfo gr cnc abs (c,info) = case info of
|
|||||||
pEval = partEval gr
|
pEval = partEval gr
|
||||||
eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
|
eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
|
||||||
|
|
||||||
-- the main function for compiling linearizations
|
-- | the main function for compiling linearizations
|
||||||
|
|
||||||
partEval :: SourceGrammar -> (Context,Type) -> Term -> Err Term
|
partEval :: SourceGrammar -> (Context,Type) -> Term -> Err Term
|
||||||
partEval gr (context, val) trm = do
|
partEval gr (context, val) trm = do
|
||||||
let vars = map fst context
|
let vars = map fst context
|
||||||
@@ -159,8 +156,7 @@ recordExpand typ trm = case unComputed typ of
|
|||||||
_ -> return trm
|
_ -> return trm
|
||||||
|
|
||||||
|
|
||||||
-- auxiliaries for compiling the resource
|
-- | auxiliaries for compiling the resource
|
||||||
|
|
||||||
allOperDependencies :: Ident -> BinTree (Ident,Info) -> [(Ident,[Ident])]
|
allOperDependencies :: Ident -> BinTree (Ident,Info) -> [(Ident,[Ident])]
|
||||||
allOperDependencies m b =
|
allOperDependencies m b =
|
||||||
[(f, nub (opty pty ++ opty pt)) | (f, ResOper pty pt) <- tree2list b]
|
[(f, nub (opty pty ++ opty pt)) | (f, ResOper pty pt) <- tree2list b]
|
||||||
@@ -196,11 +192,10 @@ mkLinDefault gr typ = do
|
|||||||
_ | isTypeInts typ -> return $ EInt 0 -- exists in all as first val
|
_ | isTypeInts typ -> return $ EInt 0 -- exists in all as first val
|
||||||
_ -> prtBad "linearization type field cannot be" typ
|
_ -> prtBad "linearization type field cannot be" typ
|
||||||
|
|
||||||
-- Form the printname: if given, compute. If not, use the computed
|
-- | Form the printname: if given, compute. If not, use the computed
|
||||||
-- lin for functions, cat name for cats (dispatch made in evalCncDef above).
|
-- 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
|
--- 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.
|
--- defaults we would need for question marks - and we're not yet in canon.
|
||||||
|
|
||||||
evalPrintname :: SourceGrammar -> Ident -> MPr -> Perh Term -> Err Term
|
evalPrintname :: SourceGrammar -> Ident -> MPr -> Perh Term -> Err Term
|
||||||
evalPrintname gr c ppr lin =
|
evalPrintname gr c ppr lin =
|
||||||
case ppr of
|
case ppr of
|
||||||
|
|||||||
@@ -25,9 +25,8 @@ import Ident
|
|||||||
import Modules
|
import Modules
|
||||||
import Operations
|
import Operations
|
||||||
|
|
||||||
-- rebuilding instance + interface, and "with" modules, prior to renaming.
|
-- | rebuilding instance + interface, and "with" modules, prior to renaming.
|
||||||
-- AR 24/10/2003
|
-- AR 24/10/2003
|
||||||
|
|
||||||
rebuildModule :: [SourceModule] -> SourceModule -> Err SourceModule
|
rebuildModule :: [SourceModule] -> SourceModule -> Err SourceModule
|
||||||
rebuildModule ms mo@(i,mi) = do
|
rebuildModule ms mo@(i,mi) = do
|
||||||
let gr = MGrammar ms
|
let gr = MGrammar ms
|
||||||
|
|||||||
@@ -9,7 +9,11 @@
|
|||||||
-- > CVS $Author $
|
-- > CVS $Author $
|
||||||
-- > CVS $Revision $
|
-- > CVS $Revision $
|
||||||
--
|
--
|
||||||
-- (Description of the module)
|
-- remove obsolete (Lin C) expressions before doing anything else. AR 21/6/2003
|
||||||
|
--
|
||||||
|
-- What the program does is replace the occurrences of Lin C with the actual
|
||||||
|
-- definition T given in lincat C = T ; with {s : Str} if no lincat is found.
|
||||||
|
-- The procedule is uncertain, if T contains another Lin.
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
|
|
||||||
module RemoveLiT (removeLiT) where
|
module RemoveLiT (removeLiT) where
|
||||||
@@ -24,12 +28,6 @@ import Operations
|
|||||||
|
|
||||||
import Monad
|
import Monad
|
||||||
|
|
||||||
-- remove obsolete (Lin C) expressions before doing anything else. AR 21/6/2003
|
|
||||||
|
|
||||||
-- What the program does is replace the occurrences of Lin C with the actual
|
|
||||||
-- definition T given in lincat C = T ; with {s : Str} if no lincat is found.
|
|
||||||
-- The procedule is uncertain, if T contains another Lin.
|
|
||||||
|
|
||||||
removeLiT :: SourceGrammar -> Err SourceGrammar
|
removeLiT :: SourceGrammar -> Err SourceGrammar
|
||||||
removeLiT gr = liftM MGrammar $ mapM (remlModule gr) (modules gr)
|
removeLiT gr = liftM MGrammar $ mapM (remlModule gr) (modules gr)
|
||||||
|
|
||||||
|
|||||||
@@ -9,7 +9,17 @@
|
|||||||
-- > CVS $Author $
|
-- > CVS $Author $
|
||||||
-- > CVS $Revision $
|
-- > CVS $Revision $
|
||||||
--
|
--
|
||||||
-- (Description of the module)
|
-- AR 14/5/2003
|
||||||
|
-- The top-level function 'renameGrammar' does several things:
|
||||||
|
--
|
||||||
|
-- - extends each module symbol table by indirections to extended module
|
||||||
|
--
|
||||||
|
-- - changes unqualified and as-qualified imports to absolutely qualified
|
||||||
|
--
|
||||||
|
-- - goes through the definitions and resolves names
|
||||||
|
--
|
||||||
|
-- Dependency analysis between modules has been performed before this pass.
|
||||||
|
-- Hence we can proceed by @fold@ing "from left to right".
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
|
|
||||||
module Rename where
|
module Rename where
|
||||||
@@ -27,19 +37,10 @@ import Operations
|
|||||||
|
|
||||||
import Monad
|
import Monad
|
||||||
|
|
||||||
-- AR 14/5/2003
|
|
||||||
|
|
||||||
-- The top-level function $renameGrammar$ does several things:
|
|
||||||
-- * extends each module symbol table by indirections to extended module
|
|
||||||
-- * changes unqualified and as-qualified imports to absolutely qualified
|
|
||||||
-- * goes through the definitions and resolves names
|
|
||||||
-- Dependency analysis between modules has been performed before this pass.
|
|
||||||
-- Hence we can proceed by $fold$ing 'from left to right'.
|
|
||||||
|
|
||||||
renameGrammar :: SourceGrammar -> Err SourceGrammar
|
renameGrammar :: SourceGrammar -> Err SourceGrammar
|
||||||
renameGrammar g = liftM (MGrammar . reverse) $ foldM renameModule [] (modules g)
|
renameGrammar g = liftM (MGrammar . reverse) $ foldM renameModule [] (modules g)
|
||||||
|
|
||||||
-- this gives top-level access to renaming term input in the cc command
|
-- | this gives top-level access to renaming term input in the cc command
|
||||||
renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term
|
renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term
|
||||||
renameSourceTerm g m t = do
|
renameSourceTerm g m t = do
|
||||||
mo <- lookupErr m (modules g)
|
mo <- lookupErr m (modules g)
|
||||||
@@ -93,7 +94,7 @@ renameIdentTerm env@(act,imps) t =
|
|||||||
IC "String" -> return $ const $ Q cPredefAbs cString
|
IC "String" -> return $ const $ Q cPredefAbs cString
|
||||||
_ -> Bad s
|
_ -> Bad s
|
||||||
|
|
||||||
--- would it make sense to optimize this by inlining?
|
--- | would it make sense to optimize this by inlining?
|
||||||
renameIdentPatt :: Status -> Patt -> Err Patt
|
renameIdentPatt :: Status -> Patt -> Err Patt
|
||||||
renameIdentPatt env p = do
|
renameIdentPatt env p = do
|
||||||
let t = patt2term p
|
let t = patt2term p
|
||||||
@@ -210,8 +211,7 @@ renameTerm env vars = ren vars where
|
|||||||
return (p',t')
|
return (p',t')
|
||||||
renpatt = renamePattern env
|
renpatt = renamePattern env
|
||||||
|
|
||||||
-- vars not needed in env, since patterns always overshadow old vars
|
-- | vars not needed in env, since patterns always overshadow old vars
|
||||||
|
|
||||||
renamePattern :: Status -> Patt -> Err (Patt,[Ident])
|
renamePattern :: Status -> Patt -> Err (Patt,[Ident])
|
||||||
renamePattern env patt = case patt of
|
renamePattern env patt = case patt of
|
||||||
|
|
||||||
@@ -263,8 +263,7 @@ renameContext b = renc [] where
|
|||||||
_ -> return cont
|
_ -> return cont
|
||||||
ren = renameTerm b
|
ren = renameTerm b
|
||||||
|
|
||||||
-- vars not needed in env, since patterns always overshadow old vars
|
-- | vars not needed in env, since patterns always overshadow old vars
|
||||||
|
|
||||||
renameEquation :: Status -> [Ident] -> Equation -> Err Equation
|
renameEquation :: Status -> [Ident] -> Equation -> Err Equation
|
||||||
renameEquation b vs (ps,t) = do
|
renameEquation b vs (ps,t) = do
|
||||||
(ps',vs') <- liftM unzip $ mapM (renamePattern b) ps
|
(ps',vs') <- liftM unzip $ mapM (renamePattern b) ps
|
||||||
|
|||||||
@@ -42,27 +42,29 @@ import List (nub,nubBy)
|
|||||||
|
|
||||||
-- AR 11/11/2001 -- 17/6/2003 (for modules) ---- unfinished
|
-- AR 11/11/2001 -- 17/6/2003 (for modules) ---- unfinished
|
||||||
|
|
||||||
-- multilingual state with grammars and options
|
-- | multilingual state with grammars and options
|
||||||
data ShellState = ShSt {
|
data ShellState = ShSt {
|
||||||
abstract :: Maybe Ident , -- pointer to actual abstract, if not empty st
|
abstract :: Maybe Ident , -- ^ pointer to actual abstract, if not empty st
|
||||||
concrete :: Maybe Ident , -- pointer to primary concrete
|
concrete :: Maybe Ident , -- ^ pointer to primary concrete
|
||||||
concretes :: [((Ident,Ident),Bool)], -- list of all concretes, and whether active
|
concretes :: [((Ident,Ident),Bool)], -- ^ list of all concretes, and whether active
|
||||||
canModules :: CanonGrammar , -- compiled abstracts and concretes
|
canModules :: CanonGrammar , -- ^ compiled abstracts and concretes
|
||||||
srcModules :: G.SourceGrammar , -- saved resource modules
|
srcModules :: G.SourceGrammar , -- ^ saved resource modules
|
||||||
cfs :: [(Ident,CF)] , -- context-free grammars
|
cfs :: [(Ident,CF)] , -- ^ context-free grammars
|
||||||
pInfos :: [(Ident,Cnv.PInfo)], -- peb 18/6
|
pInfos :: [(Ident,Cnv.PInfo)], -- ^ parser information, peb 18\/6
|
||||||
morphos :: [(Ident,Morpho)], -- morphologies
|
morphos :: [(Ident,Morpho)], -- ^ morphologies
|
||||||
gloptions :: Options, -- global options
|
gloptions :: Options, -- ^ global options
|
||||||
readFiles :: [(FilePath,ModTime)],-- files read
|
readFiles :: [(FilePath,ModTime)],-- ^ files read
|
||||||
absCats :: [(G.Cat,(G.Context, -- cats, their contexts,
|
absCats :: [(G.Cat,(G.Context,
|
||||||
[(G.Fun,G.Type)], -- functions to them,
|
[(G.Fun,G.Type)],
|
||||||
[((G.Fun,Int),G.Type)]))], -- functions on them
|
[((G.Fun,Int),G.Type)]))], -- ^ cats, (their contexts,
|
||||||
statistics :: [Statistics] -- statistics on grammars
|
-- functions to them,
|
||||||
|
-- functions on them)
|
||||||
|
statistics :: [Statistics] -- ^ statistics on grammars
|
||||||
}
|
}
|
||||||
|
|
||||||
data Statistics =
|
data Statistics =
|
||||||
StDepTypes Bool -- whether there are dependent types
|
StDepTypes Bool -- ^ whether there are dependent types
|
||||||
| StBoundVars [G.Cat] -- which categories have bound variables
|
| StBoundVars [G.Cat] -- ^ which categories have bound variables
|
||||||
--- -- etc
|
--- -- etc
|
||||||
deriving (Eq,Ord)
|
deriving (Eq,Ord)
|
||||||
|
|
||||||
@@ -87,8 +89,7 @@ type Language = Ident
|
|||||||
language = identC
|
language = identC
|
||||||
prLanguage = prIdent
|
prLanguage = prIdent
|
||||||
|
|
||||||
-- grammar for one language in a state, comprising its abs and cnc
|
-- | grammar for one language in a state, comprising its abs and cnc
|
||||||
|
|
||||||
data StateGrammar = StGr {
|
data StateGrammar = StGr {
|
||||||
absId :: Ident,
|
absId :: Ident,
|
||||||
cncId :: Ident,
|
cncId :: Ident,
|
||||||
@@ -109,7 +110,7 @@ emptyStateGrammar = StGr {
|
|||||||
loptions = noOptions
|
loptions = noOptions
|
||||||
}
|
}
|
||||||
|
|
||||||
-- analysing shell grammar into parts
|
-- | analysing shell grammar into parts
|
||||||
stateGrammarST = grammar
|
stateGrammarST = grammar
|
||||||
stateCF = cf
|
stateCF = cf
|
||||||
statePInfo = pInfo
|
statePInfo = pInfo
|
||||||
@@ -119,14 +120,12 @@ stateGrammarWords = allMorphoWords . stateMorpho
|
|||||||
|
|
||||||
cncModuleIdST = stateGrammarST
|
cncModuleIdST = stateGrammarST
|
||||||
|
|
||||||
-- form a shell state from a canonical grammar
|
-- | form a shell state from a canonical grammar
|
||||||
|
|
||||||
grammar2shellState :: Options -> (CanonGrammar, G.SourceGrammar) -> Err ShellState
|
grammar2shellState :: Options -> (CanonGrammar, G.SourceGrammar) -> Err ShellState
|
||||||
grammar2shellState opts (gr,sgr) =
|
grammar2shellState opts (gr,sgr) =
|
||||||
updateShellState opts emptyShellState ((0,sgr,gr),[]) --- is 0 safe?
|
updateShellState opts emptyShellState ((0,sgr,gr),[]) --- is 0 safe?
|
||||||
|
|
||||||
-- update a shell state from a canonical grammar
|
-- | update a shell state from a canonical grammar
|
||||||
|
|
||||||
updateShellState :: Options -> ShellState ->
|
updateShellState :: Options -> ShellState ->
|
||||||
((Int,G.SourceGrammar,CanonGrammar),[(FilePath,ModTime)]) ->
|
((Int,G.SourceGrammar,CanonGrammar),[(FilePath,ModTime)]) ->
|
||||||
---- (CanonGrammar,(G.SourceGrammar,[(FilePath,ModTime)])) ->
|
---- (CanonGrammar,(G.SourceGrammar,[(FilePath,ModTime)])) ->
|
||||||
@@ -186,8 +185,7 @@ prShellStateInfo sh = unlines [
|
|||||||
|
|
||||||
abstractName sh = maybe "(none)" P.prt (abstract sh)
|
abstractName sh = maybe "(none)" P.prt (abstract sh)
|
||||||
|
|
||||||
-- throw away those abstracts that are not needed --- could be more aggressive
|
-- | throw away those abstracts that are not needed --- could be more aggressive
|
||||||
|
|
||||||
filterAbstracts :: Maybe Ident -> CanonGrammar -> CanonGrammar
|
filterAbstracts :: Maybe Ident -> CanonGrammar -> CanonGrammar
|
||||||
filterAbstracts abstr cgr = M.MGrammar (nubBy (\x y -> fst x == fst y) [m | m <- ms, needed m]) where
|
filterAbstracts abstr cgr = M.MGrammar (nubBy (\x y -> fst x == fst y) [m | m <- ms, needed m]) where
|
||||||
ms = M.modules cgr
|
ms = M.modules cgr
|
||||||
@@ -234,8 +232,7 @@ changeMain (Just c) st@(ShSt _ _ cs ms ss cfs pis mos os rs acs s) =
|
|||||||
return (ShSt (Just a) (Just c) cs' ms ss cfs pis mos os rs acs s)
|
return (ShSt (Just a) (Just c) cs' ms ss cfs pis mos os rs acs s)
|
||||||
_ -> P.prtBad "The state has no concrete syntax named" c
|
_ -> P.prtBad "The state has no concrete syntax named" c
|
||||||
|
|
||||||
-- form just one state grammar, if unique, from a canonical grammar
|
-- | form just one state grammar, if unique, from a canonical grammar
|
||||||
|
|
||||||
grammar2stateGrammar :: Options -> CanonGrammar -> Err StateGrammar
|
grammar2stateGrammar :: Options -> CanonGrammar -> Err StateGrammar
|
||||||
grammar2stateGrammar opts gr = do
|
grammar2stateGrammar opts gr = do
|
||||||
st <- grammar2shellState opts (gr,M.emptyMGrammar)
|
st <- grammar2shellState opts (gr,M.emptyMGrammar)
|
||||||
@@ -268,8 +265,7 @@ cfOfLang st = stateCF . stateGrammarOfLang st
|
|||||||
morphoOfLang st = stateMorpho . stateGrammarOfLang st
|
morphoOfLang st = stateMorpho . stateGrammarOfLang st
|
||||||
optionsOfLang st = stateOptions . stateGrammarOfLang st
|
optionsOfLang st = stateOptions . stateGrammarOfLang st
|
||||||
|
|
||||||
-- the last introduced grammar, stored in options, is the default for operations
|
-- | the last introduced grammar, stored in options, is the default for operations
|
||||||
|
|
||||||
firstStateGrammar :: ShellState -> StateGrammar
|
firstStateGrammar :: ShellState -> StateGrammar
|
||||||
firstStateGrammar st = errVal (stateAbstractGrammar st) $ do
|
firstStateGrammar st = errVal (stateAbstractGrammar st) $ do
|
||||||
concr <- maybeErr "no concrete syntax" $ concrete st
|
concr <- maybeErr "no concrete syntax" $ concrete st
|
||||||
@@ -290,7 +286,7 @@ stateAbstractGrammar st = StGr {
|
|||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
-- analysing shell state into parts
|
-- | analysing shell state into parts
|
||||||
globalOptions = gloptions
|
globalOptions = gloptions
|
||||||
allLanguages = map (fst . fst) . concretes
|
allLanguages = map (fst . fst) . concretes
|
||||||
allCategories = map fst . allCatsOf . canModules
|
allCategories = map fst . allCatsOf . canModules
|
||||||
@@ -325,17 +321,17 @@ languageOfOptState :: Options -> ShellState -> Maybe Language
|
|||||||
languageOfOptState opts st =
|
languageOfOptState opts st =
|
||||||
maybe (concrete st) (return . language) $ getOptVal opts useLanguage
|
maybe (concrete st) (return . language) $ getOptVal opts useLanguage
|
||||||
|
|
||||||
-- command-line option -cat=foo overrides the possible start cat of a grammar
|
-- | command-line option -cat=foo overrides the possible start cat of a grammar
|
||||||
firstCatOpts :: Options -> StateGrammar -> CFCat
|
firstCatOpts :: Options -> StateGrammar -> CFCat
|
||||||
firstCatOpts opts sgr =
|
firstCatOpts opts sgr =
|
||||||
maybe (stateFirstCat sgr) (string2CFCat (P.prt (absId sgr))) $
|
maybe (stateFirstCat sgr) (string2CFCat (P.prt (absId sgr))) $
|
||||||
getOptVal opts firstCat
|
getOptVal opts firstCat
|
||||||
|
|
||||||
-- the first cat for random generation
|
-- | the first cat for random generation
|
||||||
firstAbsCat :: Options -> StateGrammar -> G.QIdent
|
firstAbsCat :: Options -> StateGrammar -> G.QIdent
|
||||||
firstAbsCat opts = cfCat2Cat . firstCatOpts opts
|
firstAbsCat opts = cfCat2Cat . firstCatOpts opts
|
||||||
|
|
||||||
-- a grammar can have start category as option startcat=foo ; default is S
|
-- | a grammar can have start category as option startcat=foo ; default is S
|
||||||
stateFirstCat sgr =
|
stateFirstCat sgr =
|
||||||
maybe (string2CFCat a "S") (string2CFCat a) $
|
maybe (string2CFCat a "S") (string2CFCat a) $
|
||||||
getOptVal (stateOptions sgr) gStartCat
|
getOptVal (stateOptions sgr) gStartCat
|
||||||
|
|||||||
@@ -24,8 +24,7 @@ import Operations
|
|||||||
import List
|
import List
|
||||||
import Monad
|
import Monad
|
||||||
|
|
||||||
-- update a resource module by adding a new or changing an old definition
|
-- | update a resource module by adding a new or changing an old definition
|
||||||
|
|
||||||
updateRes :: SourceGrammar -> Ident -> Ident -> Info -> SourceGrammar
|
updateRes :: SourceGrammar -> Ident -> Ident -> Info -> SourceGrammar
|
||||||
updateRes gr@(MGrammar ms) m i info = MGrammar $ map upd ms where
|
updateRes gr@(MGrammar ms) m i info = MGrammar $ map upd ms where
|
||||||
upd (n,mod)
|
upd (n,mod)
|
||||||
@@ -34,16 +33,14 @@ updateRes gr@(MGrammar ms) m i info = MGrammar $ map upd ms where
|
|||||||
ModMod r -> (m,ModMod $ updateModule r i info)
|
ModMod r -> (m,ModMod $ updateModule r i info)
|
||||||
_ -> (n,mod) --- no error msg
|
_ -> (n,mod) --- no error msg
|
||||||
|
|
||||||
-- combine a list of definitions into a balanced binary search tree
|
-- | combine a list of definitions into a balanced binary search tree
|
||||||
|
|
||||||
buildAnyTree :: [(Ident,Info)] -> Err (BinTree (Ident, Info))
|
buildAnyTree :: [(Ident,Info)] -> Err (BinTree (Ident, Info))
|
||||||
buildAnyTree ias = do
|
buildAnyTree ias = do
|
||||||
ias' <- combineAnyInfos ias
|
ias' <- combineAnyInfos ias
|
||||||
return $ buildTree ias'
|
return $ buildTree ias'
|
||||||
|
|
||||||
|
|
||||||
-- unifying information for abstract, resource, and concrete
|
-- | unifying information for abstract, resource, and concrete
|
||||||
|
|
||||||
combineAnyInfos :: [(Ident,Info)] -> Err [(Ident,Info)]
|
combineAnyInfos :: [(Ident,Info)] -> Err [(Ident,Info)]
|
||||||
combineAnyInfos = combineInfos unifyAnyInfo
|
combineAnyInfos = combineInfos unifyAnyInfo
|
||||||
|
|
||||||
|
|||||||
@@ -12,7 +12,7 @@
|
|||||||
-- AR 8-11-2003, using Markus Forsberg's implementation of Huet's @unglue@
|
-- AR 8-11-2003, using Markus Forsberg's implementation of Huet's @unglue@
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
|
|
||||||
module Glue (decomposeSimple, exTrie) where
|
module Glue (decomposeSimple) where
|
||||||
|
|
||||||
import Trie2
|
import Trie2
|
||||||
import Operations
|
import Operations
|
||||||
|
|||||||
46
src/haddock/haddock-check.perl
Normal file
46
src/haddock/haddock-check.perl
Normal file
@@ -0,0 +1,46 @@
|
|||||||
|
|
||||||
|
# checking that a file is haddocky
|
||||||
|
|
||||||
|
# limitations:
|
||||||
|
# - does not check that 'type' declarations really are put in the export list
|
||||||
|
# - there might be some problems with nested comments
|
||||||
|
|
||||||
|
for $file (@ARGV) {
|
||||||
|
$file =~ s/\.hs//;
|
||||||
|
|
||||||
|
open F, "<$file.hs";
|
||||||
|
$_ = join "", <F>;
|
||||||
|
close F;
|
||||||
|
|
||||||
|
# print "- $file\n";
|
||||||
|
|
||||||
|
# removing comments:
|
||||||
|
s/\{-.*?-\}//gs;
|
||||||
|
s/--.*?\n/\n/g;
|
||||||
|
|
||||||
|
# export list:
|
||||||
|
if (/\nmodule\s+(\w+)\s+\((.*?)\)\s+where/s) {
|
||||||
|
($module, $exportlist) = ($1, $2);
|
||||||
|
|
||||||
|
# removing modules from exportlist:
|
||||||
|
$exportlist =~ s/module\s+[A-Z]\w*//gs;
|
||||||
|
|
||||||
|
# type signatures:
|
||||||
|
while (/\n([a-z]\w*)\s*::/gs) {
|
||||||
|
$function = $1;
|
||||||
|
$exportlist =~ s/\b$function\b//;
|
||||||
|
}
|
||||||
|
|
||||||
|
while ($exportlist =~ /\b(\w+)\b/gs) {
|
||||||
|
$function = $1;
|
||||||
|
next if $function =~ /^[A-Z]/;
|
||||||
|
printf "%-30s | No type signature for '%s'\n", $file, $1;
|
||||||
|
}
|
||||||
|
|
||||||
|
} else {
|
||||||
|
printf "%-30s | No export list\n", $file;
|
||||||
|
}
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
@@ -6,9 +6,11 @@ katalogen src kommer att inneh
|
|||||||
- GF.hs modulen Main
|
- GF.hs modulen Main
|
||||||
- GF/ resten av Haskell-filerna
|
- GF/ resten av Haskell-filerna
|
||||||
- JavaGUI/ java-filer
|
- JavaGUI/ java-filer
|
||||||
- haddock-script.csh för att skapa haddock-dokumentation
|
- haddock/ filer för haddock
|
||||||
- haddock-resources/ nödvändiga filer för haddock-script.csh
|
- html/
|
||||||
- haddock/ html-resultat efter att ha kört haddock
|
- resources/
|
||||||
|
- run-haddock.csh
|
||||||
|
- check-haddock.perl
|
||||||
|
|
||||||
modifiera gärna strukturen och kommentarerna nedan
|
modifiera gärna strukturen och kommentarerna nedan
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
|
|||||||
49
src/tools/mkHelpFile.perl
Normal file
49
src/tools/mkHelpFile.perl
Normal file
@@ -0,0 +1,49 @@
|
|||||||
|
|
||||||
|
$infile = $#ARGV >= 0 ? '@'.join('@, @', @ARGV).'@' : '/the input file/';
|
||||||
|
|
||||||
|
print <<EOF;
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
-- |
|
||||||
|
-- Module : HelpFile
|
||||||
|
-- Maintainer : Aarne Ranta
|
||||||
|
-- Stability : Stable (Autogenerated)
|
||||||
|
-- Portability : Haskell 98
|
||||||
|
--
|
||||||
|
-- > CVS \$Date \$
|
||||||
|
-- > CVS \$Author \$
|
||||||
|
-- > CVS \$Revision \$
|
||||||
|
--
|
||||||
|
-- Help on shell commands. Generated from $infile by invoking the
|
||||||
|
-- perl script \@mkHelpFile.perl\@.
|
||||||
|
-- Automatically generated -- PLEASE DON'T EDIT THIS FILE,
|
||||||
|
-- edit $infile instead.
|
||||||
|
-----------------------------------------------------------------------------
|
||||||
|
|
||||||
|
module HelpFile (txtHelpFileSummary, txtHelpCommand, txtHelpFile) where
|
||||||
|
|
||||||
|
import Operations
|
||||||
|
|
||||||
|
txtHelpFileSummary :: String
|
||||||
|
txtHelpFileSummary =
|
||||||
|
unlines \$ map (concat . take 1 . lines) \$ paragraphs txtHelpFile
|
||||||
|
|
||||||
|
txtHelpCommand :: String -> String
|
||||||
|
txtHelpCommand c =
|
||||||
|
case lookup c [(takeWhile (/=',') p,p) | p <- paragraphs txtHelpFile] of
|
||||||
|
Just s -> s
|
||||||
|
_ -> "Command not found."
|
||||||
|
|
||||||
|
txtHelpFile :: String
|
||||||
|
txtHelpFile =
|
||||||
|
EOF
|
||||||
|
|
||||||
|
while (<>) {
|
||||||
|
chop;
|
||||||
|
s/([\"\\])/\\$1/g;
|
||||||
|
$pref = /^ / ? "\\n" : "\\n";
|
||||||
|
print " \"$pref$_\" ++\n";
|
||||||
|
}
|
||||||
|
|
||||||
|
print " []\n";
|
||||||
|
|
||||||
|
|
||||||
Reference in New Issue
Block a user