mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-22 11:19:32 -06:00
removed src for 2.9
This commit is contained in:
aarne
@@ -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.Infra.CheckM (Check,
|
||||
checkError, checkCond, checkWarn, checkUpdate, checkInContext,
|
||||
checkUpdates, checkReset, checkResets, checkGetContext,
|
||||
checkLookup, checkStart, checkErr, checkVal, checkIn,
|
||||
prtFail
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Infra.Ident
|
||||
import GF.Grammar.PrGrammar
|
||||
|
||||
-- | the strings are non-fatal warnings
|
||||
type Check a = STM (Context,[String]) a
|
||||
|
||||
checkError :: String -> Check a
|
||||
checkError = raise
|
||||
|
||||
checkCond :: String -> Bool -> Check ()
|
||||
checkCond s b = if b then return () else checkError s
|
||||
|
||||
-- | warnings should be reversed in the end
|
||||
checkWarn :: String -> Check ()
|
||||
checkWarn s = updateSTM (\ (cont,msg) -> (cont, s:msg))
|
||||
|
||||
checkUpdate :: Decl -> Check ()
|
||||
checkUpdate d = updateSTM (\ (cont,msg) -> (d:cont, msg))
|
||||
|
||||
checkInContext :: [Decl] -> Check r -> Check r
|
||||
checkInContext g ch = do
|
||||
i <- checkUpdates g
|
||||
r <- ch
|
||||
checkResets i
|
||||
return r
|
||||
|
||||
checkUpdates :: [Decl] -> Check Int
|
||||
checkUpdates ds = mapM checkUpdate ds >> return (length ds)
|
||||
|
||||
checkReset :: Check ()
|
||||
checkReset = checkResets 1
|
||||
|
||||
checkResets :: Int -> Check ()
|
||||
checkResets i = updateSTM (\ (cont,msg) -> (drop i cont, msg))
|
||||
|
||||
checkGetContext :: Check Context
|
||||
checkGetContext = do
|
||||
(co,_) <- readSTM
|
||||
return co
|
||||
|
||||
checkLookup :: Ident -> Check Type
|
||||
checkLookup x = do
|
||||
co <- checkGetContext
|
||||
checkErr $ maybe (prtBad "unknown variable" x) return $ lookup x co
|
||||
|
||||
checkStart :: Check a -> Err (a,(Context,[String]))
|
||||
checkStart c = appSTM c ([],[])
|
||||
|
||||
checkErr :: Err a -> Check a
|
||||
checkErr e = stm (\s -> do
|
||||
v <- e
|
||||
return (v,s)
|
||||
)
|
||||
|
||||
checkVal :: a -> Check a
|
||||
checkVal v = return v
|
||||
|
||||
prtFail :: Print a => String -> a -> Check b
|
||||
prtFail s t = checkErr $ prtBad s t
|
||||
|
||||
checkIn :: String -> Check a -> Check a
|
||||
checkIn msg c = stm $ \s@(g,ws) -> case appSTM c s of
|
||||
Bad e -> Bad $ msg ++++ e
|
||||
Ok (v,(g',ws')) -> Ok (v,(g',ws2)) where
|
||||
new = take (length ws' - length ws) ws'
|
||||
ws2 = [msg ++++ w | w <- new] ++ ws
|
||||
@@ -1,43 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Comments
|
||||
-- Maintainer : (Maintainer)
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:22:34 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.5 $
|
||||
--
|
||||
-- comment removal
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Infra.Comments ( remComments
|
||||
) where
|
||||
|
||||
-- | comment removal : line tails prefixed by -- as well as chunks in @{- ... -}@
|
||||
remComments :: String -> String
|
||||
remComments s =
|
||||
case s of
|
||||
'"':s2 -> '"':pass remComments s2 -- comment marks in quotes not removed!
|
||||
'{':'-':cs -> readNested cs
|
||||
'-':'-':cs -> readTail cs
|
||||
c:cs -> c : remComments cs
|
||||
[] -> []
|
||||
where
|
||||
readNested t =
|
||||
case t of
|
||||
'"':s2 -> '"':pass readNested s2
|
||||
'-':'}':cs -> remComments cs
|
||||
_:cs -> readNested cs
|
||||
[] -> []
|
||||
readTail t =
|
||||
case t of
|
||||
'\n':cs -> '\n':remComments cs
|
||||
_:cs -> readTail cs
|
||||
[] -> []
|
||||
pass f t =
|
||||
case t of
|
||||
'"':s2 -> '"': f s2
|
||||
c:s2 -> c:pass f s2
|
||||
_ -> t
|
||||
@@ -1,22 +0,0 @@
|
||||
module GF.Infra.CompactPrint where
|
||||
import Data.Char
|
||||
|
||||
compactPrint = compactPrintCustom keywordGF (const False)
|
||||
|
||||
compactPrintGFCC = compactPrintCustom (const False) keywordGFCC
|
||||
|
||||
compactPrintCustom pre post = dps . concat . map (spaceIf pre post) . words
|
||||
|
||||
dps = dropWhile isSpace
|
||||
|
||||
spaceIf pre post w = case w of
|
||||
_ | pre w -> "\n" ++ w
|
||||
_ | post w -> w ++ "\n"
|
||||
c:_ | isAlpha c || isDigit c -> " " ++ w
|
||||
'_':_ -> " " ++ w
|
||||
_ -> w
|
||||
|
||||
keywordGF w = elem w ["cat","fun","lin","lincat","lindef","oper","param"]
|
||||
keywordGFCC w =
|
||||
last w == ';' ||
|
||||
elem w ["flags","fun","cat","lin","oper","lincat","lindef","printname","param"]
|
||||
@@ -1,155 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Ident
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/11/15 11:43:33 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.8 $
|
||||
--
|
||||
-- (Description of the module)
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Infra.Ident (-- * Identifiers
|
||||
Ident(..), prIdent,
|
||||
identC, identV, identA, identAV, identW,
|
||||
argIdent, strVar, wildIdent, isWildIdent,
|
||||
newIdent, mkIdent, varIndex,
|
||||
-- * refreshing identifiers
|
||||
IdState, initIdStateN, initIdState,
|
||||
lookVar, refVar, refVarPlus
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
-- import Monad
|
||||
|
||||
|
||||
-- | the constructors labelled /INTERNAL/ are
|
||||
-- internal representation never returned by the parser
|
||||
data Ident =
|
||||
IC String -- ^ raw identifier after parsing, resolved in Rename
|
||||
| IW -- ^ wildcard
|
||||
--
|
||||
-- below this constructor: internal representation never returned by the parser
|
||||
| IV (Int,String) -- ^ /INTERNAL/ variable
|
||||
| IA (String,Int) -- ^ /INTERNAL/ argument of cat at position
|
||||
| IAV (String,Int,Int) -- ^ /INTERNAL/ argument of cat with bindings at position
|
||||
--
|
||||
|
||||
deriving (Eq, Ord, Show, Read)
|
||||
|
||||
prIdent :: Ident -> String
|
||||
prIdent i = case i of
|
||||
IC s -> s
|
||||
IV (n,s) -> s ++ "_" ++ show n
|
||||
IA (s,j) -> s ++ "_" ++ show j
|
||||
IAV (s,b,j) -> s ++ "_" ++ show b ++ "_" ++ show j
|
||||
IW -> "_"
|
||||
|
||||
identC :: String -> Ident
|
||||
identV :: (Int, String) -> Ident
|
||||
identA :: (String, Int) -> Ident
|
||||
identAV:: (String, Int, Int) -> Ident
|
||||
identW :: Ident
|
||||
(identC, identV, identA, identAV, identW) =
|
||||
(IC, IV, IA, IAV, IW)
|
||||
|
||||
-- normal identifier
|
||||
-- ident s = IC s
|
||||
|
||||
-- | to mark argument variables
|
||||
argIdent :: Int -> Ident -> Int -> Ident
|
||||
argIdent 0 (IC c) i = identA (c,i)
|
||||
argIdent b (IC c) i = identAV (c,b,i)
|
||||
|
||||
-- | used in lin defaults
|
||||
strVar :: Ident
|
||||
strVar = identA ("str",0)
|
||||
|
||||
-- | wild card
|
||||
wildIdent :: Ident
|
||||
wildIdent = identW
|
||||
|
||||
isWildIdent :: Ident -> Bool
|
||||
isWildIdent x = case x of
|
||||
IW -> True
|
||||
IC "_" -> True
|
||||
_ -> False
|
||||
|
||||
newIdent :: Ident
|
||||
newIdent = identC "#h"
|
||||
|
||||
mkIdent :: String -> Int -> Ident
|
||||
mkIdent s i = identV (i,s)
|
||||
|
||||
varIndex :: Ident -> Int
|
||||
varIndex (IV (n,_)) = n
|
||||
varIndex _ = -1 --- other than IV should not count
|
||||
|
||||
-- refreshing identifiers
|
||||
|
||||
type IdState = ([(Ident,Ident)],Int)
|
||||
|
||||
initIdStateN :: Int -> IdState
|
||||
initIdStateN i = ([],i)
|
||||
|
||||
initIdState :: IdState
|
||||
initIdState = initIdStateN 0
|
||||
|
||||
lookVar :: Ident -> STM IdState Ident
|
||||
lookVar a@(IA _) = return a
|
||||
lookVar x = do
|
||||
(sys,_) <- readSTM
|
||||
stm (\s -> maybe (Bad ("cannot find" +++ show x +++ prParenth (show sys)))
|
||||
return $
|
||||
lookup x sys >>= (\y -> return (y,s)))
|
||||
|
||||
refVar :: Ident -> STM IdState Ident
|
||||
----refVar IW = return IW --- no update of wildcard
|
||||
refVar x = do
|
||||
(_,m) <- readSTM
|
||||
let x' = IV (m, prIdent x)
|
||||
updateSTM (\ (sys,mx) -> ((x, x'):sys, mx + 1))
|
||||
return x'
|
||||
|
||||
refVarPlus :: Ident -> STM IdState Ident
|
||||
----refVarPlus IW = refVar (identC "h")
|
||||
refVarPlus x = refVar x
|
||||
|
||||
|
||||
{-
|
||||
------------------------------
|
||||
-- to test
|
||||
|
||||
refreshExp :: Exp -> Err Exp
|
||||
refreshExp e = err Bad (return . fst) (appSTM (refresh e) initState)
|
||||
|
||||
refresh :: Exp -> STM State Exp
|
||||
refresh e = case e of
|
||||
Atom x -> lookVar x >>= return . Atom
|
||||
App f a -> liftM2 App (refresh f) (refresh a)
|
||||
Abs x b -> liftM2 Abs (refVar x) (refresh b)
|
||||
Fun xs a b -> do
|
||||
a' <- refresh a
|
||||
xs' <- mapM refVar xs
|
||||
b' <- refresh b
|
||||
return $ Fun xs' a' b'
|
||||
|
||||
data Exp =
|
||||
Atom Ident
|
||||
| App Exp Exp
|
||||
| Abs Ident Exp
|
||||
| Fun [Ident] Exp Exp
|
||||
deriving Show
|
||||
|
||||
exp1 = Abs (IC "y") (Atom (IC "y"))
|
||||
exp2 = Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "y")))
|
||||
exp3 = Abs (IC "y") (Abs (IC "z") (App (Atom (IC "y")) (Atom (IC "z"))))
|
||||
exp4 = Abs (IC "y") (Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "z"))))
|
||||
exp5 = Abs (IC "y") (Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "y"))))
|
||||
exp6 = Abs (IC "y") (Fun [IC "x", IC "y"] (Atom (IC "y")) (Atom (IC "y")))
|
||||
exp7 = Abs (IL "8") (Atom (IC "y"))
|
||||
|
||||
-}
|
||||
@@ -1,416 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Modules
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/11/09 15:14:30 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.26 $
|
||||
--
|
||||
-- Datastructures and functions for modules, common to GF and GFC.
|
||||
--
|
||||
-- AR 29\/4\/2003
|
||||
--
|
||||
-- The same structure will be used in both source code and canonical.
|
||||
-- The parameters tell what kind of data is involved.
|
||||
-- Invariant: modules are stored in dependency order
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Infra.Modules (
|
||||
MGrammar(..), ModInfo(..), Module(..), ModuleType(..),
|
||||
MReuseType(..), MInclude (..),
|
||||
extends, isInherited,inheritAll,
|
||||
updateMGrammar, updateModule, replaceJudgements, addFlag,
|
||||
addOpenQualif, flagsModule, allFlags, mapModules,
|
||||
MainGrammar(..), MainConcreteSpec(..), OpenSpec(..), OpenQualif(..),
|
||||
oSimple, oQualif,
|
||||
ModuleStatus(..),
|
||||
openedModule, allOpens, depPathModule, allDepsModule, partOfGrammar,
|
||||
allExtends, allExtendSpecs, allExtendsPlus, allExtensions,
|
||||
searchPathModule, addModule,
|
||||
emptyMGrammar, emptyModInfo, emptyModule,
|
||||
IdentM(..),
|
||||
typeOfModule, abstractOfConcrete, abstractModOfConcrete,
|
||||
lookupModule, lookupModuleType, lookupModMod, lookupInfo,
|
||||
allModMod, isModAbs, isModRes, isModCnc, isModTrans,
|
||||
sameMType, isCompilableModule, isCompleteModule,
|
||||
allAbstracts, greatestAbstract, allResources,
|
||||
greatestResource, allConcretes, allConcreteModules
|
||||
) where
|
||||
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Option
|
||||
import GF.Data.Operations
|
||||
|
||||
import Data.List
|
||||
|
||||
|
||||
-- AR 29/4/2003
|
||||
|
||||
-- The same structure will be used in both source code and canonical.
|
||||
-- The parameters tell what kind of data is involved.
|
||||
-- Invariant: modules are stored in dependency order
|
||||
|
||||
data MGrammar i f a = MGrammar {modules :: [(i,ModInfo i f a)]}
|
||||
deriving Show
|
||||
|
||||
data ModInfo i f a =
|
||||
ModMainGrammar (MainGrammar i)
|
||||
| ModMod (Module i f a)
|
||||
| ModWith (Module i f a) (i,MInclude i) [OpenSpec i]
|
||||
deriving Show
|
||||
|
||||
data Module i f a = Module {
|
||||
mtype :: ModuleType i ,
|
||||
mstatus :: ModuleStatus ,
|
||||
flags :: [f] ,
|
||||
extend :: [(i,MInclude i)],
|
||||
opens :: [OpenSpec i] ,
|
||||
jments :: BinTree i a
|
||||
}
|
||||
--- deriving Show
|
||||
instance Show (Module i f a) where
|
||||
show _ = "cannot show Module with FiniteMap"
|
||||
|
||||
-- | encoding the type of the module
|
||||
data ModuleType i =
|
||||
MTAbstract
|
||||
| MTTransfer (OpenSpec i) (OpenSpec i)
|
||||
| MTResource
|
||||
| MTConcrete i
|
||||
-- ^ up to this, also used in GFC. Below, source only.
|
||||
| MTInterface
|
||||
| MTInstance i
|
||||
| MTReuse (MReuseType i)
|
||||
| MTUnion (ModuleType i) [(i,[i])] -- ^ not meant to be recursive
|
||||
deriving (Eq,Show)
|
||||
|
||||
data MReuseType i = MRInterface i | MRInstance i i | MRResource i
|
||||
deriving (Show,Eq)
|
||||
|
||||
data MInclude i = MIAll | MIOnly [i] | MIExcept [i]
|
||||
deriving (Show,Eq)
|
||||
|
||||
extends :: Module i f a -> [i]
|
||||
extends = map fst . extend
|
||||
|
||||
isInherited :: Eq i => MInclude i -> i -> Bool
|
||||
isInherited c i = case c of
|
||||
MIAll -> True
|
||||
MIOnly is -> elem i is
|
||||
MIExcept is -> notElem i is
|
||||
|
||||
inheritAll :: i -> (i,MInclude i)
|
||||
inheritAll i = (i,MIAll)
|
||||
|
||||
-- destructive update
|
||||
|
||||
-- | dep order preserved since old cannot depend on new
|
||||
updateMGrammar :: Ord i => MGrammar i f a -> MGrammar i f a -> MGrammar i f a
|
||||
updateMGrammar old new = MGrammar $
|
||||
[(i,m) | (i,m) <- os, notElem i (map fst ns)] ++ ns
|
||||
where
|
||||
os = modules old
|
||||
ns = modules new
|
||||
|
||||
updateModule :: Ord i => Module i f t -> i -> t -> Module i f t
|
||||
updateModule (Module mt ms fs me ops js) i t =
|
||||
Module mt ms fs me ops (updateTree (i,t) js)
|
||||
|
||||
replaceJudgements :: Module i f t -> BinTree i t -> Module i f t
|
||||
replaceJudgements (Module mt ms fs me ops _) js = Module mt ms fs me ops js
|
||||
|
||||
addOpenQualif :: i -> i -> Module i f t -> Module i f t
|
||||
addOpenQualif i j (Module mt ms fs me ops js) =
|
||||
Module mt ms fs me (oQualif i j : ops) js
|
||||
|
||||
addFlag :: f -> Module i f t -> Module i f t
|
||||
addFlag f mo = mo {flags = f : flags mo}
|
||||
|
||||
flagsModule :: (i,ModInfo i f a) -> [f]
|
||||
flagsModule (_,mi) = case mi of
|
||||
ModMod m -> flags m
|
||||
_ -> []
|
||||
|
||||
allFlags :: MGrammar i f a -> [f]
|
||||
allFlags gr = concat $ map flags $ [m | (_, ModMod m) <- modules gr]
|
||||
|
||||
mapModules :: (Module i f a -> Module i f a)
|
||||
-> MGrammar i f a -> MGrammar i f a
|
||||
mapModules f = MGrammar . map (onSnd mapModules') . modules
|
||||
where mapModules' (ModMod m) = ModMod (f m)
|
||||
mapModules' m = m
|
||||
|
||||
data MainGrammar i = MainGrammar {
|
||||
mainAbstract :: i ,
|
||||
mainConcretes :: [MainConcreteSpec i]
|
||||
}
|
||||
deriving Show
|
||||
|
||||
data MainConcreteSpec i = MainConcreteSpec {
|
||||
concretePrintname :: i ,
|
||||
concreteName :: i ,
|
||||
transferIn :: Maybe (OpenSpec i) , -- ^ if there is an in-transfer
|
||||
transferOut :: Maybe (OpenSpec i) -- ^ if there is an out-transfer
|
||||
}
|
||||
deriving Show
|
||||
|
||||
data OpenSpec i =
|
||||
OSimple OpenQualif i
|
||||
| OQualif OpenQualif i i
|
||||
deriving (Eq,Show)
|
||||
|
||||
data OpenQualif =
|
||||
OQNormal
|
||||
| OQInterface
|
||||
| OQIncomplete
|
||||
deriving (Eq,Show)
|
||||
|
||||
oSimple :: i -> OpenSpec i
|
||||
oSimple = OSimple OQNormal
|
||||
|
||||
oQualif :: i -> i -> OpenSpec i
|
||||
oQualif = OQualif OQNormal
|
||||
|
||||
data ModuleStatus =
|
||||
MSComplete
|
||||
| MSIncomplete
|
||||
deriving (Eq,Show)
|
||||
|
||||
openedModule :: OpenSpec i -> i
|
||||
openedModule o = case o of
|
||||
OSimple _ m -> m
|
||||
OQualif _ _ m -> m
|
||||
|
||||
allOpens :: Module i f a -> [OpenSpec i]
|
||||
allOpens m = case mtype m of
|
||||
MTTransfer a b -> a : b : opens m
|
||||
_ -> opens m
|
||||
|
||||
-- | initial dependency list
|
||||
depPathModule :: Ord i => Module i f a -> [OpenSpec i]
|
||||
depPathModule m = fors m ++ exts m ++ opens m where
|
||||
fors m = case mtype m of
|
||||
MTTransfer i j -> [i,j]
|
||||
MTConcrete i -> [oSimple i]
|
||||
MTInstance i -> [oSimple i]
|
||||
_ -> []
|
||||
exts m = map oSimple $ extends m
|
||||
|
||||
-- | all dependencies
|
||||
allDepsModule :: Ord i => MGrammar i f a -> Module i f a -> [OpenSpec i]
|
||||
allDepsModule gr m = iterFix add os0 where
|
||||
os0 = depPathModule m
|
||||
add os = [m | o <- os, Just (ModMod n) <- [lookup (openedModule o) mods],
|
||||
m <- depPathModule n]
|
||||
mods = modules gr
|
||||
|
||||
-- | select just those modules that a given one depends on, including itself
|
||||
partOfGrammar :: Ord i => MGrammar i f a -> (i,ModInfo i f a) -> MGrammar i f a
|
||||
partOfGrammar gr (i,m) = MGrammar [mo | mo@(j,_) <- mods, elem j modsFor]
|
||||
where
|
||||
mods = modules gr
|
||||
modsFor = case m of
|
||||
ModMod n -> (i:) $ map openedModule $ allDepsModule gr n
|
||||
---- ModWith n i os -> i : map openedModule os ++ partOfGrammar (ModMod n) ----
|
||||
_ -> [i]
|
||||
|
||||
-- | all modules that a module extends, directly or indirectly, without restricts
|
||||
allExtends :: (Show i,Ord i) => MGrammar i f a -> i -> [i]
|
||||
allExtends gr i = case lookupModule gr i of
|
||||
Ok (ModMod m) -> case extends m of
|
||||
[] -> [i]
|
||||
is -> i : concatMap (allExtends gr) is
|
||||
_ -> []
|
||||
|
||||
-- | all modules that a module extends, directly or indirectly, with restricts
|
||||
allExtendSpecs :: (Show i,Ord i) => MGrammar i f a -> i -> [(i,MInclude i)]
|
||||
allExtendSpecs gr i = case lookupModule gr i of
|
||||
Ok (ModMod m) -> case extend m of
|
||||
[] -> [(i,MIAll)]
|
||||
is -> (i,MIAll) : concatMap (allExtendSpecs gr . fst) is
|
||||
_ -> []
|
||||
|
||||
-- | this plus that an instance extends its interface
|
||||
allExtendsPlus :: (Show i,Ord i) => MGrammar i f a -> i -> [i]
|
||||
allExtendsPlus gr i = case lookupModule gr i of
|
||||
Ok (ModMod m) -> i : concatMap (allExtendsPlus gr) (exts m)
|
||||
_ -> []
|
||||
where
|
||||
exts m = extends m ++ [j | MTInstance j <- [mtype m]]
|
||||
|
||||
-- | conversely: all modules that extend a given module, incl. instances of interface
|
||||
allExtensions :: (Show i,Ord i) => MGrammar i f a -> i -> [i]
|
||||
allExtensions gr i = case lookupModule gr i of
|
||||
Ok (ModMod m) -> let es = exts i in es ++ concatMap (allExtensions gr) es
|
||||
_ -> []
|
||||
where
|
||||
exts i = [j | (j,m) <- mods, elem i (extends m)
|
||||
|| elem (MTInstance i) [mtype m]]
|
||||
mods = [(j,m) | (j,ModMod m) <- modules gr]
|
||||
|
||||
-- | initial search path: the nonqualified dependencies
|
||||
searchPathModule :: Ord i => Module i f a -> [i]
|
||||
searchPathModule m = [i | OSimple _ i <- depPathModule m]
|
||||
|
||||
-- | a new module can safely be added to the end, since nothing old can depend on it
|
||||
addModule :: Ord i =>
|
||||
MGrammar i f a -> i -> ModInfo i f a -> MGrammar i f a
|
||||
addModule gr name mi = MGrammar $ (modules gr ++ [(name,mi)])
|
||||
|
||||
emptyMGrammar :: MGrammar i f a
|
||||
emptyMGrammar = MGrammar []
|
||||
|
||||
emptyModInfo :: ModInfo i f a
|
||||
emptyModInfo = ModMod emptyModule
|
||||
|
||||
emptyModule :: Module i f a
|
||||
emptyModule = Module MTResource MSComplete [] [] [] emptyBinTree
|
||||
|
||||
-- | we store the module type with the identifier
|
||||
data IdentM i = IdentM {
|
||||
identM :: i ,
|
||||
typeM :: ModuleType i
|
||||
}
|
||||
deriving (Eq,Show)
|
||||
|
||||
typeOfModule :: ModInfo i f a -> ModuleType i
|
||||
typeOfModule mi = case mi of
|
||||
ModMod m -> mtype m
|
||||
|
||||
abstractOfConcrete :: (Show i, Eq i) => MGrammar i f a -> i -> Err i
|
||||
abstractOfConcrete gr c = do
|
||||
m <- lookupModule gr c
|
||||
case m of
|
||||
ModMod n -> case mtype n of
|
||||
MTConcrete a -> return a
|
||||
_ -> Bad $ "expected concrete" +++ show c
|
||||
_ -> Bad $ "expected concrete" +++ show c
|
||||
|
||||
abstractModOfConcrete :: (Show i, Eq i) =>
|
||||
MGrammar i f a -> i -> Err (Module i f a)
|
||||
abstractModOfConcrete gr c = do
|
||||
a <- abstractOfConcrete gr c
|
||||
m <- lookupModule gr a
|
||||
case m of
|
||||
ModMod n -> return n
|
||||
_ -> Bad $ "expected abstract" +++ show c
|
||||
|
||||
|
||||
-- the canonical file name
|
||||
|
||||
--- canonFileName s = prt s ++ ".gfc"
|
||||
|
||||
lookupModule :: (Show i,Eq i) => MGrammar i f a -> i -> Err (ModInfo i f a)
|
||||
lookupModule gr m = case lookup m (modules gr) of
|
||||
Just i -> return i
|
||||
_ -> Bad $ "unknown module" +++ show m
|
||||
+++ "among" +++ unwords (map (show . fst) (modules gr)) ---- debug
|
||||
|
||||
lookupModuleType :: (Show i,Eq i) => MGrammar i f a -> i -> Err (ModuleType i)
|
||||
lookupModuleType gr m = do
|
||||
mi <- lookupModule gr m
|
||||
return $ typeOfModule mi
|
||||
|
||||
lookupModMod :: (Show i,Eq i) => MGrammar i f a -> i -> Err (Module i f a)
|
||||
lookupModMod gr i = do
|
||||
mo <- lookupModule gr i
|
||||
case mo of
|
||||
ModMod m -> return m
|
||||
_ -> Bad $ "expected proper module, not" +++ show i
|
||||
|
||||
lookupInfo :: (Show i, Ord i) => Module i f a -> i -> Err a
|
||||
lookupInfo mo i = lookupTree show i (jments mo)
|
||||
|
||||
allModMod :: (Show i,Eq i) => MGrammar i f a -> [(i,Module i f a)]
|
||||
allModMod gr = [(i,m) | (i, ModMod m) <- modules gr]
|
||||
|
||||
isModAbs :: Module i f a -> Bool
|
||||
isModAbs m = case mtype m of
|
||||
MTAbstract -> True
|
||||
---- MTUnion t -> isModAbs t
|
||||
_ -> False
|
||||
|
||||
isModRes :: Module i f a -> Bool
|
||||
isModRes m = case mtype m of
|
||||
MTResource -> True
|
||||
MTReuse _ -> True
|
||||
---- MTUnion t -> isModRes t --- maybe not needed, since eliminated early
|
||||
MTInterface -> True ---
|
||||
MTInstance _ -> True
|
||||
_ -> False
|
||||
|
||||
isModCnc :: Module i f a -> Bool
|
||||
isModCnc m = case mtype m of
|
||||
MTConcrete _ -> True
|
||||
---- MTUnion t -> isModCnc t
|
||||
_ -> False
|
||||
|
||||
isModTrans :: Module i f a -> Bool
|
||||
isModTrans m = case mtype m of
|
||||
MTTransfer _ _ -> True
|
||||
---- MTUnion t -> isModTrans t
|
||||
_ -> False
|
||||
|
||||
sameMType :: Eq i => ModuleType i -> ModuleType i -> Bool
|
||||
sameMType m n = case (n,m) of
|
||||
(MTConcrete _, MTConcrete _) -> True
|
||||
|
||||
(MTInstance _, MTInstance _) -> True
|
||||
(MTInstance _, MTResource) -> True
|
||||
(MTInstance _, MTConcrete _) -> True
|
||||
|
||||
(MTInterface, MTInstance _) -> True
|
||||
(MTInterface, MTResource) -> True -- for reuse
|
||||
(MTInterface, MTAbstract) -> True -- for reuse
|
||||
|
||||
(MTResource, MTInstance _) -> True
|
||||
(MTResource, MTConcrete _) -> True -- for reuse
|
||||
|
||||
_ -> m == n
|
||||
|
||||
-- | don't generate code for interfaces and for incomplete modules
|
||||
isCompilableModule :: ModInfo i f a -> Bool
|
||||
isCompilableModule m = case m of
|
||||
ModMod m -> case mtype m of
|
||||
MTInterface -> False
|
||||
_ -> mstatus m == MSComplete
|
||||
_ -> False ---
|
||||
|
||||
-- | interface and "incomplete M" are not complete
|
||||
isCompleteModule :: (Eq i) => Module i f a -> Bool
|
||||
isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface
|
||||
|
||||
|
||||
-- | all abstract modules sorted from least to most dependent
|
||||
allAbstracts :: Eq i => MGrammar i f a -> [i]
|
||||
allAbstracts gr = topoSort
|
||||
[(i,extends m) | (i,ModMod m) <- modules gr, mtype m == MTAbstract]
|
||||
|
||||
-- | the last abstract in dependency order (head of list)
|
||||
greatestAbstract :: Eq i => MGrammar i f a -> Maybe i
|
||||
greatestAbstract gr = case allAbstracts gr of
|
||||
[] -> Nothing
|
||||
as -> return $ last as
|
||||
|
||||
-- | all resource modules
|
||||
allResources :: MGrammar i f a -> [i]
|
||||
allResources gr = [i | (i,ModMod m) <- modules gr, isModRes m]
|
||||
|
||||
-- | the greatest resource in dependency order
|
||||
greatestResource :: MGrammar i f a -> Maybe i
|
||||
greatestResource gr = case allResources gr of
|
||||
[] -> Nothing
|
||||
a -> return $ head a
|
||||
|
||||
-- | all concretes for a given abstract
|
||||
allConcretes :: Eq i => MGrammar i f a -> i -> [i]
|
||||
allConcretes gr a =
|
||||
[i | (i, ModMod m) <- modules gr, mtype m == MTConcrete a, isCompleteModule m]
|
||||
|
||||
-- | all concrete modules for any abstract
|
||||
allConcreteModules :: Eq i => MGrammar i f a -> [i]
|
||||
allConcreteModules gr =
|
||||
[i | (i, ModMod m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]
|
||||
@@ -1,375 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Option
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/11/14 16:03:41 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.34 $
|
||||
--
|
||||
-- Options and flags used in GF shell commands and files.
|
||||
--
|
||||
-- The types 'Option' and 'Options' should be kept abstract, but:
|
||||
--
|
||||
-- - The constructor 'Opt' is used in "ShellCommands" and "GrammarToSource"
|
||||
--
|
||||
-- - The constructor 'Opts' us udes in "API", "Shell" and "ShellCommands"
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Infra.Option where
|
||||
|
||||
import Data.List (partition)
|
||||
import Data.Char (isDigit)
|
||||
|
||||
-- * all kinds of options, to be kept abstract
|
||||
|
||||
newtype Option = Opt (String,[String]) deriving (Eq,Show,Read)
|
||||
newtype Options = Opts [Option] deriving (Eq,Show,Read)
|
||||
|
||||
noOptions :: Options
|
||||
noOptions = Opts []
|
||||
|
||||
-- | simple option -o
|
||||
iOpt :: String -> Option
|
||||
iOpt o = Opt (o,[])
|
||||
|
||||
-- | option with argument -o=a
|
||||
aOpt :: String -> String -> Option
|
||||
aOpt o a = Opt (o,[a])
|
||||
|
||||
iOpts :: [Option] -> Options
|
||||
iOpts = Opts
|
||||
|
||||
-- | value of option argument
|
||||
oArg :: String -> String
|
||||
oArg s = s
|
||||
|
||||
oElem :: Option -> Options -> Bool
|
||||
oElem o (Opts os) = elem o os
|
||||
|
||||
eqOpt :: String -> Option -> Bool
|
||||
eqOpt s (Opt (o, [])) = s == o
|
||||
eqOpt s _ = False
|
||||
|
||||
type OptFun = String -> Option
|
||||
type OptFunId = String
|
||||
|
||||
getOptVal :: Options -> OptFun -> Maybe String
|
||||
getOptVal (Opts os) fopt =
|
||||
case [a | opt@(Opt (o,[a])) <- os, opt == fopt a] of
|
||||
a:_ -> Just a
|
||||
_ -> Nothing
|
||||
|
||||
isSetFlag :: Options -> OptFun -> Bool
|
||||
isSetFlag (Opts os) fopt =
|
||||
case [a | opt@(Opt (o,[a])) <- os, opt == fopt a] of
|
||||
a:_ -> True
|
||||
_ -> False
|
||||
|
||||
getOptInt :: Options -> OptFun -> Maybe Int
|
||||
getOptInt opts f = do
|
||||
s <- getOptVal opts f
|
||||
if (not (null s) && all isDigit s) then return (read s) else Nothing
|
||||
|
||||
optIntOrAll :: Options -> OptFun -> [a] -> [a]
|
||||
optIntOrAll opts f = case getOptInt opts f of
|
||||
Just i -> take i
|
||||
_ -> id
|
||||
|
||||
optIntOrN :: Options -> OptFun -> Int -> Int
|
||||
optIntOrN opts f n = case getOptInt opts f of
|
||||
Just i -> i
|
||||
_ -> n
|
||||
|
||||
optIntOrOne :: Options -> OptFun -> Int
|
||||
optIntOrOne opts f = optIntOrN opts f 1
|
||||
|
||||
changeOptVal :: Options -> OptFun -> String -> Options
|
||||
changeOptVal os f x =
|
||||
addOption (f x) $ maybe os (\y -> removeOption (f y) os) $ getOptVal os f
|
||||
|
||||
addOption :: Option -> Options -> Options
|
||||
addOption o (Opts os) = iOpts (o:os)
|
||||
|
||||
addOptions :: Options -> Options -> Options
|
||||
addOptions (Opts os) os0 = foldr addOption os0 os
|
||||
|
||||
concatOptions :: [Options] -> Options
|
||||
concatOptions = foldr addOptions noOptions
|
||||
|
||||
removeOption :: Option -> Options -> Options
|
||||
removeOption o (Opts os) = iOpts (filter (/=o) os)
|
||||
|
||||
removeOptions :: Options -> Options -> Options
|
||||
removeOptions (Opts os) os0 = foldr removeOption os0 os
|
||||
|
||||
options :: [Option] -> Options
|
||||
options = foldr addOption noOptions
|
||||
|
||||
unionOptions :: Options -> Options -> Options
|
||||
unionOptions (Opts os) (Opts os') = Opts (os ++ os')
|
||||
|
||||
-- * parsing options, with prefix pre (e.g. \"-\")
|
||||
|
||||
getOptions :: String -> [String] -> (Options, [String])
|
||||
getOptions pre inp = let
|
||||
(os,rest) = span (isOption pre) inp -- options before args
|
||||
in
|
||||
(Opts (map (pOption pre) os), rest)
|
||||
|
||||
pOption :: String -> String -> Option
|
||||
pOption pre s = case span (/= '=') (drop (length pre) s) of
|
||||
(f,_:a) -> aOpt f a
|
||||
(o,[]) -> iOpt o
|
||||
|
||||
isOption :: String -> String -> Bool
|
||||
isOption pre = (==pre) . take (length pre)
|
||||
|
||||
-- * printing options, without prefix
|
||||
|
||||
prOpt :: Option -> String
|
||||
prOpt (Opt (s,[])) = s
|
||||
prOpt (Opt (s,xs)) = s ++ "=" ++ concat xs
|
||||
|
||||
prOpts :: Options -> String
|
||||
prOpts (Opts os) = unwords $ map prOpt os
|
||||
|
||||
-- * a suggestion for option names
|
||||
|
||||
-- ** parsing
|
||||
|
||||
strictParse, forgiveParse, ignoreParse, literalParse, rawParse, firstParse :: Option
|
||||
-- | parse as term instead of string
|
||||
dontParse :: Option
|
||||
|
||||
strictParse = iOpt "strict"
|
||||
forgiveParse = iOpt "n"
|
||||
ignoreParse = iOpt "ign"
|
||||
literalParse = iOpt "lit"
|
||||
rawParse = iOpt "raw"
|
||||
firstParse = iOpt "1"
|
||||
dontParse = iOpt "read"
|
||||
|
||||
newParser, newerParser, newCParser, newMParser :: Option
|
||||
newParser = iOpt "new"
|
||||
newerParser = iOpt "newer"
|
||||
newCParser = iOpt "cfg"
|
||||
newMParser = iOpt "mcfg"
|
||||
newFParser = iOpt "fcfg"
|
||||
|
||||
{-
|
||||
useParserMCFG, useParserMCFGviaCFG, useParserCFG, useParserCF :: Option
|
||||
|
||||
useParserMCFG = iOpt "mcfg"
|
||||
useParserMCFGviaCFG = iOpt "mcfg-via-cfg"
|
||||
useParserCFG = iOpt "cfg"
|
||||
useParserCF = iOpt "cf"
|
||||
-}
|
||||
|
||||
-- ** grammar formats
|
||||
|
||||
showAbstr, showXML, showOld, showLatex, showFullForm,
|
||||
showEBNF, showCF, showWords, showOpts,
|
||||
isCompiled, isHaskell, noCompOpers, retainOpers,
|
||||
noCF, checkCirc, noCheckCirc, lexerByNeed, useUTF8id :: Option
|
||||
defaultGrOpts :: [Option]
|
||||
|
||||
showAbstr = iOpt "abs"
|
||||
showXML = iOpt "xml"
|
||||
showOld = iOpt "old"
|
||||
showLatex = iOpt "latex"
|
||||
showFullForm = iOpt "fullform"
|
||||
showEBNF = iOpt "ebnf"
|
||||
showCF = iOpt "cf"
|
||||
showWords = iOpt "ws"
|
||||
showOpts = iOpt "opts"
|
||||
-- showOptim = iOpt "opt"
|
||||
isCompiled = iOpt "gfc"
|
||||
isHaskell = iOpt "gfhs"
|
||||
noCompOpers = iOpt "nocomp"
|
||||
retainOpers = iOpt "retain"
|
||||
defaultGrOpts = []
|
||||
noCF = iOpt "nocf"
|
||||
checkCirc = iOpt "nocirc"
|
||||
noCheckCirc = iOpt "nocheckcirc"
|
||||
lexerByNeed = iOpt "cflexer"
|
||||
useUTF8id = iOpt "utf8id"
|
||||
elimSubs = iOpt "subs"
|
||||
|
||||
-- ** linearization
|
||||
|
||||
allLin, firstLin, distinctLin, dontLin,
|
||||
showRecord, showStruct, xmlLin, latexLin,
|
||||
tableLin, useUTF8, showLang, withMetas :: Option
|
||||
defaultLinOpts :: [Option]
|
||||
|
||||
allLin = iOpt "all"
|
||||
firstLin = iOpt "one"
|
||||
distinctLin = iOpt "nub"
|
||||
dontLin = iOpt "show"
|
||||
showRecord = iOpt "record"
|
||||
showStruct = iOpt "structured"
|
||||
xmlLin = showXML
|
||||
latexLin = showLatex
|
||||
tableLin = iOpt "table"
|
||||
defaultLinOpts = [firstLin]
|
||||
useUTF8 = iOpt "utf8"
|
||||
showLang = iOpt "lang"
|
||||
showDefs = iOpt "defs"
|
||||
withMetas = iOpt "metas"
|
||||
|
||||
-- ** other
|
||||
|
||||
beVerbose, showInfo, beSilent, emitCode, getHelp,
|
||||
doMake, doBatch, notEmitCode, makeMulti, beShort,
|
||||
wholeGrammar, makeFudget, byLines, byWords, analMorpho,
|
||||
doTrace, noCPU, doCompute, optimizeCanon, optimizeValues,
|
||||
stripQualif, nostripQualif, showAll, fromSource :: Option
|
||||
|
||||
beVerbose = iOpt "v"
|
||||
invertGrep = iOpt "v" --- same letter in unix
|
||||
showInfo = iOpt "i"
|
||||
beSilent = iOpt "s"
|
||||
emitCode = iOpt "o"
|
||||
getHelp = iOpt "help"
|
||||
doMake = iOpt "make"
|
||||
doBatch = iOpt "batch"
|
||||
notEmitCode = iOpt "noemit"
|
||||
makeMulti = iOpt "multi"
|
||||
beShort = iOpt "short"
|
||||
wholeGrammar = iOpt "w"
|
||||
makeFudget = iOpt "f"
|
||||
byLines = iOpt "lines"
|
||||
byWords = iOpt "words"
|
||||
analMorpho = iOpt "morpho"
|
||||
doTrace = iOpt "tr"
|
||||
noCPU = iOpt "nocpu"
|
||||
doCompute = iOpt "c"
|
||||
optimizeCanon = iOpt "opt"
|
||||
optimizeValues = iOpt "val"
|
||||
stripQualif = iOpt "strip"
|
||||
nostripQualif = iOpt "nostrip"
|
||||
showAll = iOpt "all"
|
||||
showFields = iOpt "fields"
|
||||
showMulti = iOpt "multi"
|
||||
fromSource = iOpt "src"
|
||||
makeConcrete = iOpt "examples"
|
||||
fromExamples = iOpt "ex"
|
||||
openEditor = iOpt "edit"
|
||||
getTrees = iOpt "trees"
|
||||
|
||||
-- ** mainly for stand-alone
|
||||
|
||||
useUnicode, optCompute, optCheck, optParaphrase, forJava :: Option
|
||||
|
||||
useUnicode = iOpt "unicode"
|
||||
optCompute = iOpt "compute"
|
||||
optCheck = iOpt "typecheck"
|
||||
optParaphrase = iOpt "paraphrase"
|
||||
forJava = iOpt "java"
|
||||
|
||||
-- ** for edit session
|
||||
|
||||
allLangs, absView :: Option
|
||||
|
||||
allLangs = iOpt "All"
|
||||
absView = iOpt "Abs"
|
||||
|
||||
-- ** options that take arguments
|
||||
|
||||
useTokenizer, useUntokenizer, useParser, withFun,
|
||||
useLanguage, useResource, speechLanguage, useFont,
|
||||
grammarFormat, grammarPrinter, filterString, termCommand,
|
||||
transferFun, forForms, menuDisplay, sizeDisplay, typeDisplay,
|
||||
noDepTypes, extractGr, pathList, uniCoding :: String -> Option
|
||||
-- | used on command line
|
||||
firstCat :: String -> Option
|
||||
-- | used in grammar, to avoid clash w res word
|
||||
gStartCat :: String -> Option
|
||||
|
||||
useTokenizer = aOpt "lexer"
|
||||
useUntokenizer = aOpt "unlexer"
|
||||
useParser = aOpt "parser"
|
||||
-- useStrategy = aOpt "strategy" -- parsing strategy
|
||||
withFun = aOpt "fun"
|
||||
firstCat = aOpt "cat"
|
||||
gStartCat = aOpt "startcat"
|
||||
useLanguage = aOpt "lang"
|
||||
useResource = aOpt "res"
|
||||
speechLanguage = aOpt "language"
|
||||
useFont = aOpt "font"
|
||||
grammarFormat = aOpt "format"
|
||||
grammarPrinter = aOpt "printer"
|
||||
filterString = aOpt "filter"
|
||||
termCommand = aOpt "transform"
|
||||
transferFun = aOpt "transfer"
|
||||
forForms = aOpt "forms"
|
||||
menuDisplay = aOpt "menu"
|
||||
sizeDisplay = aOpt "size"
|
||||
typeDisplay = aOpt "types"
|
||||
noDepTypes = aOpt "nodeptypes"
|
||||
extractGr = aOpt "extract"
|
||||
pathList = aOpt "path"
|
||||
uniCoding = aOpt "coding"
|
||||
probFile = aOpt "probs"
|
||||
noparseFile = aOpt "noparse"
|
||||
usePreprocessor = aOpt "preproc"
|
||||
|
||||
-- peb 16/3-05:
|
||||
gfcConversion :: String -> Option
|
||||
gfcConversion = aOpt "conversion"
|
||||
|
||||
useName, useAbsName, useCncName, useResName,
|
||||
useFile, useOptimizer :: String -> Option
|
||||
|
||||
useName = aOpt "name"
|
||||
useAbsName = aOpt "abs"
|
||||
useCncName = aOpt "cnc"
|
||||
useResName = aOpt "res"
|
||||
useFile = aOpt "file"
|
||||
useOptimizer = aOpt "optimize"
|
||||
|
||||
markLin :: String -> Option
|
||||
markOptXML, markOptJava, markOptStruct, markOptFocus :: String
|
||||
|
||||
markLin = aOpt "mark"
|
||||
markOptXML = oArg "xml"
|
||||
markOptJava = oArg "java"
|
||||
markOptStruct = oArg "struct"
|
||||
markOptFocus = oArg "focus"
|
||||
|
||||
|
||||
-- ** refinement order
|
||||
|
||||
nextRefine :: String -> Option
|
||||
firstRefine, lastRefine :: String
|
||||
|
||||
nextRefine = aOpt "nextrefine"
|
||||
firstRefine = oArg "first"
|
||||
lastRefine = oArg "last"
|
||||
|
||||
-- ** Boolean flags
|
||||
|
||||
flagYes, flagNo :: String
|
||||
|
||||
flagYes = oArg "yes"
|
||||
flagNo = oArg "no"
|
||||
|
||||
-- ** integer flags
|
||||
|
||||
flagDepth, flagAlts, flagLength, flagNumber, flagRawtrees :: String -> Option
|
||||
|
||||
flagDepth = aOpt "depth"
|
||||
flagAlts = aOpt "alts"
|
||||
flagLength = aOpt "length"
|
||||
flagNumber = aOpt "number"
|
||||
flagRawtrees = aOpt "rawtrees"
|
||||
|
||||
caseYesNo :: Options -> OptFun -> Maybe Bool
|
||||
caseYesNo opts f = do
|
||||
v <- getOptVal opts f
|
||||
if v == flagYes then return True
|
||||
else if v == flagNo then return False
|
||||
else Nothing
|
||||
@@ -1,127 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/06/17 14:15:18 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.4 $
|
||||
--
|
||||
-- Pretty-printing
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Infra.Print
|
||||
(module GF.Infra.PrintClass
|
||||
) where
|
||||
|
||||
-- haskell modules:
|
||||
import Data.Char (toUpper)
|
||||
-- gf modules:
|
||||
|
||||
import GF.Infra.PrintClass
|
||||
import GF.Data.Operations (Err(..))
|
||||
import GF.Infra.Ident (Ident(..))
|
||||
import GF.Canon.AbsGFC
|
||||
import GF.CF.CF
|
||||
import GF.CF.CFIdent
|
||||
import qualified GF.Canon.PrintGFC as P
|
||||
|
||||
------------------------------------------------------------
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
instance Print Ident where
|
||||
prt = P.printTree
|
||||
|
||||
instance Print Term where
|
||||
prt (Arg arg) = prt arg
|
||||
prt (con `Par` []) = prt con
|
||||
prt (con `Par` terms) = prt con ++ "(" ++ prtSep ", " terms ++ ")"
|
||||
prt (LI ident) = "$" ++ prt ident
|
||||
prt (R record) = "{" ++ prtSep "; " record ++ "}"
|
||||
prt (term `P` lbl) = prt term ++ "." ++ prt lbl
|
||||
prt (T _ table) = "table{" ++ prtSep "; " table ++ "}"
|
||||
prt (V _ terms) = "values{" ++ prtSep "; " terms ++ "}"
|
||||
prt (term `S` sel) = "(" ++ prt term ++ " ! " ++ prt sel ++ ")"
|
||||
prt (FV terms) = "variants{" ++ prtSep " | " terms ++ "}"
|
||||
prt (term `C` term') = prt term ++ " " ++ prt term'
|
||||
prt (EInt n) = prt n
|
||||
prt (K tokn) = show (prt tokn)
|
||||
prt (E) = show ""
|
||||
|
||||
instance Print Patt where
|
||||
prt (con `PC` []) = prt con
|
||||
prt (con `PC` pats) = prt con ++ "(" ++ prtSep "," pats ++ ")"
|
||||
prt (PV ident) = "$" ++ prt ident
|
||||
prt (PW) = "_"
|
||||
prt (PR record) = "{" ++ prtSep ";" record ++ "}"
|
||||
|
||||
instance Print Label where
|
||||
prt (L ident) = prt ident
|
||||
prt (LV nr) = "$" ++ show nr
|
||||
|
||||
instance Print Tokn where
|
||||
prt (KS str) = str
|
||||
prt tokn@(KP _ _) = show tokn
|
||||
|
||||
instance Print ArgVar where
|
||||
prt (A cat argNr) = prt cat ++ "#" ++ show argNr
|
||||
|
||||
instance Print CIdent where
|
||||
prt (CIQ _ ident) = prt ident
|
||||
|
||||
instance Print Case where
|
||||
prt (pats `Cas` term) = prtSep "|" pats ++ "=>" ++ prt term
|
||||
|
||||
instance Print Assign where
|
||||
prt (lbl `Ass` term) = prt lbl ++ "=" ++ prt term
|
||||
|
||||
instance Print PattAssign where
|
||||
prt (lbl `PAss` pat) = prt lbl ++ "=" ++ prt pat
|
||||
|
||||
instance Print Atom where
|
||||
prt (AC c) = prt c
|
||||
prt (AD c) = "<" ++ prt c ++ ">"
|
||||
prt (AV i) = "$" ++ prt i
|
||||
prt (AM n) = "?" ++ show n
|
||||
prt atom = show atom
|
||||
|
||||
instance Print CType where
|
||||
prt (RecType rtype) = "{" ++ prtSep "; " rtype ++ "}"
|
||||
prt (Table ptype vtype) = "(" ++ prt ptype ++ " => " ++ prt vtype ++ ")"
|
||||
prt (Cn cn) = prt cn
|
||||
prt (TStr) = "Str"
|
||||
|
||||
instance Print Labelling where
|
||||
prt (lbl `Lbg` ctype) = prt lbl ++ ":" ++ prt ctype
|
||||
|
||||
instance Print CFItem where
|
||||
prt (CFTerm regexp) = prt regexp
|
||||
prt (CFNonterm cat) = prt cat
|
||||
|
||||
instance Print RegExp where
|
||||
prt (RegAlts words) = "("++prtSep "|" words ++ ")"
|
||||
prt (RegSpec tok) = prt tok
|
||||
|
||||
instance Print CFTok where
|
||||
prt (TS str) = str
|
||||
prt (TC (c:str)) = '(' : toUpper c : ')' : str
|
||||
prt (TL str) = show str
|
||||
prt (TI n) = "#" ++ show n
|
||||
prt (TV x) = "$" ++ prt x
|
||||
prt (TM n s) = "?" ++ show n ++ s
|
||||
|
||||
instance Print CFCat where
|
||||
prt (CFCat (cid,lbl)) = prt cid ++ "-" ++ prt lbl
|
||||
|
||||
instance Print CFFun where
|
||||
prt (CFFun fun) = prt (fst fun)
|
||||
|
||||
instance Print Exp where
|
||||
prt = P.printTree
|
||||
|
||||
instance Print a => Print (Err a) where
|
||||
prt (Ok a) = prt a
|
||||
prt (Bad str) = str
|
||||
|
||||
@@ -1,51 +0,0 @@
|
||||
module GF.Infra.PrintClass where
|
||||
|
||||
import Data.List (intersperse)
|
||||
|
||||
class Print a where
|
||||
prt :: a -> String
|
||||
prtList :: [a] -> String
|
||||
prtList as = "[" ++ prtSep "," as ++ "]"
|
||||
|
||||
prtSep :: Print a => String -> [a] -> String
|
||||
prtSep sep = concat . intersperse sep . map prt
|
||||
|
||||
prtBefore :: Print a => String -> [a] -> String
|
||||
prtBefore before = prtBeforeAfter before ""
|
||||
|
||||
prtAfter :: Print a => String -> [a] -> String
|
||||
prtAfter after = prtBeforeAfter "" after
|
||||
|
||||
prtBeforeAfter :: Print a => String -> String -> [a] -> String
|
||||
prtBeforeAfter before after as = concat [ before ++ prt a ++ after | a <- as ]
|
||||
|
||||
prtPairList :: (Print a, Print b) => String -> String -> [(a,b)] -> String
|
||||
prtPairList comma sep xys = prtSep sep [ prt x ++ comma ++ prt y | (x,y) <- xys ]
|
||||
prIO :: Print a => a -> IO ()
|
||||
prIO = putStr . prt
|
||||
|
||||
instance Print a => Print [a] where
|
||||
prt = prtList
|
||||
|
||||
instance (Print a, Print b) => Print (a, b) where
|
||||
prt (a, b) = "(" ++ prt a ++ "," ++ prt b ++ ")"
|
||||
|
||||
instance (Print a, Print b, Print c) => Print (a, b, c) where
|
||||
prt (a, b, c) = "(" ++ prt a ++ "," ++ prt b ++ "," ++ prt c ++ ")"
|
||||
|
||||
instance (Print a, Print b, Print c, Print d) => Print (a, b, c, d) where
|
||||
prt (a, b, c, d) = "(" ++ prt a ++ "," ++ prt b ++ "," ++ prt c ++ "," ++ prt d ++ ")"
|
||||
|
||||
instance Print Char where
|
||||
prt = return
|
||||
prtList = id
|
||||
|
||||
instance Print Int where
|
||||
prt = show
|
||||
|
||||
instance Print Integer where
|
||||
prt = show
|
||||
|
||||
instance Print a => Print (Maybe a) where
|
||||
prt (Just a) = prt a
|
||||
prt Nothing = "Nothing"
|
||||
@@ -1,362 +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.gfc@ or @file.gfr@ otherwise.
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Infra.ReadFiles (-- * Heading 1
|
||||
getAllFiles,fixNewlines,ModName,getOptionsFromFile,
|
||||
-- * Heading 2
|
||||
gfcFile,gfFile,gfrFile,isGFC,resModName,isOldFile
|
||||
) where
|
||||
|
||||
import GF.System.Arch (selectLater, modifiedFiles, ModTime, getModTime,laterModTime)
|
||||
|
||||
import GF.Infra.Option
|
||||
import GF.Data.Operations
|
||||
import GF.Infra.UseIO
|
||||
|
||||
import System
|
||||
import Data.Char
|
||||
import Control.Monad
|
||||
import Data.List
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
|
||||
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 gfc, or if in env; returns full file path
|
||||
|
||||
data CompStatus =
|
||||
CSComp -- compile: read gf
|
||||
| CSRead -- read gfc
|
||||
| CSEnv -- gfc is in env
|
||||
| CSEnvR -- also gfr is in env
|
||||
| CSDont -- don't read at all
|
||||
| CSRes -- read gfr
|
||||
deriving (Eq,Show)
|
||||
|
||||
-- for gfc, 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 -gfc
|
||||
mtgfc <- getModTime $ gfcFile 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 ->
|
||||
case mtenv of
|
||||
-- Just tenv | laterModTime tenv tgfc -> (CSEnv,Just tenv)
|
||||
_ -> (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 gfc is earlier than a deeper gfc
|
||||
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]
|
||||
|
||||
|
||||
-- if a compilable file depends on a resource, read gfr instead of gfc/env
|
||||
-- but don't read gfr if already in env (by CSEnvR)
|
||||
-- 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 -> gfcFile
|
||||
CSRes -> gfrFile
|
||||
|
||||
isGFC :: FilePath -> Bool
|
||||
isGFC = (== ".gfc") . takeExtensions
|
||||
|
||||
gfcFile :: FilePath -> FilePath
|
||||
gfcFile f = addExtension f "gfc"
|
||||
|
||||
gfrFile :: FilePath -> FilePath
|
||||
gfrFile f = addExtension f "gfr"
|
||||
|
||||
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
|
||||
let file_gfr = gfrFile name
|
||||
bb <- doesFileExistPath ps file_gfr -- gfr file next
|
||||
if bb then return file_gfr else do
|
||||
return (gfcFile name) -- gfc 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
|
||||
|
||||
@@ -1,330 +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.Infra.UseIO where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.System.Arch (prCPU)
|
||||
import GF.Infra.Option
|
||||
import GF.Today (libdir)
|
||||
|
||||
import System.Directory
|
||||
import System.IO
|
||||
import System.IO.Error
|
||||
import System.Environment
|
||||
import System.FilePath
|
||||
import Control.Monad
|
||||
|
||||
#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
|
||||
|
||||
prOptCPU :: Options -> Integer -> IO Integer
|
||||
prOptCPU opts = if (oElem noCPU opts) then (const (return 0)) else prCPU
|
||||
|
||||
putCPU :: IO ()
|
||||
putCPU = do
|
||||
prCPU 0
|
||||
return ()
|
||||
|
||||
putPoint :: Show a => Options -> String -> IO a -> IO a
|
||||
putPoint = putPoint' id
|
||||
|
||||
putPoint' :: Show a => (c -> a) -> Options -> String -> IO c -> IO c
|
||||
putPoint' f opts msg act = do
|
||||
let sil x = if oElem beSilent opts then return () else x
|
||||
ve x = if oElem beVerbose opts then x else return ()
|
||||
ve $ putStrLn msg
|
||||
a <- act
|
||||
ve $ putShow' f a
|
||||
ve $ putCPU
|
||||
return a
|
||||
|
||||
readFileStrict :: String -> IO String
|
||||
readFileStrict f = do
|
||||
s <- readFile f
|
||||
return $ seq (length s) ()
|
||||
return s
|
||||
|
||||
readFileIf = readFileIfs readFile
|
||||
readFileIfStrict = readFileIfs readFileStrict
|
||||
|
||||
readFileIfs rf f = catch (rf f) (\_ -> reportOn f) where
|
||||
reportOn f = do
|
||||
putStrLnFlush ("File " ++ f ++ " does not exist. Returned empty string")
|
||||
return ""
|
||||
|
||||
type FileName = String
|
||||
type InitPath = String
|
||||
type FullPath = String
|
||||
|
||||
getFilePath :: [FilePath] -> String -> IO (Maybe FilePath)
|
||||
getFilePath ps file = do
|
||||
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 exist then return (Just pfile) else get ps
|
||||
--- catch (readFileStrict pfile >> return (Just pfile)) (\_ -> get ps)
|
||||
|
||||
readFileIfPath :: [FilePath] -> String -> IOE (FilePath,String)
|
||||
readFileIfPath paths file = do
|
||||
mpfile <- ioeIO $ getFilePath paths file
|
||||
case mpfile of
|
||||
Just pfile -> do
|
||||
s <- ioeIO $ readFileStrict 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"
|
||||
|
||||
-- | environment variable for grammar search 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
|
||||
a <- act
|
||||
--- ve $ ioeIO $ putShow' id a --- replace by a statistics command
|
||||
ve $ ioeIO $ putStrFlush " "
|
||||
ve $ ioeIO $ putCPU
|
||||
return a
|
||||
{-
|
||||
putPointE :: Options -> String -> IOE a -> IOE a
|
||||
putPointE opts msg act = do
|
||||
let ve x = if oElem beVerbose opts then x else return ()
|
||||
ve $ putStrE msg
|
||||
a <- act
|
||||
--- ve $ ioeIO $ putShow' id a --- replace by a statistics command
|
||||
ve $ ioeIO $ putCPU
|
||||
return a
|
||||
-}
|
||||
|
||||
-- | forces verbosity
|
||||
putPointEVerb :: Options -> String -> IOE a -> IOE a
|
||||
putPointEVerb opts = putPointE (addOption beVerbose opts)
|
||||
|
||||
-- ((do {s <- readFile f; return (return s)}) )
|
||||
readFileIOE :: FilePath -> IOE (String)
|
||||
readFileIOE f = ioe $ catch (readFileStrict 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, String)
|
||||
readFileLibraryIOE ini f = ioe $ do
|
||||
lp <- getLibraryPath
|
||||
tryRead ini $ \_ ->
|
||||
tryRead lp $ \e ->
|
||||
return (Bad (show e))
|
||||
where
|
||||
tryRead path onError =
|
||||
catch (readFileStrict 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
|
||||
|
||||
Reference in New Issue
Block a user