module GF.Grammar.Grammar (
Grammar, ModuleName, Module, ModuleInfo(..),
SourceGrammar, SourceModInfo, SourceModule,
ModuleType(..),
emptyGrammar, mGrammar, modules, prependModule, moduleMap,
MInclude (..), OpenSpec(..),
extends, isInherited, inheritAll,
openedModule, allDepsModule, partOfGrammar, depPathModule,
allExtends, allExtendsPlus, --searchPathModule,
lookupModule,
isModAbs, isModRes, isModCnc,
sameMType, isCompilableModule, isCompleteModule,
allAbstracts, greatestAbstract, allResources,
greatestResource, allConcretes, allConcreteModules,
abstractOfConcrete,
ModuleStatus(..),
Info(..),
Term(..),
Type,
Cat,
Fun,
QIdent,
BindType(..),
Patt(..),
TInfo(..),
Label(..),
MetaId,
Hypo,
Context,
Equation,
Labelling,
Assign,
Case,
LocalDef,
Param,
Altern,
Substitution,
varLabel, tupleLabel, linLabel, theLinLabel,
ident2label, label2ident,
Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
PMCFG(..), Production(..), FId, FunId, SeqId, LIndex, Sequence
) where
import GF.Infra.Ident
import GF.Infra.Option
import GF.Infra.Location
import GF.Data.Operations
import PGF.Internal (FId, FunId, SeqId, LIndex, Sequence, BindType(..))
import Data.Array.IArray(Array)
import Data.Array.Unboxed(UArray)
import qualified Data.Map as Map
import GF.Text.Pretty
data Grammar = MGrammar {
moduleMap :: Map.Map ModuleName ModuleInfo,
modules :: [Module]
}
type Module = (ModuleName, ModuleInfo)
data ModuleInfo = ModInfo {
mtype :: ModuleType,
mstatus :: ModuleStatus,
mflags :: Options,
mextend :: [(ModuleName,MInclude)],
mwith :: Maybe (ModuleName,MInclude,[(ModuleName,ModuleName)]),
mopens :: [OpenSpec],
mexdeps :: [ModuleName],
msrc :: FilePath,
mseqs :: Maybe (Array SeqId Sequence),
jments :: Map.Map Ident Info
}
type SourceGrammar = Grammar
type SourceModule = Module
type SourceModInfo = ModuleInfo
instance HasSourcePath ModuleInfo where sourcePath = msrc
data ModuleType =
MTAbstract
| MTResource
| MTConcrete ModuleName
| MTInterface
| MTInstance (ModuleName,MInclude)
deriving (Eq,Show)
data MInclude = MIAll | MIOnly [Ident] | MIExcept [Ident]
deriving (Eq,Show)
extends :: ModuleInfo -> [ModuleName]
extends = map fst . mextend
isInherited :: MInclude -> Ident -> Bool
isInherited c i = case c of
MIAll -> True
MIOnly is -> elem i is
MIExcept is -> notElem i is
inheritAll :: ModuleName -> (ModuleName,MInclude)
inheritAll i = (i,MIAll)
data OpenSpec =
OSimple ModuleName
| OQualif ModuleName ModuleName
deriving (Eq,Show)
data ModuleStatus =
MSComplete
| MSIncomplete
deriving (Eq,Ord,Show)
openedModule :: OpenSpec -> ModuleName
openedModule o = case o of
OSimple m -> m
OQualif _ m -> m
depPathModule :: ModuleInfo -> [OpenSpec]
depPathModule m = fors m ++ exts m ++ mopens m
where
fors m =
case mtype m of
MTConcrete i -> [OSimple i]
MTInstance (i,_) -> [OSimple i]
_ -> []
exts m = map OSimple (extends m)
allDepsModule :: Grammar -> ModuleInfo -> [OpenSpec]
allDepsModule gr m = iterFix add os0 where
os0 = depPathModule m
add os = [m | o <- os, Just n <- [lookup (openedModule o) mods],
m <- depPathModule n]
mods = modules gr
partOfGrammar :: Grammar -> Module -> Grammar
partOfGrammar gr (i,m) = mGrammar [mo | mo@(j,_) <- mods, elem j modsFor]
where
mods = modules gr
modsFor = (i:) $ map openedModule $ allDepsModule gr m
allExtends :: Grammar -> ModuleName -> [Module]
allExtends gr m =
case lookupModule gr m of
Ok mi -> (m,mi) : concatMap (allExtends gr . fst) (mextend mi)
_ -> []
allExtendsPlus :: Grammar -> ModuleName -> [ModuleName]
allExtendsPlus gr i =
case lookupModule gr i of
Ok m -> i : concatMap (allExtendsPlus gr) (exts m)
_ -> []
where
exts m = extends m ++ [j | MTInstance (j,_) <- [mtype m]]
prependModule :: Grammar -> Module -> Grammar
prependModule (MGrammar mm ms) im@(i,m) = MGrammar (Map.insert i m mm) (im:ms)
emptyGrammar = mGrammar []
mGrammar :: [Module] -> Grammar
mGrammar ms = MGrammar (Map.fromList ms) ms
abstractOfConcrete :: ErrorMonad m => Grammar -> ModuleName -> m ModuleName
abstractOfConcrete gr c = do
n <- lookupModule gr c
case mtype n of
MTConcrete a -> return a
_ -> raise $ render ("expected concrete" <+> c)
lookupModule :: ErrorMonad m => Grammar -> ModuleName -> m ModuleInfo
lookupModule gr m = case Map.lookup m (moduleMap gr) of
Just i -> return i
Nothing -> raise $ render ("unknown module" <+> m <+> "among" <+> hsep (map fst (modules gr)))
isModAbs :: ModuleInfo -> Bool
isModAbs m =
case mtype m of
MTAbstract -> True
_ -> False
isModRes :: ModuleInfo -> Bool
isModRes m =
case mtype m of
MTResource -> True
MTInterface -> True
MTInstance _ -> True
_ -> False
isModCnc :: ModuleInfo -> Bool
isModCnc m =
case mtype m of
MTConcrete _ -> True
_ -> False
sameMType :: ModuleType -> ModuleType -> 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
(MTInterface, MTAbstract) -> True
(MTInterface, MTConcrete _) -> True
(MTResource, MTInstance _) -> True
(MTResource, MTConcrete _) -> True
_ -> m == n
isCompilableModule :: ModuleInfo -> Bool
isCompilableModule m =
case mtype m of
MTInterface -> False
_ -> mstatus m == MSComplete
isCompleteModule :: ModuleInfo -> Bool
isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface
allAbstracts :: Grammar -> [ModuleName]
allAbstracts gr =
case topoTest [(i,extends m) | (i,m) <- modules gr, mtype m == MTAbstract] of
Left is -> is
Right cycles -> error $ render ("Cyclic abstract modules:" <+> vcat (map hsep cycles))
greatestAbstract :: Grammar -> Maybe ModuleName
greatestAbstract gr =
case allAbstracts gr of
[] -> Nothing
as -> return $ last as
allResources :: Grammar -> [ModuleName]
allResources gr = [i | (i,m) <- modules gr, isModRes m || isModCnc m]
greatestResource :: Grammar -> Maybe ModuleName
greatestResource gr =
case allResources gr of
[] -> Nothing
mo:_ -> Just mo
allConcretes :: Grammar -> ModuleName -> [ModuleName]
allConcretes gr a =
[i | (i, m) <- modules gr, mtype m == MTConcrete a, isCompleteModule m]
allConcreteModules :: Grammar -> [ModuleName]
allConcreteModules gr =
[i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]
data Production = Production !FId
!FunId
[[FId]]
deriving (Eq,Ord,Show)
data PMCFG = PMCFG [Production]
(Array FunId (UArray LIndex SeqId))
deriving (Eq,Show)
data Info =
AbsCat (Maybe (L Context))
| AbsFun (Maybe (L Type)) (Maybe Int) (Maybe [L Equation]) (Maybe Bool)
| ResParam (Maybe (L [Param])) (Maybe [Term])
| ResValue (L Type)
| ResOper (Maybe (L Type)) (Maybe (L Term))
| ResOverload [ModuleName] [(L Type,L Term)]
| CncCat (Maybe (L Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG)
| CncFun (Maybe (Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG)
| AnyInd Bool ModuleName
deriving Show
type Type = Term
type Cat = QIdent
type Fun = QIdent
type QIdent = (ModuleName,Ident)
data Term =
Vr Ident
| Cn Ident
| Con Ident
| Sort Ident
| EInt Int
| EFloat Double
| K String
| Empty
| App Term Term
| Abs BindType Ident Term
| Meta !MetaId
| ImplArg Term
| Prod BindType Ident Term Term
| Typed Term Term
| Example Term String
| RecType [Labelling]
| R [Assign]
| P Term Label
| ExtR Term Term
| Table Term Term
| T TInfo [Case]
| V Type [Term]
| S Term Term
| Let LocalDef Term
| Q QIdent
| QC QIdent
| C Term Term
| Glue Term Term
| EPatt Patt
| EPattType Term
| ELincat Ident Term
| ELin Ident Term
| AdHocOverload [Term]
| FV [Term]
| Alts Term [(Term, Term)]
| Strs [Term]
| Error String
deriving (Show, Eq, Ord)
data Patt =
PC Ident [Patt]
| PP QIdent [Patt]
| PV Ident
| PW
| PR [(Label,Patt)]
| PString String
| PInt Int
| PFloat Double
| PT Type Patt
| PAs Ident Patt
| PImplArg Patt
| PTilde Term
| PNeg Patt
| PAlt Patt Patt
| PSeq Patt Patt
| PMSeq MPatt MPatt
| PRep Patt
| PChar
| PChars [Char]
| PMacro Ident
| PM QIdent
deriving (Show, Eq, Ord)
type MPatt = ((Int,Int),Patt)
data TInfo =
TRaw
| TTyped Type
| TComp Type
| TWild Type
deriving (Show, Eq, Ord)
data Label =
LIdent RawIdent
| LVar Int
deriving (Show, Eq, Ord)
type MetaId = Int
type Hypo = (BindType,Ident,Term)
type Context = [Hypo]
type Equation = ([Patt],Term)
type Labelling = (Label, Type)
type Assign = (Label, (Maybe Type, Term))
type Case = (Patt, Term)
type LocalDef = (Ident, (Maybe Type, Term))
type Param = (Ident, Context)
type Altern = (Term, [(Term, Term)])
type Substitution = [(Ident, Term)]
varLabel :: Int -> Label
varLabel = LVar
tupleLabel, linLabel :: Int -> Label
tupleLabel i = LIdent $! rawIdentS ('p':show i)
linLabel i = LIdent $! rawIdentS ('s':show i)
theLinLabel :: Label
theLinLabel = LIdent (rawIdentS "s")
ident2label :: Ident -> Label
ident2label c = LIdent (ident2raw c)
label2ident :: Label -> Ident
label2ident (LIdent s) = identC s
label2ident (LVar i) = identS ('$':show i)