msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

ModuleName and Ident are now distinct types

Browse Source 
This makes the documentation clearer, and can potentially catch more
programming mistakes.
This commit is contained in:
hallgren
2014-10-21 19:20:31 +00:00
parent 3bfcfa157d
commit 391b301881
24 changed files with 156 additions and 132 deletions
Download Patch File Download Diff File Expand all files Collapse all files

21
src/compiler/GF/Grammar/Analyse.hs
View File

@@ -10,6 +10,7 @@ module GF.Grammar.Analyse (
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Text.Pretty(render)
--import GF.Infra.Option ---
import GF.Grammar.Macros
import GF.Grammar.Lookup
@@ -20,7 +21,7 @@ import qualified Data.Map as Map
import Data.List (nub)
--import Debug.Trace
stripSourceGrammar :: SourceGrammar -> SourceGrammar
stripSourceGrammar :: Grammar -> Grammar
stripSourceGrammar sgr = mGrammar [(i, m{jments = Map.map stripInfo (jments m)}) | (i,m) <- modules sgr]
stripInfo :: Info -> Info
@@ -42,7 +43,7 @@ constantsInTerm = nub . consts where
QC c -> [c]
_ -> collectOp consts t
constantDeps :: SourceGrammar -> QIdent -> Err [QIdent]
constantDeps :: Grammar -> QIdent -> Err [QIdent]
constantDeps sgr f = return $ nub $ iterFix more start where
start = constants f
more = concatMap constants
@@ -54,23 +55,23 @@ getIdTerm :: Term -> Err QIdent
getIdTerm t = case t of
Q i -> return i
QC i -> return i
P (Vr r) l -> return (r,label2ident l) --- needed if term is received from parser
P (Vr r) l -> return (MN r,label2ident l) --- needed if term is received from parser
_ -> Bad ("expected qualified constant, not " ++ show t)
constantDepsTerm :: SourceGrammar -> Term -> Err [Term]
constantDepsTerm :: Grammar -> Term -> Err [Term]
constantDepsTerm sgr t = do
i <- getIdTerm t
cs <- constantDeps sgr i
return $ map Q cs --- losing distinction Q/QC
termsOfConstant :: SourceGrammar -> QIdent -> Err [Term]
termsOfConstant :: Grammar -> QIdent -> Err [Term]
termsOfConstant sgr c = case lookupOverload sgr c of
Ok tts -> return $ concat [[ty,tr] | (_,(ty,tr)) <- tts]
_ -> return $
[ty | Ok ty <- [lookupResType sgr c]] ++ -- type sig may be missing
[ty | Ok ty <- [lookupResDef sgr c]]
sizeConstant :: SourceGrammar -> Term -> Int
sizeConstant :: Grammar -> Term -> Int
sizeConstant sgr t = err (const 0) id $ do
c <- getIdTerm t
fmap (sum . map sizeTerm) $ termsOfConstant sgr c
@@ -131,20 +132,20 @@ sizesModule (_,m) =
in (length tb + sum (map snd tb),tb)
-- the size of a grammar
sizeGrammar :: SourceGrammar -> Int
sizeGrammar :: Grammar -> Int
sizeGrammar = fst . sizesGrammar
sizesGrammar :: SourceGrammar -> (Int,[(Ident,(Int,[(Ident,Int)]))])
sizesGrammar :: Grammar -> (Int,[(ModuleName,(Int,[(Ident,Int)]))])
sizesGrammar g =
let
ms = modules g
mz = [(i,sizesModule m) | m@(i,j) <- ms]
in (length mz + sum (map (fst . snd) mz), mz)
printSizesGrammar :: SourceGrammar -> String
printSizesGrammar :: Grammar -> String
printSizesGrammar g = unlines $
("total" +++ show s):
[showIdent m +++ "total" +++ show i ++++
[render m +++ "total" +++ show i ++++
unlines [indent 2 (showIdent j +++ show k) | (j,k) <- js]
| (m,(i,js)) <- sg
]

4
src/compiler/GF/Grammar/Binary.hs
View File

@@ -37,6 +37,10 @@ instance Binary Ident where
then return identW
else return (identC (rawIdentC bs))
instance Binary ModuleName where
put (MN id) = put id
get = fmap MN get
instance Binary Grammar where
put = put . modules
get = fmap mGrammar get

20
src/compiler/GF/Grammar/Grammar.hs
View File

@@ -80,13 +80,13 @@ import qualified Data.Map as Map
import GF.Text.Pretty
-- ^ A grammar is a self-contained collection of grammar modules
-- | A grammar is a self-contained collection of grammar modules
data Grammar = MGrammar {
moduleMap :: Map.Map ModuleName ModuleInfo,
modules :: [Module]
}
type ModuleName = Ident
-- | Modules
type Module = (ModuleName, ModuleInfo)
data ModuleInfo = ModInfo {
@@ -96,7 +96,7 @@ data ModuleInfo = ModInfo {
mextend :: [(ModuleName,MInclude)],
mwith :: Maybe (ModuleName,MInclude,[(ModuleName,ModuleName)]),
mopens :: [OpenSpec],
mexdeps :: [Ident],
mexdeps :: [ModuleName],
msrc :: FilePath,
mseqs :: Maybe (Array SeqId Sequence),
jments :: Map.Map Ident Info
@@ -112,9 +112,9 @@ instance HasSourcePath ModuleInfo where sourcePath = msrc
data ModuleType =
MTAbstract
| MTResource
| MTConcrete Ident
| MTConcrete ModuleName
| MTInterface
| MTInstance (Ident,MInclude)
| MTInstance (ModuleName,MInclude)
deriving (Eq,Show)
data MInclude = MIAll | MIOnly [Ident] | MIExcept [Ident]
@@ -142,7 +142,7 @@ data ModuleStatus =
| MSIncomplete
deriving (Eq,Ord,Show)
openedModule :: OpenSpec -> Ident
openedModule :: OpenSpec -> ModuleName
openedModule o = case o of
OSimple m -> m
OQualif _ m -> m
@@ -167,14 +167,14 @@ allDepsModule gr m = iterFix add os0 where
mods = modules gr
-- | select just those modules that a given one depends on, including itself
partOfGrammar :: Grammar -> (Ident,ModuleInfo) -> Grammar
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
-- | all modules that a module extends, directly or indirectly, with restricts
allExtends :: Grammar -> Ident -> [Module]
allExtends :: Grammar -> ModuleName -> [Module]
allExtends gr m =
case lookupModule gr m of
Ok mi -> (m,mi) : concatMap (allExtends gr . fst) (mextend mi)
@@ -331,14 +331,14 @@ data Info =
| ResValue (L Type) -- ^ (/RES/) to mark parameter constructors for lookup
| ResOper (Maybe (L Type)) (Maybe (L Term)) -- ^ (/RES/)
| ResOverload [Ident] [(L Type,L Term)] -- ^ (/RES/) idents: modules inherited
| ResOverload [ModuleName] [(L Type,L Term)] -- ^ (/RES/) idents: modules inherited
-- judgements in concrete syntax
| CncCat (Maybe (L Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) lindef ini'zed,
| CncFun (Maybe (Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) type info added at 'TC'
-- indirection to module Ident
| AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical
| AnyInd Bool ModuleName -- ^ (/INDIR/) the 'Bool' says if canonical
deriving Show
type Type = Term

28
src/compiler/GF/Grammar/Lookup.hs
View File

@@ -59,10 +59,10 @@ lookupIdent c t =
lookupIdentInfo :: ErrorMonad m => SourceModInfo -> Ident -> m Info
lookupIdentInfo mo i = lookupIdent i (jments mo)
lookupQIdentInfo :: ErrorMonad m => SourceGrammar -> QIdent -> m Info
lookupQIdentInfo :: ErrorMonad m => Grammar -> QIdent -> m Info
lookupQIdentInfo gr (m,c) = flip lookupIdentInfo c =<< lookupModule gr m
lookupResDef :: ErrorMonad m => SourceGrammar -> QIdent -> m Term
lookupResDef :: ErrorMonad m => Grammar -> QIdent -> m Term
lookupResDef gr x = fmap unLoc (lookupResDefLoc gr x)
lookupResDefLoc gr (m,c)
@@ -85,7 +85,7 @@ lookupResDefLoc gr (m,c)
ResValue _ -> return (noLoc (QC (m,c)))
_ -> raise $ render (c <+> "is not defined in resource" <+> m)
lookupResType :: ErrorMonad m => SourceGrammar -> QIdent -> m Type
lookupResType :: ErrorMonad m => Grammar -> QIdent -> m Type
lookupResType gr (m,c) = do
info <- lookupQIdentInfo gr (m,c)
case info of
@@ -101,7 +101,7 @@ lookupResType gr (m,c) = do
ResValue (L _ t) -> return t
_ -> raise $ render (c <+> "has no type defined in resource" <+> m)
lookupOverload :: ErrorMonad m => SourceGrammar -> QIdent -> m [([Type],(Type,Term))]
lookupOverload :: ErrorMonad m => Grammar -> QIdent -> m [([Type],(Type,Term))]
lookupOverload gr (m,c) = do
info <- lookupQIdentInfo gr (m,c)
case info of
@@ -115,26 +115,26 @@ lookupOverload gr (m,c) = do
_ -> raise $ render (c <+> "is not an overloaded operation")
-- | returns the original 'Info' and the module where it was found
lookupOrigInfo :: ErrorMonad m => SourceGrammar -> QIdent -> m (Ident,Info)
lookupOrigInfo :: ErrorMonad m => Grammar -> QIdent -> m (ModuleName,Info)
lookupOrigInfo gr (m,c) = do
info <- lookupQIdentInfo gr (m,c)
case info of
AnyInd _ n -> lookupOrigInfo gr (n,c)
i -> return (m,i)
allOrigInfos :: SourceGrammar -> Ident -> [(QIdent,Info)]
allOrigInfos :: Grammar -> ModuleName -> [(QIdent,Info)]
allOrigInfos gr m = fromErr [] $ do
mo <- lookupModule gr m
return [((m,c),i) | (c,_) <- tree2list (jments mo), Ok (m,i) <- [lookupOrigInfo gr (m,c)]]
lookupParamValues :: ErrorMonad m => SourceGrammar -> QIdent -> m [Term]
lookupParamValues :: ErrorMonad m => Grammar -> QIdent -> m [Term]
lookupParamValues gr c = do
(_,info) <- lookupOrigInfo gr c
case info of
ResParam _ (Just pvs) -> return pvs
_ -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined")
allParamValues :: ErrorMonad m => SourceGrammar -> Type -> m [Term]
allParamValues :: ErrorMonad m => Grammar -> Type -> m [Term]
allParamValues cnc ptyp =
case ptyp of
_ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]]
@@ -153,7 +153,7 @@ allParamValues cnc ptyp =
-- to normalize records and record types
sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
lookupAbsDef :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m (Maybe Int,Maybe [Equation])
lookupAbsDef :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m (Maybe Int,Maybe [Equation])
lookupAbsDef gr m c = errIn (render ("looking up absdef of" <+> c)) $ do
info <- lookupQIdentInfo gr (m,c)
case info of
@@ -161,7 +161,7 @@ lookupAbsDef gr m c = errIn (render ("looking up absdef of" <+> c)) $ do
AnyInd _ n -> lookupAbsDef gr n c
_ -> return (Nothing,Nothing)
lookupLincat :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Type
lookupLincat :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m Type
lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
lookupLincat gr m c = do
info <- lookupQIdentInfo gr (m,c)
@@ -171,7 +171,7 @@ lookupLincat gr m c = do
_ -> raise (render (c <+> "has no linearization type in" <+> m))
-- | this is needed at compile time
lookupFunType :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Type
lookupFunType :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m Type
lookupFunType gr m c = do
info <- lookupQIdentInfo gr (m,c)
case info of
@@ -180,7 +180,7 @@ lookupFunType gr m c = do
_ -> raise (render ("cannot find type of" <+> c))
-- | this is needed at compile time
lookupCatContext :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Context
lookupCatContext :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m Context
lookupCatContext gr m c = do
info <- lookupQIdentInfo gr (m,c)
case info of
@@ -192,7 +192,7 @@ lookupCatContext gr m c = do
-- this gives all opers and param constructors, also overloaded opers and funs, and the types, and locations
-- notice that it only gives the modules that are reachable and the opers that are included
allOpers :: SourceGrammar -> [((Ident,Ident),Type,Location)]
allOpers :: Grammar -> [(QIdent,Type,Location)]
allOpers gr =
[((m,op),typ,loc) |
(m,mi) <- maybe [] (allExtends gr) (greatestResource gr),
@@ -214,7 +214,7 @@ allOpers gr =
_ -> typ
--- not for dependent types
allOpersTo :: SourceGrammar -> Type -> [((Ident,Ident),Type,Location)]
allOpersTo :: Grammar -> Type -> [(QIdent,Type,Location)]
allOpersTo gr ty = [op | op@(_,typ,_) <- allOpers gr, isProdTo ty typ] where
isProdTo t typ = eqProd typ t || case typ of
Prod _ _ a b -> isProdTo t b

2
src/compiler/GF/Grammar/MMacros.hs
View File

@@ -230,7 +230,7 @@ identVar _ = Bad "not a variable"
-- | light-weight rename for user interaction; also change names of internal vars
qualifTerm :: Ident -> Term -> Term
qualifTerm :: ModuleName -> Term -> Term
qualifTerm m = qualif [] where
qualif xs t = case t of
Abs b x t -> let x' = chV x in Abs b x' $ qualif (x':xs) t

6
src/compiler/GF/Grammar/Macros.hs
View File

@@ -46,7 +46,7 @@ typeForm t =
in ([],cat,args ++ [a])
Q c -> ([],c,[])
QC c -> ([],c,[])
Sort c -> ([],(identW, c),[])
Sort c -> ([],(MN identW, c),[])
_ -> error (render ("no normal form of type" <+> ppTerm Unqualified 0 t))
typeFormCnc :: Type -> (Context, Type)
@@ -416,7 +416,7 @@ patt2term pt = case pt of
PNeg a -> appCons cNeg [(patt2term a)] --- an encoding
redirectTerm :: Ident -> Term -> Term
redirectTerm :: ModuleName -> Term -> Term
redirectTerm n t = case t of
QC (_,f) -> QC (n,f)
Q (_,f) -> Q (n,f)
@@ -588,7 +588,7 @@ sortRec = sortBy ordLabel where
-- | dependency check, detecting circularities and returning topo-sorted list
allDependencies :: (Ident -> Bool) -> BinTree Ident Info -> [(Ident,[Ident])]
allDependencies :: (ModuleName -> Bool) -> BinTree Ident Info -> [(Ident,[Ident])]
allDependencies ism b =
[(f, nub (concatMap opty (pts i))) | (f,i) <- tree2list b]
where

51
src/compiler/GF/Grammar/Parser.y
View File

@@ -140,16 +140,16 @@ ComplMod
: {- empty -} { MSComplete }
| 'incomplete' { MSIncomplete }
ModType :: { (ModuleType,Ident) }
ModType :: { (ModuleType,ModuleName) }
ModType
: 'abstract' Ident { (MTAbstract, $2) }
| 'resource' Ident { (MTResource, $2) }
| 'interface' Ident { (MTInterface, $2) }
| 'concrete' Ident 'of' Ident { (MTConcrete $4, $2) }
| 'instance' Ident 'of' Included { (MTInstance $4, $2) }
: 'abstract' ModuleName { (MTAbstract, $2) }
| 'resource' ModuleName { (MTResource, $2) }
| 'interface' ModuleName { (MTInterface, $2) }
| 'concrete' ModuleName 'of' ModuleName { (MTConcrete $4, $2) }
| 'instance' ModuleName 'of' Included { (MTInstance $4, $2) }
ModHeaderBody :: { ( [(Ident,MInclude)]
, Maybe (Ident,MInclude,[(Ident,Ident)])
ModHeaderBody :: { ( [(ModuleName,MInclude)]
, Maybe (ModuleName,MInclude,[(ModuleName,ModuleName)])
, [OpenSpec]
) }
ModHeaderBody
@@ -166,8 +166,8 @@ ModOpen
: { [] }
| 'open' ListOpen { $2 }
ModBody :: { ( [(Ident,MInclude)]
, Maybe (Ident,MInclude,[(Ident,Ident)])
ModBody :: { ( [(ModuleName,MInclude)]
, Maybe (ModuleName,MInclude,[(ModuleName,ModuleName)])
, Maybe ([OpenSpec],[(Ident,Info)],Options)
) }
ModBody
@@ -197,28 +197,28 @@ ListOpen
Open :: { OpenSpec }
Open
: Ident { OSimple $1 }
| '(' Ident '=' Ident ')' { OQualif $2 $4 }
: ModuleName { OSimple $1 }
| '(' ModuleName '=' ModuleName ')' { OQualif $2 $4 }
ListInst :: { [(Ident,Ident)] }
ListInst :: { [(ModuleName,ModuleName)] }
ListInst
: Inst { [$1] }
| Inst ',' ListInst { $1 : $3 }
Inst :: { (Ident,Ident) }
Inst :: { (ModuleName,ModuleName) }
Inst
: '(' Ident '=' Ident ')' { ($2,$4) }
: '(' ModuleName '=' ModuleName ')' { ($2,$4) }
ListIncluded :: { [(Ident,MInclude)] }
ListIncluded :: { [(ModuleName,MInclude)] }
ListIncluded
: Included { [$1] }
| Included ',' ListIncluded { $1 : $3 }
Included :: { (Ident,MInclude) }
Included :: { (ModuleName,MInclude) }
Included
: Ident { ($1,MIAll ) }
| Ident '[' ListIdent ']' { ($1,MIOnly $3) }
| Ident '-' '[' ListIdent ']' { ($1,MIExcept $4) }
: ModuleName { ($1,MIAll ) }
| ModuleName '[' ListIdent ']' { ($1,MIOnly $3) }
| ModuleName '-' '[' ListIdent ']' { ($1,MIExcept $4) }
TopDef :: { Either [(Ident,Info)] Options }
TopDef
@@ -485,7 +485,7 @@ Patt
Patt1 :: { Patt }
Patt1
: Ident ListPatt { PC $1 $2 }
| Ident '.' Ident ListPatt { PP ($1,$3) $4 }
| ModuleName '.' Ident ListPatt { PP ($1,$3) $4 }
| Patt3 '*' { PRep $1 }
| Patt2 { $1 }
@@ -501,10 +501,10 @@ Patt3
: '?' { PChar }
| '[' String ']' { PChars $2 }
| '#' Ident { PMacro $2 }
| '#' Ident '.' Ident { PM ($2,$4) }
| '#' ModuleName '.' Ident { PM ($2,$4) }
| '_' { PW }
| Ident { PV $1 }
| Ident '.' Ident { PP ($1,$3) [] }
| ModuleName '.' Ident { PP ($1,$3) [] }
| Integer { PInt $1 }
| Double { PFloat $1 }
| String { PString $1 }
@@ -675,6 +675,9 @@ ERHS3 :: { ERHS }
| Ident { ENonTerm (showIdent $1,[]) }
| '(' ERHS0 ')' { $2 }
ModuleName :: { ModuleName }
: Ident { MN $1 }
Posn :: { Posn }
Posn
: {- empty -} {% getPosn }
@@ -730,7 +733,7 @@ mkOverload pdt pdf@(Just (L loc df)) =
case appForm df of
(keyw, ts@(_:_)) | isOverloading keyw ->
case last ts of
R fs -> [ResOverload [m | Vr m <- ts] [(L loc ty,L loc fu) | (_,(Just ty,fu)) <- fs]]
R fs -> [ResOverload [MN m | Vr m <- ts] [(L loc ty,L loc fu) | (_,(Just ty,fu)) <- fs]]
_ -> [ResOper pdt pdf]
_ -> [ResOper pdt pdf]

8
src/compiler/GF/Grammar/Predef.hs
View File

@@ -10,16 +10,16 @@
module GF.Grammar.Predef where
import GF.Infra.Ident(Ident,identS)
import GF.Infra.Ident(Ident,identS,moduleNameS)
cType = identS "Type"
cPType = identS "PType"
cTok = identS "Tok"
cStr = identS "Str"
cStrs = identS "Strs"
cPredefAbs = identS "PredefAbs"
cPredefCnc = identS "PredefCnc"
cPredef = identS "Predef"
cPredefAbs = moduleNameS "PredefAbs"
cPredefCnc = moduleNameS "PredefCnc"
cPredef = moduleNameS "Predef"
cInt = identS "Int"
cFloat = identS "Float"
cString = identS "String"