GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 03:32:51 -06:00
Code Issues Packages Projects Releases Wiki Activity

Introducing GF.Text.Pretty for more concise pretty printers and GF.Infra.Location for modularity

Browse Source 
GF.Text.Pretty provides the class Pretty and overloaded versions of the pretty
printing combinators in Text.PrettyPrint, allowing pretty printable values to
be used directly instead of first having to convert them to Doc with functions
like text, int, char and ppIdent. Some modules have been converted to use
GF.Text.Pretty, but not all. Precedences could be added to simplify the pretty
printers for terms and patterns.

GF.Infra.Location contains the types Location and L, factored out from
GF.Grammar.Grammar, and the class HasSourcePath. This allowed the import
of GF.Grammar.Grammar to be removed from GF.Infra.CheckM, making it more
like a pure library module.
This commit is contained in:
hallgren
2014-07-27 22:06:23 +00:00
parent 7eaea44386
commit 30cda51516
22 changed files with 422 additions and 451 deletions
Download Patch File Download Diff File Expand all files Collapse all files

28
src/compiler/GF/Command/Commands.hs
View File

@@ -47,7 +47,7 @@ import Data.Maybe
import qualified Data.Map as Map import qualified Data.Map as Map
--import System.Cmd(system) -- use GF.Infra.UseIO.restricedSystem instead! --import System.Cmd(system) -- use GF.Infra.UseIO.restricedSystem instead!
import GF.System.Process import GF.System.Process
import Text.PrettyPrint import GF.Text.Pretty
import Data.List (sort) import Data.List (sort)
--import Debug.Trace --import Debug.Trace
--import System.Random (newStdGen) ---- --import System.Random (newStdGen) ----
@@ -762,19 +762,19 @@ allCommands = Map.fromList [
Just e -> let (es,err) = exprs ls Just e -> let (es,err) = exprs ls
in case inferExpr pgf e of in case inferExpr pgf e of
Right (e,t) -> (e:es,err) Right (e,t) -> (e:es,err)
Left tcerr -> (es,text "on line" <+> int n <> colon $$ nest 2 (ppTcError tcerr) $$ err) Left tcerr -> (es,"on line" <+> n <> ':' $$ nest 2 (ppTcError tcerr) $$ err)
Nothing -> let (es,err) = exprs ls Nothing -> let (es,err) = exprs ls
in (es,text "on line" <+> int n <> colon <+> text "parse error" $$ err) in (es,"on line" <+> n <> ':' <+> "parse error" $$ err)
returnFromLines ls = case exprs ls of returnFromLines ls = case exprs ls of
(es, err) | null es -> return $ pipeMessage $ render (err $$ text "no trees found") (es, err) | null es -> return $ pipeMessage $ render (err $$ "no trees found")
| otherwise -> return $ pipeWithMessage es (render err) | otherwise -> return $ pipeWithMessage es (render err)
s <- restricted $ readFile file s <- restricted $ readFile file
case opts of case opts of
_ | isOpt "lines" opts && isOpt "tree" opts -> _ | isOpt "lines" opts && isOpt "tree" opts ->
returnFromLines (zip [1..] (lines s)) returnFromLines (zip [1::Int ..] (lines s))
_ | isOpt "tree" opts -> _ | isOpt "tree" opts ->
returnFromLines [(1,s)] returnFromLines [(1::Int,s)]
_ | isOpt "lines" opts -> return (fromStrings $ lines s) _ | isOpt "lines" opts -> return (fromStrings $ lines s)
_ -> return (fromString s), _ -> return (fromString s),
flags = [("file","the input file name")] flags = [("file","the input file name")]
@@ -1145,9 +1145,9 @@ allCommands = Map.fromList [
render (ppCat id cd $$ render (ppCat id cd $$
if null (functionsToCat pgf id) if null (functionsToCat pgf id)
then empty then empty
else space $$ else ' ' $$
vcat [ppFun fid (ty,0,Just [],0,0) | (fid,ty) <- functionsToCat pgf id] $$ vcat [ppFun fid (ty,0,Just [],0,0) | (fid,ty) <- functionsToCat pgf id] $$
space) ' ')
let (_,_,prob,_) = cd let (_,_,prob,_) = cd
putStrLn ("Probability: "++show prob) putStrLn ("Probability: "++show prob)
return void return void
@@ -1290,7 +1290,7 @@ allCommands = Map.fromList [
| otherwise = case po of | otherwise = case po of
ParseOk ts -> let Piped (es',msg') = fromExprs ts ParseOk ts -> let Piped (es',msg') = fromExprs ts
in (es'++es,msg'++msg) in (es'++es,msg'++msg)
TypeError errs -> ([], render (text "The parsing is successful but the type checking failed with error(s):" $$ TypeError errs -> ([], render ("The parsing is successful but the type checking failed with error(s):" $$
nest 2 (vcat (map (ppTcError . snd) errs))) nest 2 (vcat (map (ppTcError . snd) errs)))
++ "\n" ++ msg) ++ "\n" ++ msg)
ParseFailed i -> ([], "The parser failed at token " ++ show (words s !! max 0 (i-1)) ParseFailed i -> ([], "The parser failed at token " ++ show (words s !! max 0 (i-1))
@@ -1448,13 +1448,13 @@ execToktok (pgf, _) opts exprs = do
trie = render . pptss . toTrie . map toATree trie = render . pptss . toTrie . map toATree
where where
pptss [ts] = text "*"<+>nest 2 (ppts ts) pptss [ts] = "*"<+>nest 2 (ppts ts)
pptss tss = vcat [int i<+>nest 2 (ppts ts)|(i,ts)<-zip [1..] tss] pptss tss = vcat [i<+>nest 2 (ppts ts)|(i,ts)<-zip [(1::Int)..] tss]
ppts = vcat . map ppt ppts = vcat . map ppt
ppt t = ppt t =
case t of case t of
Oth e -> text (showExpr [] e) Oth e -> pp (showExpr [] e)
Ap f [[]] -> text (showCId f) Ap f [[]] -> pp (showCId f)
Ap f tss -> text (showCId f) $$ nest 2 (pptss tss) Ap f tss -> showCId f $$ nest 2 (pptss tss)

36
src/compiler/GF/Compile.hs
View File

@@ -1,4 +1,4 @@
module GF.Compile (batchCompile, link, srcAbsName, compileToPGF, compileSourceGrammar) where module GF.Compile (batchCompile, link, srcAbsName, compileToPGF) where
import Prelude hiding (catch) import Prelude hiding (catch)
import GF.System.Catch import GF.System.Catch
@@ -32,7 +32,7 @@ import qualified Data.Map as Map
--import qualified Data.Set as Set --import qualified Data.Set as Set
import Data.List(nub) import Data.List(nub)
import Data.Time(UTCTime) import Data.Time(UTCTime)
import Text.PrettyPrint import GF.Text.Pretty
import PGF.Internal(optimizePGF) import PGF.Internal(optimizePGF)
import PGF import PGF
@@ -59,7 +59,7 @@ batchCompile opts files = do
let cnc = identS (justModuleName (last files)) let cnc = identS (justModuleName (last files))
t = maximum . map fst $ Map.elems menv t = maximum . map fst $ Map.elems menv
return (cnc,t,gr) return (cnc,t,gr)
{-
-- to compile a set of modules, e.g. an old GF or a .cf file -- to compile a set of modules, e.g. an old GF or a .cf file
compileSourceGrammar :: Options -> SourceGrammar -> IOE SourceGrammar compileSourceGrammar :: Options -> SourceGrammar -> IOE SourceGrammar
compileSourceGrammar opts gr = do compileSourceGrammar opts gr = do
@@ -68,12 +68,12 @@ compileSourceGrammar opts gr = do
emptyCompileEnv emptyCompileEnv
(modules gr) (modules gr)
return gr' return gr'
-}
-- to output an intermediate stage -- to output an intermediate stage
intermOut :: Options -> Dump -> Doc -> IOE () intermOut :: Options -> Dump -> Doc -> IOE ()
intermOut opts d doc intermOut opts d doc
| dump opts d = ePutStrLn (render (text "\n\n--#" <+> text (show d) $$ doc)) | dump opts d = ePutStrLn (render ("\n\n--#" <+> show d $$ doc))
| otherwise = return () | otherwise = return ()
warnOut opts warnings warnOut opts warnings
@@ -118,8 +118,8 @@ compileModule opts1 env file = do
exists <- liftIO $ doesFileExist file1 exists <- liftIO $ doesFileExist file1
if exists if exists
then return file1 then return file1
else raise (render (text "None of these files exists:" $$ nest 2 (text file $$ text file1))) else raise (render ("None of these files exists:" $$ nest 2 (file $$ file1)))
else raise (render (text "File" <+> text file <+> text "does not exist.")) else raise (render ("File" <+> file <+> "does not exist."))
compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
compileOne opts env@(_,srcgr,_) file = do compileOne opts env@(_,srcgr,_) file = do
@@ -171,32 +171,28 @@ compileOne opts env@(_,srcgr,_) file = do
isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete
compileSourceModule :: Options -> FilePath -> CompileEnv -> Maybe FilePath -> SourceModule -> IOE CompileEnv compileSourceModule :: Options -> FilePath -> CompileEnv -> Maybe FilePath -> SourceModule -> IOE CompileEnv
compileSourceModule opts cwd env@(k,gr,_) mb_gfFile mo@(i,mi) = do compileSourceModule opts cwd env@(k,gr,_) mb_gfFile mo0@(i,mi) = do
mo1 <- runPass Rebuild "" (rebuildModule cwd gr mo) mo1a <- runPass Rebuild "" (rebuildModule cwd gr mo0)
mo1b <- runPass Extend "" (extendModule cwd gr mo1) mo1b <- runPass Extend "" (extendModule cwd gr mo1a)
case mo1b of case mo1b of
(_,n) | not (isCompleteModule n) -> (_,n) | not (isCompleteModule n) -> generateTagsOr generateGFO k mo1b
if tagsFlag then generateTags k mo1b else generateGFO k mo1b
_ -> do _ -> do
mo2 <- runPass Rename "renaming" $ renameModule cwd gr mo1b mo2 <- runPass Rename "renaming" $ renameModule cwd gr mo1b
mo3 <- runPass TypeCheck "type checking" $ checkModule opts cwd gr mo2 mo3 <- runPass TypeCheck "type checking" $ checkModule opts cwd gr mo2
if tagsFlag then generateTags k mo3 else compileCompleteModule k mo3 generateTagsOr compileCompleteModule k mo3
where where
compileCompleteModule k mo3 = do compileCompleteModule k mo3 = do
-- (k',mo3r:_) <- runPass2 (head.snd) Refresh "refreshing" $ mo4 <- runPass2 id Optimize "optimizing" $ optimizeModule opts gr mo3
-- refreshModule (k,gr) mo3
let k' = k
mo3r = mo3
mo4 <- runPass2 id Optimize "optimizing" $ optimizeModule opts gr mo3r
mo5 <- if isModCnc (snd mo4) && flag optPMCFG opts mo5 <- if isModCnc (snd mo4) && flag optPMCFG opts
then runPass2' "generating PMCFG" $ generatePMCFG opts gr mb_gfFile mo4 then runPass2' "generating PMCFG" $ generatePMCFG opts gr mb_gfFile mo4
else runPass2' "" $ return mo4 else runPass2' "" $ return mo4
generateGFO k' mo5 generateGFO k mo5
------------------------------ ------------------------------
tagsFlag = flag optTagsOnly opts generateTagsOr compile =
if flag optTagsOnly opts then generateTags else compile
generateGFO k mo = generateGFO k mo =
do let mb_gfo = fmap (gf2gfo opts) mb_gfFile do let mb_gfo = fmap (gf2gfo opts) mb_gfFile

35
src/compiler/GF/Compile/CheckGrammar.hs
View File

@@ -42,7 +42,7 @@ import GF.Infra.CheckM
import Data.List import Data.List
import qualified Data.Set as Set import qualified Data.Set as Set
import Control.Monad import Control.Monad
import Text.PrettyPrint import GF.Text.Pretty
-- | checking is performed in the dependency order of modules -- | checking is performed in the dependency order of modules
checkModule :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule checkModule :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
@@ -78,8 +78,8 @@ checkRestrictedInheritance cwd sgr (name,mo) = checkInModule cwd mo NoLoc empty
(f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)] (f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)]
case illegals of case illegals of
[] -> return () [] -> return ()
cs -> checkWarn (text "In inherited module" <+> ppIdent i <> text ", dependence of excluded constants:" $$ cs -> checkWarn ("In inherited module" <+> i <> ", dependence of excluded constants:" $$
nest 2 (vcat [ppIdent f <+> text "on" <+> fsep (map ppIdent is) | (f,is) <- cs])) nest 2 (vcat [f <+> "on" <+> fsep is | (f,is) <- cs]))
allDeps = concatMap (allDependencies (const True) . jments . snd) mos allDeps = concatMap (allDependencies (const True) . jments . snd) mos
checkCompleteGrammar :: Options -> FilePath -> SourceGrammar -> SourceModule -> SourceModule -> Check SourceModule checkCompleteGrammar :: Options -> FilePath -> SourceGrammar -> SourceModule -> SourceModule -> Check SourceModule
@@ -126,15 +126,15 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
Bad _ -> do noLinOf c Bad _ -> do noLinOf c
return js return js
where noLinOf c = when (verbAtLeast opts Normal) $ where noLinOf c = when (verbAtLeast opts Normal) $
checkWarn (text "no linearization of" <+> ppIdent c) checkWarn ("no linearization of" <+> c)
AbsCat (Just _) -> case lookupIdent c js of AbsCat (Just _) -> case lookupIdent c js of
Ok (AnyInd _ _) -> return js Ok (AnyInd _ _) -> return js
Ok (CncCat (Just _) _ _ _ _) -> return js Ok (CncCat (Just _) _ _ _ _) -> return js
Ok (CncCat Nothing md mr mp mpmcfg) -> do Ok (CncCat Nothing md mr mp mpmcfg) -> do
checkWarn (text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}") checkWarn ("no linearization type for" <+> c <> ", inserting default {s : Str}")
return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) md mr mp mpmcfg) js return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) md mr mp mpmcfg) js
_ -> do _ -> do
checkWarn (text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}") checkWarn ("no linearization type for" <+> c <> ", inserting default {s : Str}")
return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing Nothing) js return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing Nothing) js
_ -> return js _ -> return js
@@ -145,11 +145,11 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
do (cont,val) <- linTypeOfType gr cm ty do (cont,val) <- linTypeOfType gr cm ty
let linty = (snd (valCat ty),cont,val) let linty = (snd (valCat ty),cont,val)
return $ updateTree (c,CncFun (Just linty) d mn mf) js return $ updateTree (c,CncFun (Just linty) d mn mf) js
_ -> do checkWarn (text "function" <+> ppIdent c <+> text "is not in abstract") _ -> do checkWarn ("function" <+> c <+> "is not in abstract")
return js return js
CncCat _ _ _ _ _ -> case lookupOrigInfo gr (am,c) of CncCat _ _ _ _ _ -> case lookupOrigInfo gr (am,c) of
Ok _ -> return $ updateTree i js Ok _ -> return $ updateTree i js
_ -> do checkWarn (text "category" <+> ppIdent c <+> text "is not in abstract") _ -> do checkWarn ("category" <+> c <+> "is not in abstract")
return js return js
_ -> return $ updateTree i js _ -> return $ updateTree i js
@@ -241,7 +241,7 @@ checkInfo opts cwd sgr (m,mo) c info = do
return (Just (L locd ty'), Just (L locd de')) return (Just (L locd ty'), Just (L locd de'))
(Just (L loct ty), Nothing) -> do (Just (L loct ty), Nothing) -> do
chIn loct "operation" $ chIn loct "operation" $
checkError (text "No definition given to the operation") checkError (pp "No definition given to the operation")
return (ResOper pty' pde') return (ResOper pty' pde')
ResOverload os tysts -> chIn NoLoc "overloading" $ do ResOverload os tysts -> chIn NoLoc "overloading" $ do
@@ -263,8 +263,7 @@ checkInfo opts cwd sgr (m,mo) c info = do
_ -> return info _ -> return info
where where
gr = prependModule sgr (m,mo) gr = prependModule sgr (m,mo)
chIn loc cat = checkInModule cwd mo loc chIn loc cat = checkInModule cwd mo loc ("Happened in" <+> cat <+> c)
(text "Happened in" <+> text cat <+> ppIdent c)
mkPar (f,co) = do mkPar (f,co) = do
vs <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co vs <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
@@ -272,7 +271,7 @@ checkInfo opts cwd sgr (m,mo) c info = do
checkUniq xss = case xss of checkUniq xss = case xss of
x:y:xs x:y:xs
| x == y -> checkError $ text "ambiguous for type" <+> | x == y -> checkError $ "ambiguous for type" <+>
ppType (mkFunType (tail x) (head x)) ppType (mkFunType (tail x) (head x))
| otherwise -> checkUniq $ y:xs | otherwise -> checkUniq $ y:xs
_ -> return () _ -> return ()
@@ -282,7 +281,7 @@ checkInfo opts cwd sgr (m,mo) c info = do
_ -> chIn loc cat $ checkError (vcat ss) _ -> chIn loc cat $ checkError (vcat ss)
compAbsTyp g t = case t of compAbsTyp g t = case t of
Vr x -> maybe (checkError (text "no value given to variable" <+> ppIdent x)) return $ lookup x g Vr x -> maybe (checkError ("no value given to variable" <+> x)) return $ lookup x g
Let (x,(_,a)) b -> do Let (x,(_,a)) b -> do
a' <- compAbsTyp g a a' <- compAbsTyp g a
compAbsTyp ((x, a'):g) b compAbsTyp ((x, a'):g) b
@@ -298,7 +297,7 @@ checkInfo opts cwd sgr (m,mo) c info = do
checkReservedId :: Ident -> Check () checkReservedId :: Ident -> Check ()
checkReservedId x = checkReservedId x =
when (isReservedWord x) $ when (isReservedWord x) $
checkWarn (text "reserved word used as identifier:" <+> ppIdent x) checkWarn ("reserved word used as identifier:" <+> x)
-- auxiliaries -- auxiliaries
@@ -315,10 +314,10 @@ linTypeOfType cnc m typ = do
let vars = mkRecType varLabel $ replicate n typeStr let vars = mkRecType varLabel $ replicate n typeStr
symb = argIdent n cat i symb = argIdent n cat i
rec <- if n==0 then return val else rec <- if n==0 then return val else
errIn (render (text "extending" $$ errIn (render ("extending" $$
nest 2 (ppTerm Unqualified 0 vars) $$ nest 2 vars $$
text "with" $$ "with" $$
nest 2 (ppTerm Unqualified 0 val))) $ nest 2 val)) $
plusRecType vars val plusRecType vars val
return (Explicit,symb,rec) return (Explicit,symb,rec)
lookLin (_,c) = checks [ --- rather: update with defLinType ? lookLin (_,c) = checks [ --- rather: update with defLinType ?

34
src/compiler/GF/Compile/Compute/ConcreteNew.hs
View File

@@ -1,7 +1,7 @@
-- | Functions for computing the values of terms in the concrete syntax, in -- | Functions for computing the values of terms in the concrete syntax, in
-- | preparation for PMCFG generation. -- | preparation for PMCFG generation.
module GF.Compile.Compute.ConcreteNew module GF.Compile.Compute.ConcreteNew
(GlobalEnv, resourceValues, normalForm, ppL (GlobalEnv, resourceValues, normalForm,
--, Value(..), Env, value2term, eval, apply --, Value(..), Env, value2term, eval, apply
) where ) where
@@ -18,7 +18,7 @@ import GF.Data.Utilities(mapFst,mapSnd,mapBoth)
import Control.Monad(ap,liftM,liftM2,mplus,unless) import Control.Monad(ap,liftM,liftM2,mplus,unless)
import Data.List (findIndex,intersect,nub,elemIndex,(\\)) --,isInfixOf import Data.List (findIndex,intersect,nub,elemIndex,(\\)) --,isInfixOf
--import Data.Char (isUpper,toUpper,toLower) --import Data.Char (isUpper,toUpper,toLower)
import Text.PrettyPrint import GF.Text.Pretty
import qualified Data.Map as Map import qualified Data.Map as Map
--import Debug.Trace(trace) --import Debug.Trace(trace)
@@ -109,7 +109,7 @@ value env t0 =
brackets (fsep (map ppIdent (local env))), brackets (fsep (map ppIdent (local env))),
ppT 10 t0]) $ ppT 10 t0]) $
--} --}
errIn (render $ ppT 0 t0) $ errIn (render t0) $
case t0 of case t0 of
Vr x -> var env x Vr x -> var env x
Q x@(m,f) Q x@(m,f)
@@ -158,7 +158,7 @@ value env t0 =
Glue t1 t2 -> ((ok2p (glue env).) # both id) # both (value env) (t1,t2) Glue t1 t2 -> ((ok2p (glue env).) # both id) # both (value env) (t1,t2)
ELin c r -> (unlockVRec c.) # value env r ELin c r -> (unlockVRec c.) # value env r
EPatt p -> return $ const (VPatt p) -- hmm EPatt p -> return $ const (VPatt p) -- hmm
t -> fail.render $ text "value"<+>ppT 10 t $$ text (show t) t -> fail.render $ "value"<+>ppT 10 t $$ show t
paramValues env ty = do let ge = global env paramValues env ty = do let ge = global env
ats <- allParamValues (srcgr env) =<< nfx ge ty ats <- allParamValues (srcgr env) =<< nfx ge ty
@@ -216,15 +216,15 @@ extR t vv =
(VRecType rs1, VRecType rs2) -> (VRecType rs1, VRecType rs2) ->
case intersect (map fst rs1) (map fst rs2) of case intersect (map fst rs1) (map fst rs2) of
[] -> VRecType (rs1 ++ rs2) [] -> VRecType (rs1 ++ rs2)
ls -> error $ text "clash"<+>text (show ls) ls -> error $ "clash"<+>show ls
(VRec rs1, VRec rs2) -> plusVRec rs1 rs2 (VRec rs1, VRec rs2) -> plusVRec rs1 rs2
(v1 , VRec [(l,_)]) | isLockLabel l -> v1 -- hmm (v1 , VRec [(l,_)]) | isLockLabel l -> v1 -- hmm
(VS (VV t pvs vs) s,v2) -> VS (VV t pvs [extR t (v1,v2)|v1<-vs]) s (VS (VV t pvs vs) s,v2) -> VS (VV t pvs [extR t (v1,v2)|v1<-vs]) s
(v1,v2) -> ok2 VExtR v1 v2 -- hmm (v1,v2) -> ok2 VExtR v1 v2 -- hmm
-- (v1,v2) -> error $ text "not records" $$ text (show v1) $$ text (show v2) -- (v1,v2) -> error $ text "not records" $$ text (show v1) $$ text (show v2)
where where
error explain = ppbug $ text "The term" <+> ppT 0 t error explain = ppbug $ "The term" <+> t
<+> text "is not reducible" $$ explain <+> "is not reducible" $$ explain
glue env (v1,v2) = glu v1 v2 glue env (v1,v2) = glu v1 v2
where where
@@ -249,8 +249,8 @@ glue env (v1,v2) = glu v1 v2
(_,v2@(VApp NonExist _)) -> v2 (_,v2@(VApp NonExist _)) -> v2
-- (v1,v2) -> ok2 VGlue v1 v2 -- (v1,v2) -> ok2 VGlue v1 v2
(v1,v2) -> error . render $ (v1,v2) -> error . render $
ppL loc (hang (text "unsupported token gluing:") 4 ppL loc (hang "unsupported token gluing:" 4
(ppT 0 (Glue (vt v1) (vt v2)))) (Glue (vt v1) (vt v2)))
vt = value2term loc (local env) vt = value2term loc (local env)
loc = gloc env loc = gloc env
@@ -331,7 +331,7 @@ valueTable env i cs =
pvs = nub allpvs pvs = nub allpvs
dups = allpvs \\ pvs dups = allpvs \\ pvs
unless (null dups) $ unless (null dups) $
fail.render $ hang (text "Pattern is not linear:") 4 fail.render $ hang "Pattern is not linear:" 4
(ppPatt Unqualified 0 p') (ppPatt Unqualified 0 p')
vt <- value (extend pvs env) t vt <- value (extend pvs env) t
return (p', \ vs -> Bind $ \ bs -> vt (push' p' bs pvs vs)) return (p', \ vs -> Bind $ \ bs -> vt (push' p' bs pvs vs))
@@ -350,8 +350,8 @@ valueTable env i cs =
PM qc -> do r <- resource env qc PM qc -> do r <- resource env qc
case r of case r of
VPatt p' -> inlinePattMacro p' VPatt p' -> inlinePattMacro p'
_ -> ppbug $ hang (text "Expected pattern macro:") 4 _ -> ppbug $ hang "Expected pattern macro:" 4
(text (show r)) (show r)
_ -> composPattOp inlinePattMacro p _ -> composPattOp inlinePattMacro p
--} --}
@@ -498,11 +498,7 @@ both f (x,y) = (,) # f x <# f y
ppT = ppTerm Unqualified ppT = ppTerm Unqualified
ppL (L loc x) msg = hang (ppLocation "" loc<>colon) 4 bugloc loc s = ppbug $ ppL loc s
(text "In"<+>ppIdent x<>colon<+>msg)
bugloc loc s = ppbug $ ppL loc (text s) bug msg = ppbug msg
ppbug doc = error $ render $ hang "Internal error in Compute.ConcreteNew:" 4 doc
bug msg = ppbug (text msg)
ppbug doc = error $ render $
hang (text "Internal error in Compute.ConcreteNew:") 4 doc

42
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

@@ -25,13 +25,13 @@ import GF.Data.BacktrackM
import GF.Data.Operations import GF.Data.Operations
import GF.Infra.UseIO (IOE,ePutStr,ePutStrLn) import GF.Infra.UseIO (IOE,ePutStr,ePutStrLn)
import GF.Data.Utilities (updateNthM) --updateNth import GF.Data.Utilities (updateNthM) --updateNth
import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues,ppL) import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues)
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.List as List import qualified Data.List as List
--import qualified Data.IntMap as IntMap --import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet import qualified Data.IntSet as IntSet
import Text.PrettyPrint hiding (Str) import GF.Text.Pretty
import Data.Array.IArray import Data.Array.IArray
import Data.Array.Unboxed import Data.Array.Unboxed
--import Data.Maybe --import Data.Maybe
@@ -148,13 +148,13 @@ floc opath loc id = maybe (L loc id) (\path->L (External path loc) id) opath
convert opts gr cenv loc term ty@(_,val) pargs = convert opts gr cenv loc term ty@(_,val) pargs =
case term' of case term' of
Error s -> fail $ render $ ppL loc (text $ "Predef.error: "++s) Error s -> fail $ render $ ppL loc ("Predef.error: "++s)
_ -> do {-when (verbAtLeast opts Verbose) $ _ -> do {-when (verbAtLeast opts Verbose) $
ePutStrLn $ ePutStrLn $
"\n"++take 10000 (renderStyle style{mode=OneLineMode} "\n"++take 10000 (renderStyle style{mode=OneLineMode}
(text "term:"<+>ppU 0 term $$ (text "term:"<+>term $$
text "eta expanded:"<+>ppU 0 eterm $$ text "eta expanded:"<+>eterm $$
text "normalized:"<+>ppU 0 term'))--} text "normalized:"<+>term'))--}
return $ runCnvMonad gr (conv term') (pargs,[]) return $ runCnvMonad gr (conv term') (pargs,[])
where where
conv t = convertTerm opts CNil val =<< unfactor t conv t = convertTerm opts CNil val =<< unfactor t
@@ -189,16 +189,16 @@ unfactor t = CM (\gr c -> c (unfac gr t))
case t of case t of
T (TTyped ty) [(PV x,u)] -> let u' = unfac gr u T (TTyped ty) [(PV x,u)] -> let u' = unfac gr u
vs = allparams ty vs = allparams ty
in --trace ("expand single variable table into "++show (length vs)++" branches.\n"++render (ppU 0 t)) $ in --trace ("expand single variable table into "++show (length vs)++" branches.\n"++render t) $
V ty [restore x v u' | v <- vs] V ty [restore x v u' | v <- vs]
T (TTyped ty) [(PW ,u)] -> let u' = unfac gr u T (TTyped ty) [(PW ,u)] -> let u' = unfac gr u
vs = allparams ty vs = allparams ty
in --trace ("expand wildcard table into "++show (length vs)++ "branches.\n"++render (ppU 0 t)) $ in --trace ("expand wildcard table into "++show (length vs)++ "branches.\n"++render t) $
V ty [u' | _ <- vs] V ty [u' | _ <- vs]
T (TTyped ty) _ -> -- convertTerm doesn't handle these tables T (TTyped ty) _ -> -- convertTerm doesn't handle these tables
ppbug $ ppbug $
sep [text "unfactor"<+>ppU 10 t, sep ["unfactor"<+>ppU 10 t,
text (show t){-, pp (show t){-,
fsep (map (ppU 10) (allparams ty))-}] fsep (map (ppU 10) (allparams ty))-}]
_ -> composSafeOp (unfac gr) t _ -> composSafeOp (unfac gr) t
where where
@@ -376,7 +376,7 @@ computeCatRange gr lincat = compute (0,1) lincat
(index,m) = st (index,m) = st
in ((index,m*length vs),CPar (m,zip vs [0..])) in ((index,m*length vs),CPar (m,zip vs [0..]))
ppPath (CProj lbl path) = ppLabel lbl <+> ppPath path ppPath (CProj lbl path) = lbl <+> ppPath path
ppPath (CSel trm path) = ppU 5 trm <+> ppPath path ppPath (CSel trm path) = ppU 5 trm <+> ppPath path
ppPath CNil = empty ppPath CNil = empty
@@ -417,7 +417,7 @@ convertTerm opts sel ctype (Alts s alts)= do CStr s <- convertTerm opts CNil cty
where where
unSym (CStr []) = "" unSym (CStr []) = ""
unSym (CStr [SymKS t]) = t unSym (CStr [SymKS t]) = t
unSym _ = ppbug $ hang (text "invalid prefix in pre expression:") 4 (ppU 0 (Alts s alts)) unSym _ = ppbug $ hang ("invalid prefix in pre expression:") 4 (Alts s alts)
unPatt (EPatt p) = fmap Strs (getPatts p) unPatt (EPatt p) = fmap Strs (getPatts p)
unPatt u = return u unPatt u = return u
@@ -429,7 +429,7 @@ convertTerm opts sel ctype (Alts s alts)= do CStr s <- convertTerm opts CNil cty
as <- getPatts a as <- getPatts a
bs <- getPatts b bs <- getPatts b
return [K (s ++ t) | K s <- as, K t <- bs] return [K (s ++ t) | K s <- as, K t <- bs]
_ -> fail (render (text "not valid pattern in pre expression" <+> ppPatt Unqualified 0 p)) _ -> fail (render ("not valid pattern in pre expression" <+> ppPatt Unqualified 0 p))
convertTerm opts sel ctype (Q (m,f)) convertTerm opts sel ctype (Q (m,f))
| m == cPredef && | m == cPredef &&
@@ -449,7 +449,7 @@ convertTerm opts sel@(CProj l _) ctype (ExtR t1@(R rs1) t2)
convertTerm opts CNil ctype t = do v <- evalTerm CNil t convertTerm opts CNil ctype t = do v <- evalTerm CNil t
return (CPar v) return (CPar v)
convertTerm _ sel _ t = ppbug (text "convertTerm" <+> sep [parens (text (show sel)),ppU 10 t]) convertTerm _ sel _ t = ppbug ("convertTerm" <+> sep [parens (show sel),ppU 10 t])
convertArg :: Options -> Term -> Int -> Path -> CnvMonad (Value [Symbol]) convertArg :: Options -> Term -> Int -> Path -> CnvMonad (Value [Symbol])
convertArg opts (RecType rs) nr path = convertArg opts (RecType rs) nr path =
@@ -489,8 +489,8 @@ convertTbl opts (CSel v sub_sel) ctype pt ts = do
vs <- getAllParamValues pt vs <- getAllParamValues pt
case lookup v (zip vs ts) of case lookup v (zip vs ts) of
Just t -> convertTerm opts sub_sel ctype t Just t -> convertTerm opts sub_sel ctype t
Nothing -> ppbug (text "convertTbl:" <+> (text "missing value" <+> ppU 0 v $$ Nothing -> ppbug ( "convertTbl:" <+> ("missing value" <+> v $$
text "among" <+> vcat (map (ppU 0) vs))) "among" <+> vcat vs))
convertTbl opts _ ctype _ _ = bug ("convertTbl: "++show ctype) convertTbl opts _ ctype _ _ = bug ("convertTbl: "++show ctype)
@@ -571,13 +571,13 @@ evalTerm path (V pt ts) =
do vs <- getAllParamValues pt do vs <- getAllParamValues pt
case lookup trm (zip vs ts) of case lookup trm (zip vs ts) of
Just t -> evalTerm path t Just t -> evalTerm path t
Nothing -> ppbug $ text "evalTerm: missing value:"<+>ppU 0 trm Nothing -> ppbug $ "evalTerm: missing value:"<+>trm
$$ text "among:" <+>fsep (map (ppU 10) vs) $$ "among:" <+>fsep (map (ppU 10) vs)
evalTerm path (S term sel) = do v <- evalTerm CNil sel evalTerm path (S term sel) = do v <- evalTerm CNil sel
evalTerm (CSel v path) term evalTerm (CSel v path) term
evalTerm path (FV terms) = variants terms >>= evalTerm path evalTerm path (FV terms) = variants terms >>= evalTerm path
evalTerm path (EInt n) = return (EInt n) evalTerm path (EInt n) = return (EInt n)
evalTerm path t = ppbug (text "evalTerm" <+> parens (ppU 0 t)) evalTerm path t = ppbug ("evalTerm" <+> parens t)
--evalTerm path t = ppbug (text "evalTerm" <+> sep [parens (text (show path)),parens (text (show t))]) --evalTerm path t = ppbug (text "evalTerm" <+> sep [parens (text (show path)),parens (text (show t))])
getVarIndex x = maybe err id $ getArgIndex x getVarIndex x = maybe err id $ getArgIndex x
@@ -654,7 +654,7 @@ restrictProtoFCat path v (PFCat cat f schema) = do
mkArray lst = listArray (0,length lst-1) lst mkArray lst = listArray (0,length lst-1) lst
mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map] mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
bug msg = ppbug (text msg) bug msg = ppbug msg
ppbug = error . render . hang (text "Internal error in GeneratePMCFG:") 4 ppbug msg = error . render $ hang "Internal error in GeneratePMCFG:" 4 msg
ppU = ppTerm Unqualified ppU = ppTerm Unqualified

14
src/compiler/GF/Compile/Optimize.hs
View File

@@ -34,7 +34,7 @@ import GF.Infra.Option
import Control.Monad import Control.Monad
--import Data.List --import Data.List
import qualified Data.Set as Set import qualified Data.Set as Set
import Text.PrettyPrint import GF.Text.Pretty
import Debug.Trace import Debug.Trace
@@ -89,7 +89,7 @@ evalInfo opts resenv sgr m c info = do
return (CncCat ptyp pde' pre' ppr' mpmcfg) return (CncCat ptyp pde' pre' ppr' mpmcfg)
CncFun (mt@(Just (_,cont,val))) pde ppr mpmcfg -> --trace (prt c) $ CncFun (mt@(Just (_,cont,val))) pde ppr mpmcfg -> --trace (prt c) $
eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd cont val []) $$ text "of function") $ do eIn ("linearization in type" <+> mkProd cont val [] $$ "of function") $ do
pde' <- case pde of pde' <- case pde of
Just (L loc de) -> do de <- partEval opts gr (cont,val) de Just (L loc de) -> do de <- partEval opts gr (cont,val) de
return (Just (L loc (factor param c 0 de))) return (Just (L loc (factor param c 0 de)))
@@ -112,7 +112,7 @@ evalInfo opts resenv sgr m c info = do
gr = prependModule sgr m gr = prependModule sgr m
optim = flag optOptimizations opts optim = flag optOptimizations opts
param = OptParametrize `Set.member` optim param = OptParametrize `Set.member` optim
eIn cat = errIn (render (text "Error optimizing" <+> cat <+> ppIdent c <+> colon)) eIn cat = errIn (render ("Error optimizing" <+> cat <+> c <+> ':'))
-- | the main function for compiling linearizations -- | the main function for compiling linearizations
partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term
@@ -121,7 +121,7 @@ partEval opts = {-if flag optNewComp opts
{-else partEvalOld opts-} {-else partEvalOld opts-}
partEvalNew opts gr (context, val) trm = partEvalNew opts gr (context, val) trm =
errIn (render (text "partial evaluation" <+> ppTerm Qualified 0 trm)) $ errIn (render ("partial evaluation" <+> ppTerm Qualified 0 trm)) $
checkPredefError trm checkPredefError trm
{- {-
partEvalOld opts gr (context, val) trm = errIn (render (text "partial evaluation" <+> ppTerm Qualified 0 trm)) $ do partEvalOld opts gr (context, val) trm = errIn (render (text "partial evaluation" <+> ppTerm Qualified 0 trm)) $ do
@@ -169,13 +169,13 @@ mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
QC p -> do vs <- lookupParamValues gr p QC p -> do vs <- lookupParamValues gr p
case vs of case vs of
v:_ -> return v v:_ -> return v
_ -> Bad (render (text "no parameter values given to type" <+> ppQIdent Qualified p)) _ -> Bad (render ("no parameter values given to type" <+> ppQIdent Qualified p))
RecType r -> do RecType r -> do
let (ls,ts) = unzip r let (ls,ts) = unzip r
ts <- mapM mkDefField ts ts <- mapM mkDefField ts
return $ R (zipWith assign ls ts) return $ R (zipWith assign ls ts)
_ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val _ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val
_ -> Bad (render (text "linearization type field cannot be" <+> ppTerm Unqualified 0 typ)) _ -> Bad (render ("linearization type field cannot be" <+> typ))
mkLinReference :: SourceGrammar -> Type -> Err Term mkLinReference :: SourceGrammar -> Type -> Err Term
mkLinReference gr typ = mkLinReference gr typ =
@@ -196,7 +196,7 @@ mkLinReference gr typ =
RecType rs -> do RecType rs -> do
msum (map (\(l,ty) -> mkDefField ty (P trm l)) (sortRec rs)) msum (map (\(l,ty) -> mkDefField ty (P trm l)) (sortRec rs))
_ | Just _ <- isTypeInts typ -> Bad "no string" _ | Just _ <- isTypeInts typ -> Bad "no string"
_ -> Bad (render (text "linearization type field cannot be" <+> ppTerm Unqualified 0 typ)) _ -> Bad (render ("linearization type field cannot be" <+> typ))
evalPrintname :: GlobalEnv -> Ident -> L Term -> L Term evalPrintname :: GlobalEnv -> Ident -> L Term -> L Term
evalPrintname resenv c (L loc pr) = L loc (normalForm resenv (L loc c) pr) evalPrintname resenv c (L loc pr) = L loc (normalForm resenv (L loc c) pr)

30
src/compiler/GF/Compile/Rename.hs
View File

@@ -40,7 +40,7 @@ import GF.Data.Operations
import Control.Monad import Control.Monad
import Data.List (nub,(\\)) import Data.List (nub,(\\))
import Text.PrettyPrint import GF.Text.Pretty
-- | this gives top-level access to renaming term input in the cc command -- | this gives top-level access to renaming term input in the cc command
renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term
@@ -97,8 +97,8 @@ renameIdentTerm' env@(act,imps) t0 =
Ok f -> return (f c) Ok f -> return (f c)
_ -> case lookupTreeManyAll showIdent opens c of _ -> case lookupTreeManyAll showIdent opens c of
[f] -> return (f c) [f] -> return (f c)
[] -> alt c (text "constant not found:" <+> ppIdent c $$ [] -> alt c ("constant not found:" <+> c $$
text "given" <+> fsep (punctuate comma (map (ppIdent . fst) qualifs))) "given" <+> fsep (punctuate ',' (map fst qualifs)))
fs -> case nub [f c | f <- fs] of fs -> case nub [f c | f <- fs] of
[tr] -> return tr [tr] -> return tr
{- {-
@@ -106,9 +106,9 @@ renameIdentTerm' env@(act,imps) t0 =
-- name conflicts resolved as overloading in TypeCheck.RConcrete AR 31/1/2014 -- name conflicts resolved as overloading in TypeCheck.RConcrete AR 31/1/2014
-- the old definition is below and still presupposed in TypeCheck.Concrete -- the old definition is below and still presupposed in TypeCheck.Concrete
-} -}
ts@(t:_) -> do checkWarn (text "atomic term" <+> ppTerm Qualified 0 t0 $$ ts@(t:_) -> do checkWarn ("atomic term" <+> ppTerm Qualified 0 t0 $$
text "conflict" <+> hsep (punctuate comma (map (ppTerm Qualified 0) ts)) $$ "conflict" <+> hsep (punctuate ',' (map (ppTerm Qualified 0) ts)) $$
text "given" <+> fsep (punctuate comma (map (ppIdent . fst) qualifs))) "given" <+> fsep (punctuate ',' (map fst qualifs)))
return t return t
-- a warning will be generated in CheckGrammar, and the head returned -- a warning will be generated in CheckGrammar, and the head returned
@@ -171,7 +171,7 @@ renameInfo cwd status (m,mi) i info =
renMaybe ren Nothing = return Nothing renMaybe ren Nothing = return Nothing
renLoc ren (L loc x) = renLoc ren (L loc x) =
checkInModule cwd mi loc (text "Happened in the renaming of" <+> ppIdent i) $ do checkInModule cwd mi loc ("Happened in the renaming of" <+> i) $ do
x <- ren x x <- ren x
return (L loc x) return (L loc x)
@@ -222,7 +222,7 @@ renameTerm env vars = ren vars where
| elem r vs -> return trm -- try var proj first .. | elem r vs -> return trm -- try var proj first ..
| otherwise -> checks [ renid' (Q (r,label2ident l)) -- .. and qualified expression second. | otherwise -> checks [ renid' (Q (r,label2ident l)) -- .. and qualified expression second.
, renid' t >>= \t -> return (P t l) -- try as a constant at the end , renid' t >>= \t -> return (P t l) -- try as a constant at the end
, checkError (text "unknown qualified constant" <+> ppTerm Unqualified 0 trm) , checkError ("unknown qualified constant" <+> trm)
] ]
EPatt p -> do EPatt p -> do
@@ -244,8 +244,8 @@ renamePattern :: Status -> Patt -> Check (Patt,[Ident])
renamePattern env patt = renamePattern env patt =
do r@(p',vs) <- renp patt do r@(p',vs) <- renp patt
let dupl = vs \\ nub vs let dupl = vs \\ nub vs
unless (null dupl) $ checkError (hang (text "[C.4.13] Pattern is not linear:") 4 unless (null dupl) $ checkError (hang ("[C.4.13] Pattern is not linear:") 4
(ppPatt Unqualified 0 patt)) patt)
return r return r
where where
renp patt = case patt of renp patt = case patt of
@@ -253,7 +253,7 @@ renamePattern env patt =
c' <- renid $ Vr c c' <- renid $ Vr c
case c' of case c' of
Q d -> renp $ PM d Q d -> renp $ PM d
_ -> checkError (text "unresolved pattern" <+> ppPatt Unqualified 0 patt) _ -> checkError ("unresolved pattern" <+> patt)
PC c ps -> do PC c ps -> do
c' <- renid $ Cn c c' <- renid $ Cn c
@@ -261,8 +261,8 @@ renamePattern env patt =
QC c -> do psvss <- mapM renp ps QC c -> do psvss <- mapM renp ps
let (ps,vs) = unzip psvss let (ps,vs) = unzip psvss
return (PP c ps, concat vs) return (PP c ps, concat vs)
Q _ -> checkError (text "data constructor expected but" <+> ppTerm Qualified 0 c' <+> text "is found instead") Q _ -> checkError ("data constructor expected but" <+> ppTerm Qualified 0 c' <+> "is found instead")
_ -> checkError (text "unresolved data constructor" <+> ppTerm Qualified 0 c') _ -> checkError ("unresolved data constructor" <+> ppTerm Qualified 0 c')
PP c ps -> do PP c ps -> do
(QC c') <- renid (QC c) (QC c') <- renid (QC c)
@@ -274,12 +274,12 @@ renamePattern env patt =
x <- renid (Q c) x <- renid (Q c)
c' <- case x of c' <- case x of
(Q c') -> return c' (Q c') -> return c'
_ -> checkError (text "not a pattern macro" <+> ppPatt Qualified 0 patt) _ -> checkError ("not a pattern macro" <+> ppPatt Qualified 0 patt)
return (PM c', []) return (PM c', [])
PV x -> checks [ renid' (Vr x) >>= \t' -> case t' of PV x -> checks [ renid' (Vr x) >>= \t' -> case t' of
QC c -> return (PP c [],[]) QC c -> return (PP c [],[])
_ -> checkError (text "not a constructor") _ -> checkError (pp "not a constructor")
, return (patt, [x]) , return (patt, [x])
] ]

42
src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
View File

@@ -10,7 +10,7 @@ import GF.Infra.CheckM
--import GF.Infra.UseIO --import GF.Infra.UseIO
import GF.Data.Operations import GF.Data.Operations
import Text.PrettyPrint import GF.Text.Pretty
import Data.List (nub, (\\), tails) import Data.List (nub, (\\), tails)
import qualified Data.IntMap as IntMap import qualified Data.IntMap as IntMap
@@ -48,7 +48,7 @@ checkSigma gr scope t sigma = do -- GEN2
let bad_tvs = filter (`elem` esc_tvs) skol_tvs let bad_tvs = filter (`elem` esc_tvs) skol_tvs
if null bad_tvs if null bad_tvs
then return (abs t) then return (abs t)
else tcError (text "Type not polymorphic enough") else tcError (pp "Type not polymorphic enough")
tcRho :: SourceGrammar -> Scope -> Term -> Maybe Rho -> TcM (Term, Rho) tcRho :: SourceGrammar -> Scope -> Term -> Maybe Rho -> TcM (Term, Rho)
tcRho gr scope t@(EInt _) mb_ty = instSigma gr scope t (eval gr [] typeInt) mb_ty tcRho gr scope t@(EInt _) mb_ty = instSigma gr scope t (eval gr [] typeInt) mb_ty
@@ -58,20 +58,20 @@ tcRho gr scope t@(Empty) mb_ty = instSigma gr scope t (eval gr [] typeStr)
tcRho gr scope t@(Vr v) mb_ty = do -- VAR tcRho gr scope t@(Vr v) mb_ty = do -- VAR
case lookup v scope of case lookup v scope of
Just v_sigma -> instSigma gr scope t v_sigma mb_ty Just v_sigma -> instSigma gr scope t v_sigma mb_ty
Nothing -> tcError (text "Unknown variable" <+> ppIdent v) Nothing -> tcError ("Unknown variable" <+> v)
tcRho gr scope t@(Q id) mb_ty tcRho gr scope t@(Q id) mb_ty
| elem (fst id) [cPredef,cPredefAbs] = | elem (fst id) [cPredef,cPredefAbs] =
case typPredefined (snd id) of case typPredefined (snd id) of
Just ty -> instSigma gr scope t (eval gr [] ty) mb_ty Just ty -> instSigma gr scope t (eval gr [] ty) mb_ty
Nothing -> tcError (text "unknown in Predef:" <+> ppQIdent Qualified id) Nothing -> tcError (pp "unknown in Predef:" <+> ppQIdent Qualified id)
| otherwise = do | otherwise = do
case lookupResType gr id of case lookupResType gr id of
Ok ty -> instSigma gr scope t (eval gr [] ty) mb_ty Ok ty -> instSigma gr scope t (eval gr [] ty) mb_ty
Bad err -> tcError (text err) Bad err -> tcError (pp err)
tcRho gr scope t@(QC id) mb_ty = do tcRho gr scope t@(QC id) mb_ty = do
case lookupResType gr id of case lookupResType gr id of
Ok ty -> instSigma gr scope t (eval gr [] ty) mb_ty Ok ty -> instSigma gr scope t (eval gr [] ty) mb_ty
Bad err -> tcError (text err) Bad err -> tcError (pp err)
tcRho gr scope (App fun arg) mb_ty = do -- APP tcRho gr scope (App fun arg) mb_ty = do -- APP
(fun,fun_ty) <- tcRho gr scope fun Nothing (fun,fun_ty) <- tcRho gr scope fun Nothing
(arg_ty, res_ty) <- unifyFun gr scope (eval gr (scopeEnv scope) arg) fun_ty (arg_ty, res_ty) <- unifyFun gr scope (eval gr (scopeEnv scope) arg) fun_ty
@@ -148,9 +148,9 @@ tcRho gr scope t@(R rs) mb_ty = do
Just ty -> case ty of Just ty -> case ty of
VRecType ltys -> checkRecFields gr scope rs ltys VRecType ltys -> checkRecFields gr scope rs ltys
VMeta _ _ _ -> inferRecFields gr scope rs VMeta _ _ _ -> inferRecFields gr scope rs
_ -> tcError (text "Record type is inferred but:" $$ _ -> tcError ("Record type is inferred but:" $$
nest 2 (ppTerm Unqualified 0 (value2term gr (scopeVars scope) ty)) $$ nest 2 (ppTerm Unqualified 0 (value2term gr (scopeVars scope) ty)) $$
text "is expected in the expresion:" $$ "is expected in the expresion:" $$
nest 2 (ppTerm Unqualified 0 t)) nest 2 (ppTerm Unqualified 0 t))
return (R [(l, (Just (value2term gr (scopeVars scope) ty), t)) | (l,t,ty) <- lttys], return (R [(l, (Just (value2term gr (scopeVars scope) ty), t)) | (l,t,ty) <- lttys],
VRecType [(l, ty) | (l,t,ty) <- lttys] VRecType [(l, ty) | (l,t,ty) <- lttys]
@@ -177,9 +177,9 @@ tcRho gr scope t@(ExtR t1 t2) mb_ty = do
(VSort s1,VSort s2) (VSort s1,VSort s2)
| s1 == cType && s2 == cType -> instSigma gr scope (ExtR t1 t2) (VSort cType) mb_ty | s1 == cType && s2 == cType -> instSigma gr scope (ExtR t1 t2) (VSort cType) mb_ty
(VRecType rs1, VRecType rs2) (VRecType rs1, VRecType rs2)
| otherwise -> do tcWarn (text "bbbb") | otherwise -> do tcWarn (pp "bbbb")
instSigma gr scope (ExtR t1 t2) (VRecType (rs1 ++ rs2)) mb_ty instSigma gr scope (ExtR t1 t2) (VRecType (rs1 ++ rs2)) mb_ty
_ -> tcError (text "Cannot type check" <+> ppTerm Unqualified 0 t) _ -> tcError ("Cannot type check" <+> ppTerm Unqualified 0 t)
tcRho gr scope (ELin cat t) mb_ty = do -- this could be done earlier, i.e. in the parser tcRho gr scope (ELin cat t) mb_ty = do -- this could be done earlier, i.e. in the parser
tcRho gr scope (ExtR t (R [(lockLabel cat,(Just (RecType []),R []))])) mb_ty tcRho gr scope (ExtR t (R [(lockLabel cat,(Just (RecType []),R []))])) mb_ty
tcRho gr scope (ELincat cat t) mb_ty = do -- this could be done earlier, i.e. in the parser tcRho gr scope (ELincat cat t) mb_ty = do -- this could be done earlier, i.e. in the parser
@@ -216,7 +216,7 @@ tcPatt gr scope (PP c ps) ty0 =
(scope,ty) <- go scope (eval gr [] ty) ps (scope,ty) <- go scope (eval gr [] ty) ps
unify gr scope ty0 ty unify gr scope ty0 ty
return scope return scope
Bad err -> tcError (text err) Bad err -> tcError (pp err)
tcPatt gr scope (PString s) ty0 = do tcPatt gr scope (PString s) ty0 = do
unify gr scope ty0 (eval gr [] typeStr) unify gr scope ty0 (eval gr [] typeStr)
return scope return scope
@@ -252,13 +252,13 @@ inferRecFields gr scope rs =
checkRecFields gr scope [] ltys checkRecFields gr scope [] ltys
| null ltys = return [] | null ltys = return []
| otherwise = tcError (text "Missing fields:" <+> hsep (map (ppLabel . fst) ltys)) | otherwise = tcError ("Missing fields:" <+> hsep (map fst ltys))
checkRecFields gr scope ((l,t):lts) ltys = checkRecFields gr scope ((l,t):lts) ltys =
case takeIt l ltys of case takeIt l ltys of
(Just ty,ltys) -> do ltty <- tcRecField gr scope l t (Just ty) (Just ty,ltys) -> do ltty <- tcRecField gr scope l t (Just ty)
lttys <- checkRecFields gr scope lts ltys lttys <- checkRecFields gr scope lts ltys
return (ltty : lttys) return (ltty : lttys)
(Nothing,ltys) -> do tcWarn (text "Discarded field:" <+> ppLabel l) (Nothing,ltys) -> do tcWarn ("Discarded field:" <+> l)
ltty <- tcRecField gr scope l t Nothing ltty <- tcRecField gr scope l t Nothing
lttys <- checkRecFields gr scope lts ltys lttys <- checkRecFields gr scope lts ltys
return lttys -- ignore the field return lttys -- ignore the field
@@ -298,9 +298,9 @@ subsCheck gr scope t sigma1 sigma2 = do -- DEEP-SKOL
let bad_tvs = filter (`elem` esc_tvs) skol_tvs let bad_tvs = filter (`elem` esc_tvs) skol_tvs
if null bad_tvs if null bad_tvs
then return (abs t) then return (abs t)
else tcError (vcat [text "Subsumption check failed:", else tcError (vcat [pp "Subsumption check failed:",
nest 2 (ppTerm Unqualified 0 (value2term gr (scopeVars scope) sigma1)), nest 2 (ppTerm Unqualified 0 (value2term gr (scopeVars scope) sigma1)),
text "is not as polymorphic as", pp "is not as polymorphic as",
nest 2 (ppTerm Unqualified 0 (value2term gr (scopeVars scope) sigma2))]) nest 2 (ppTerm Unqualified 0 (value2term gr (scopeVars scope) sigma2))])
@@ -365,8 +365,8 @@ unify gr scope (VRecType rs1) (VRecType rs2) = do
unify gr scope v1 v2 = do unify gr scope v1 v2 = do
t1 <- zonkTerm (value2term gr (scopeVars scope) v1) t1 <- zonkTerm (value2term gr (scopeVars scope) v1)
t2 <- zonkTerm (value2term gr (scopeVars scope) v2) t2 <- zonkTerm (value2term gr (scopeVars scope) v2)
tcError (text "Cannot unify types:" <+> (ppTerm Unqualified 0 t1 $$ tcError ("Cannot unify types:" <+> (ppTerm Unqualified 0 t1 $$
ppTerm Unqualified 0 t2)) ppTerm Unqualified 0 t2))
-- | Invariant: tv1 is a flexible type variable -- | Invariant: tv1 is a flexible type variable
unifyVar :: SourceGrammar -> Scope -> MetaId -> Env -> [Value] -> Tau -> TcM () unifyVar :: SourceGrammar -> Scope -> MetaId -> Env -> [Value] -> Tau -> TcM ()
@@ -377,7 +377,7 @@ unifyVar gr scope i env vs ty2 = do -- Check whether i is bound
Unbound _ -> do let ty2' = value2term gr (scopeVars scope) ty2 Unbound _ -> do let ty2' = value2term gr (scopeVars scope) ty2
ms2 <- getMetaVars gr [(scope,ty2)] ms2 <- getMetaVars gr [(scope,ty2)]
if i `elem` ms2 if i `elem` ms2
then tcError (text "Occurs check for" <+> ppMeta i <+> text "in:" $$ then tcError ("Occurs check for" <+> ppMeta i <+> "in:" $$
nest 2 (ppTerm Unqualified 0 ty2')) nest 2 (ppTerm Unqualified 0 ty2'))
else setMeta i (Bound ty2') else setMeta i (Bound ty2')
@@ -465,7 +465,7 @@ instance Monad TcM where
f >>= g = TcM (\ms msgs -> case unTcM f ms msgs of f >>= g = TcM (\ms msgs -> case unTcM f ms msgs of
TcOk x ms msgs -> unTcM (g x) ms msgs TcOk x ms msgs -> unTcM (g x) ms msgs
TcFail msgs -> TcFail msgs) TcFail msgs -> TcFail msgs)
fail = tcError . text fail = tcError . pp
instance Functor TcM where instance Functor TcM where
fmap f g = TcM (\ms msgs -> case unTcM g ms msgs of fmap f g = TcM (\ms msgs -> case unTcM g ms msgs of
@@ -476,7 +476,7 @@ tcError :: Message -> TcM a
tcError msg = TcM (\ms msgs -> TcFail (msg : msgs)) tcError msg = TcM (\ms msgs -> TcFail (msg : msgs))
tcWarn :: Message -> TcM () tcWarn :: Message -> TcM ()
tcWarn msg = TcM (\ms msgs -> TcOk () ms ((text "Warning:" <+> msg) : msgs)) tcWarn msg = TcM (\ms msgs -> TcOk () ms (("Warning:" <+> msg) : msgs))
unimplemented str = fail ("Unimplemented: "++str) unimplemented str = fail ("Unimplemented: "++str)
@@ -494,7 +494,7 @@ getMeta :: MetaId -> TcM MetaValue
getMeta i = TcM (\ms msgs -> getMeta i = TcM (\ms msgs ->
case IntMap.lookup i ms of case IntMap.lookup i ms of
Just mv -> TcOk mv ms msgs Just mv -> TcOk mv ms msgs
Nothing -> TcFail ((text "Unknown metavariable" <+> ppMeta i) : msgs)) Nothing -> TcFail (("Unknown metavariable" <+> ppMeta i) : msgs))
setMeta :: MetaId -> MetaValue -> TcM () setMeta :: MetaId -> MetaValue -> TcM ()
setMeta i mv = TcM (\ms msgs -> TcOk () (IntMap.insert i mv ms) msgs) setMeta i mv = TcM (\ms msgs -> TcOk () (IntMap.insert i mv ms) msgs)

114
src/compiler/GF/Compile/TypeCheck/RConcrete.hs
View File

@@ -13,7 +13,7 @@ import GF.Compile.TypeCheck.Primitives
import Data.List import Data.List
import Control.Monad import Control.Monad
import Text.PrettyPrint import GF.Text.Pretty
computeLType :: SourceGrammar -> Context -> Type -> Check Type computeLType :: SourceGrammar -> Context -> Type -> Check Type
computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
@@ -22,7 +22,7 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
_ | Just _ <- isTypeInts ty -> return ty ---- shouldn't be needed _ | Just _ <- isTypeInts ty -> return ty ---- shouldn't be needed
| isPredefConstant ty -> return ty ---- shouldn't be needed | isPredefConstant ty -> return ty ---- shouldn't be needed
Q (m,ident) -> checkIn (text "module" <+> ppIdent m) $ do Q (m,ident) -> checkIn ("module" <+> m) $ do
ty' <- lookupResDef gr (m,ident) ty' <- lookupResDef gr (m,ident)
if ty' == ty then return ty else comp g ty' --- is this necessary to test? if ty' == ty then return ty else comp g ty' --- is this necessary to test?
@@ -30,7 +30,7 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
over <- getOverload gr g (Just typeType) t over <- getOverload gr g (Just typeType) t
case over of case over of
Just (tr,_) -> return tr Just (tr,_) -> return tr
_ -> checkError (text "unresolved overloading of constants" <+> ppTerm Qualified 0 t) _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 t)
Vr ident -> checkLookup ident g -- never needed to compute! Vr ident -> checkLookup ident g -- never needed to compute!
@@ -79,26 +79,26 @@ inferLType gr g trm = case trm of
Q (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of Q (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of
Just ty -> return ty Just ty -> return ty
Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident) Nothing -> checkError ("unknown in Predef:" <+> ident)
Q ident -> checks [ Q ident -> checks [
termWith trm $ lookupResType gr ident >>= computeLType gr g termWith trm $ lookupResType gr ident >>= computeLType gr g
, ,
lookupResDef gr ident >>= inferLType gr g lookupResDef gr ident >>= inferLType gr g
, ,
checkError (text "cannot infer type of constant" <+> ppTerm Unqualified 0 trm) checkError ("cannot infer type of constant" <+> ppTerm Unqualified 0 trm)
] ]
QC (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of QC (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of
Just ty -> return ty Just ty -> return ty
Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident) Nothing -> checkError ("unknown in Predef:" <+> ident)
QC ident -> checks [ QC ident -> checks [
termWith trm $ lookupResType gr ident >>= computeLType gr g termWith trm $ lookupResType gr ident >>= computeLType gr g
, ,
lookupResDef gr ident >>= inferLType gr g lookupResDef gr ident >>= inferLType gr g
, ,
checkError (text "cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm) checkError ("cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm)
] ]
Vr ident -> termWith trm $ checkLookup ident g Vr ident -> termWith trm $ checkLookup ident g
@@ -111,7 +111,7 @@ inferLType gr g trm = case trm of
over <- getOverload gr g Nothing trm over <- getOverload gr g Nothing trm
case over of case over of
Just trty -> return trty Just trty -> return trty
_ -> checkError (text "unresolved overloading of constants" <+> ppTerm Qualified 0 trm) _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm)
App f a -> do App f a -> do
over <- getOverload gr g Nothing trm over <- getOverload gr g Nothing trm
@@ -127,7 +127,7 @@ inferLType gr g trm = case trm of
then return val then return val
else substituteLType [(bt,z,a')] val else substituteLType [(bt,z,a')] val
return (App f' a',ty) return (App f' a',ty)
_ -> checkError (text "A function type is expected for" <+> ppTerm Unqualified 0 f <+> text "instead of type" <+> ppType fty) _ -> checkError ("A function type is expected for" <+> ppTerm Unqualified 0 f <+> "instead of type" <+> ppType fty)
S f x -> do S f x -> do
(f', fty) <- inferLType gr g f (f', fty) <- inferLType gr g f
@@ -135,7 +135,7 @@ inferLType gr g trm = case trm of
Table arg val -> do Table arg val -> do
x'<- justCheck g x arg x'<- justCheck g x arg
return (S f' x', val) return (S f' x', val)
_ -> checkError (text "table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm)) _ -> checkError ("table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm))
P t i -> do P t i -> do
(t',ty) <- inferLType gr g t --- ?? (t',ty) <- inferLType gr g t --- ??
@@ -143,16 +143,16 @@ inferLType gr g trm = case trm of
let tr2 = P t' i let tr2 = P t' i
termWith tr2 $ case ty' of termWith tr2 $ case ty' of
RecType ts -> case lookup i ts of RecType ts -> case lookup i ts of
Nothing -> checkError (text "unknown label" <+> ppLabel i <+> text "in" $$ nest 2 (ppTerm Unqualified 0 ty')) Nothing -> checkError ("unknown label" <+> i <+> "in" $$ nest 2 (ppTerm Unqualified 0 ty'))
Just x -> return x Just x -> return x
_ -> checkError (text "record type expected for:" <+> ppTerm Unqualified 0 t $$ _ -> checkError ("record type expected for:" <+> ppTerm Unqualified 0 t $$
text " instead of the inferred:" <+> ppTerm Unqualified 0 ty') " instead of the inferred:" <+> ppTerm Unqualified 0 ty')
R r -> do R r -> do
let (ls,fs) = unzip r let (ls,fs) = unzip r
fsts <- mapM inferM fs fsts <- mapM inferM fs
let ts = [ty | (Just ty,_) <- fsts] let ts = [ty | (Just ty,_) <- fsts]
checkCond (text "cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 trm)) (length ts == length fsts) checkCond ("cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 trm)) (length ts == length fsts)
return $ (R (zip ls fsts), RecType (zip ls ts)) return $ (R (zip ls fsts), RecType (zip ls ts))
T (TTyped arg) pts -> do T (TTyped arg) pts -> do
@@ -164,7 +164,7 @@ inferLType gr g trm = case trm of
T ti pts -> do -- tries to guess: good in oper type inference T ti pts -> do -- tries to guess: good in oper type inference
let pts' = [pt | pt@(p,_) <- pts, isConstPatt p] let pts' = [pt | pt@(p,_) <- pts, isConstPatt p]
case pts' of case pts' of
[] -> checkError (text "cannot infer table type of" <+> ppTerm Unqualified 0 trm) [] -> checkError ("cannot infer table type of" <+> ppTerm Unqualified 0 trm)
---- PInt k : _ -> return $ Ints $ max [i | PInt i <- pts'] ---- PInt k : _ -> return $ Ints $ max [i | PInt i <- pts']
_ -> do _ -> do
(arg,val) <- checks $ map (inferCase Nothing) pts' (arg,val) <- checks $ map (inferCase Nothing) pts'
@@ -198,7 +198,7 @@ inferLType gr g trm = case trm of
---- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007 ---- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007
Strs (Cn c : ts) | c == cConflict -> do Strs (Cn c : ts) | c == cConflict -> do
checkWarn (text "unresolved constant, could be any of" <+> hcat (map (ppTerm Unqualified 0) ts)) checkWarn ("unresolved constant, could be any of" <+> hcat (map (ppTerm Unqualified 0) ts))
inferLType gr g (head ts) inferLType gr g (head ts)
Strs ts -> do Strs ts -> do
@@ -231,7 +231,7 @@ inferLType gr g trm = case trm of
checkLType gr g trm' rt ---- return (trm', rt) checkLType gr g trm' rt ---- return (trm', rt)
_ | rT' == typeType && sT' == typeType -> do _ | rT' == typeType && sT' == typeType -> do
return (trm', typeType) return (trm', typeType)
_ -> checkError (text "records or record types expected in" <+> ppTerm Unqualified 0 trm) _ -> checkError ("records or record types expected in" <+> ppTerm Unqualified 0 trm)
Sort _ -> Sort _ ->
termWith trm $ return typeType termWith trm $ return typeType
@@ -263,7 +263,7 @@ inferLType gr g trm = case trm of
ty' <- lockRecType c ty ---- lookup c; remove lock AR 20/6/2009 ty' <- lockRecType c ty ---- lookup c; remove lock AR 20/6/2009
return $ (ELin c trm', ty') return $ (ELin c trm', ty')
_ -> checkError (text "cannot infer lintype of" <+> ppTerm Unqualified 0 trm) _ -> checkError ("cannot infer lintype of" <+> ppTerm Unqualified 0 trm)
where where
isPredef m = elem m [cPredef,cPredefAbs] isPredef m = elem m [cPredef,cPredefAbs]
@@ -352,25 +352,25 @@ getOverload gr g mt ot = case appForm ot of
case ([vf | (vf,True) <- matches],[vf | (vf,False) <- matches]) of case ([vf | (vf,True) <- matches],[vf | (vf,False) <- matches]) of
([(_,val,fun)],_) -> return (mkApp fun tts, val) ([(_,val,fun)],_) -> return (mkApp fun tts, val)
([],[(pre,val,fun)]) -> do ([],[(pre,val,fun)]) -> do
checkWarn $ text "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot $$ checkWarn $ "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot $$
text "for" $$ "for" $$
nest 2 (showTypes tys) $$ nest 2 (showTypes tys) $$
text "using" $$ "using" $$
nest 2 (showTypes pre) nest 2 (showTypes pre)
return (mkApp fun tts, val) return (mkApp fun tts, val)
([],[]) -> do ([],[]) -> do
checkError $ text "no overload instance of" <+> ppTerm Unqualified 0 f $$ checkError $ "no overload instance of" <+> ppTerm Unqualified 0 f $$
text "for" $$ "for" $$
nest 2 stysError $$ nest 2 stysError $$
text "among" $$ "among" $$
nest 2 (vcat stypsError) $$ nest 2 (vcat stypsError) $$
maybe empty (\x -> text "with value type" <+> ppType x) mt maybe empty (\x -> "with value type" <+> ppType x) mt
(vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of (vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of
([(val,fun)],_) -> do ([(val,fun)],_) -> do
return (mkApp fun tts, val) return (mkApp fun tts, val)
([],[(val,fun)]) -> do ([],[(val,fun)]) -> do
checkWarn (text "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot) checkWarn ("ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot)
return (mkApp fun tts, val) return (mkApp fun tts, val)
----- unsafely exclude irritating warning AR 24/5/2008 ----- unsafely exclude irritating warning AR 24/5/2008
@@ -382,9 +382,9 @@ getOverload gr g mt ot = case appForm ot of
-- This gives ad hoc overloading the same behaviour as the choice of the first match in renaming did before. -- This gives ad hoc overloading the same behaviour as the choice of the first match in renaming did before.
-- But it also gives a chance to ambiguous overloadings that were banned before. -- But it also gives a chance to ambiguous overloadings that were banned before.
(nps1,nps2) -> do (nps1,nps2) -> do
checkWarn $ text "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+> checkWarn $ "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+>
---- text "with argument types" <+> hsep (map (ppTerm Qualified 0) tys) $$ ---- "with argument types" <+> hsep (map (ppTerm Qualified 0) tys) $$
text "resolved by selecting the first of the alternatives" $$ "resolved by selecting the first of the alternatives" $$
nest 2 (vcat [ppTerm Qualified 0 fun | (_,ty,fun) <- vfs1 ++ if null vfs1 then vfs2 else []]) nest 2 (vcat [ppTerm Qualified 0 fun | (_,ty,fun) <- vfs1 ++ if null vfs1 then vfs2 else []])
return $ head [(mkApp fun tts,val) | (val,fun) <- nps1 ++ nps2] return $ head [(mkApp fun tts,val) | (val,fun) <- nps1 ++ nps2]
@@ -421,10 +421,10 @@ checkLType gr g trm typ0 = do
Prod bt' z a b -> do Prod bt' z a b -> do
(c',b') <- if isWildIdent z (c',b') <- if isWildIdent z
then checkLType gr ((bt,x,a):g) c b then checkLType gr ((bt,x,a):g) c b
else do b' <- checkIn (text "abs") $ substituteLType [(bt',z,Vr x)] b else do b' <- checkIn (pp "abs") $ substituteLType [(bt',z,Vr x)] b
checkLType gr ((bt,x,a):g) c b' checkLType gr ((bt,x,a):g) c b'
return $ (Abs bt x c', Prod bt' x a b') return $ (Abs bt x c', Prod bt' x a b')
_ -> checkError $ text "function type expected instead of" <+> ppType typ _ -> checkError $ "function type expected instead of" <+> ppType typ
App f a -> do App f a -> do
over <- getOverload gr g (Just typ) trm over <- getOverload gr g (Just typ) trm
@@ -438,7 +438,7 @@ checkLType gr g trm typ0 = do
over <- getOverload gr g Nothing trm over <- getOverload gr g Nothing trm
case over of case over of
Just trty -> return trty Just trty -> return trty
_ -> checkError (text "unresolved overloading of constants" <+> ppTerm Qualified 0 trm) _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm)
Q _ -> do Q _ -> do
over <- getOverload gr g (Just typ) trm over <- getOverload gr g (Just typ) trm
@@ -449,7 +449,7 @@ checkLType gr g trm typ0 = do
termWith trm' $ checkEqLType gr g typ ty' trm' termWith trm' $ checkEqLType gr g typ ty' trm'
T _ [] -> T _ [] ->
checkError (text "found empty table in type" <+> ppTerm Unqualified 0 typ) checkError ("found empty table in type" <+> ppTerm Unqualified 0 typ)
T _ cs -> case typ of T _ cs -> case typ of
Table arg val -> do Table arg val -> do
case allParamValues gr arg of case allParamValues gr arg of
@@ -458,12 +458,12 @@ checkLType gr g trm typ0 = do
ps <- testOvershadow ps0 vs ps <- testOvershadow ps0 vs
if null ps if null ps
then return () then return ()
else checkWarn (text "patterns never reached:" $$ else checkWarn ("patterns never reached:" $$
nest 2 (vcat (map (ppPatt Unqualified 0) ps))) nest 2 (vcat (map (ppPatt Unqualified 0) ps)))
_ -> return () -- happens with variable types _ -> return () -- happens with variable types
cs' <- mapM (checkCase arg val) cs cs' <- mapM (checkCase arg val) cs
return (T (TTyped arg) cs', typ) return (T (TTyped arg) cs', typ)
_ -> checkError $ text "table type expected for table instead of" $$ nest 2 (ppType typ) _ -> checkError $ "table type expected for table instead of" $$ nest 2 (ppType typ)
V arg0 vs -> V arg0 vs ->
case typ of case typ of
Table arg1 val -> Table arg1 val ->
@@ -477,7 +477,7 @@ checkLType gr g trm typ0 = do
fsts <- mapM (checkM r) rr -- check that they are found in the record fsts <- mapM (checkM r) rr -- check that they are found in the record
return $ (R fsts, typ) -- normalize record return $ (R fsts, typ) -- normalize record
_ -> checkError (text "record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ)) _ -> checkError ("record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ))
ExtR r s -> case typ of ExtR r s -> case typ of
_ | typ == typeType -> do _ | typ == typeType -> do
@@ -486,7 +486,7 @@ checkLType gr g trm typ0 = do
RecType _ -> termWith trm' $ return typeType RecType _ -> termWith trm' $ return typeType
ExtR (Vr _) (RecType _) -> termWith trm' $ return typeType ExtR (Vr _) (RecType _) -> termWith trm' $ return typeType
-- ext t = t ** ... -- ext t = t ** ...
_ -> checkError (text "invalid record type extension" <+> nest 2 (ppTerm Unqualified 0 trm)) _ -> checkError ("invalid record type extension" <+> nest 2 (ppTerm Unqualified 0 trm))
RecType rr -> do RecType rr -> do
@@ -496,7 +496,7 @@ checkLType gr g trm typ0 = do
(s',typ2) <- inferLType gr g s (s',typ2) <- inferLType gr g s
case typ2 of case typ2 of
RecType ss -> return $ map fst ss RecType ss -> return $ map fst ss
_ -> checkError (text "cannot get labels from" $$ nest 2 (ppTerm Unqualified 0 typ2)) _ -> checkError ("cannot get labels from" $$ nest 2 (ppTerm Unqualified 0 typ2))
let ll1 = [l | (l,_) <- rr, notElem l ll2] let ll1 = [l | (l,_) <- rr, notElem l ll2]
(r',_) <- checkLType gr g r (RecType [field | field@(l,_) <- rr, elem l ll1]) (r',_) <- checkLType gr g r (RecType [field | field@(l,_) <- rr, elem l ll1])
(s',_) <- checkLType gr g s (RecType [field | field@(l,_) <- rr, elem l ll2]) (s',_) <- checkLType gr g s (RecType [field | field@(l,_) <- rr, elem l ll2])
@@ -509,7 +509,7 @@ checkLType gr g trm typ0 = do
s' <- justCheck g s ex s' <- justCheck g s ex
return $ (ExtR r' s', typ) --- is this all? it assumes the same division in trm and typ return $ (ExtR r' s', typ) --- is this all? it assumes the same division in trm and typ
_ -> checkError (text "record extension not meaningful for" <+> ppTerm Unqualified 0 typ) _ -> checkError ("record extension not meaningful for" <+> ppTerm Unqualified 0 typ)
FV vs -> do FV vs -> do
ttys <- mapM (flip (checkLType gr g) typ) vs ttys <- mapM (flip (checkLType gr g) typ) vs
@@ -524,7 +524,7 @@ checkLType gr g trm typ0 = do
(arg',val) <- checkLType gr g arg p (arg',val) <- checkLType gr g arg p
checkEqLType gr g typ t trm checkEqLType gr g typ t trm
return (S tab' arg', t) return (S tab' arg', t)
_ -> checkError (text "table type expected for applied table instead of" <+> ppType ty') _ -> checkError ("table type expected for applied table instead of" <+> ppType ty')
, do , do
(arg',ty) <- inferLType gr g arg (arg',ty) <- inferLType gr g arg
ty' <- computeLType gr g ty ty' <- computeLType gr g ty
@@ -565,9 +565,9 @@ checkLType gr g trm typ0 = do
_ -> checkError $ _ -> checkError $
if isLockLabel l if isLockLabel l
then let cat = drop 5 (showIdent (label2ident l)) then let cat = drop 5 (showIdent (label2ident l))
in ppTerm Unqualified 0 (R rms) <+> text "is not in the lincat of" <+> text cat <> in ppTerm Unqualified 0 (R rms) <+> "is not in the lincat of" <+> cat <>
text "; try wrapping it with lin" <+> text cat "; try wrapping it with lin" <+> cat
else text "cannot find value for label" <+> ppLabel l <+> text "in" <+> ppTerm Unqualified 0 (R rms) else "cannot find value for label" <+> l <+> "in" <+> ppTerm Unqualified 0 (R rms)
checkCase arg val (p,t) = do checkCase arg val (p,t) = do
cont <- pattContext gr g arg p cont <- pattContext gr g arg p
@@ -580,7 +580,7 @@ pattContext env g typ p = case p of
PP (q,c) ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006 PP (q,c) ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006
t <- lookupResType env (q,c) t <- lookupResType env (q,c)
let (cont,v) = typeFormCnc t let (cont,v) = typeFormCnc t
checkCond (text "wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p) checkCond ("wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p)
(length cont == length ps) (length cont == length ps)
checkEqLType env g typ v (patt2term p) checkEqLType env g typ v (patt2term p)
mapM (\((_,_,ty),p) -> pattContext env g ty p) (zip cont ps) >>= return . concat mapM (\((_,_,ty),p) -> pattContext env g ty p) (zip cont ps) >>= return . concat
@@ -591,7 +591,7 @@ pattContext env g typ p = case p of
let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]] let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]]
----- checkWarn $ prt p ++++ show pts ----- debug ----- checkWarn $ prt p ++++ show pts ----- debug
mapM (uncurry (pattContext env g)) pts >>= return . concat mapM (uncurry (pattContext env g)) pts >>= return . concat
_ -> checkError (text "record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ') _ -> checkError ("record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ')
PT t p' -> do PT t p' -> do
checkEqLType env g typ t (patt2term p') checkEqLType env g typ t (patt2term p')
pattContext env g typ p' pattContext env g typ p'
@@ -605,9 +605,9 @@ pattContext env g typ p = case p of
g2 <- pattContext env g typ q g2 <- pattContext env g typ q
let pts = nub ([x | pt@(_,x,_) <- g1, notElem pt g2] ++ [x | pt@(_,x,_) <- g2, notElem pt g1]) let pts = nub ([x | pt@(_,x,_) <- g1, notElem pt g2] ++ [x | pt@(_,x,_) <- g2, notElem pt g1])
checkCond checkCond
(text "incompatible bindings of" <+> ("incompatible bindings of" <+>
fsep (map ppIdent pts) <+> fsep pts <+>
text "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts) "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts)
return g1 -- must be g1 == g2 return g1 -- must be g1 == g2
PSeq p q -> do PSeq p q -> do
g1 <- pattContext env g typ p g1 <- pattContext env g typ p
@@ -621,7 +621,7 @@ pattContext env g typ p = case p of
noBind typ p' = do noBind typ p' = do
co <- pattContext env g typ p' co <- pattContext env g typ p'
if not (null co) if not (null co)
then checkWarn (text "no variable bound inside pattern" <+> ppPatt Unqualified 0 p) then checkWarn ("no variable bound inside pattern" <+> ppPatt Unqualified 0 p)
>> return [] >> return []
else return [] else return []
@@ -630,9 +630,9 @@ checkEqLType gr g t u trm = do
(b,t',u',s) <- checkIfEqLType gr g t u trm (b,t',u',s) <- checkIfEqLType gr g t u trm
case b of case b of
True -> return t' True -> return t'
False -> checkError $ text s <+> text "type of" <+> ppTerm Unqualified 0 trm $$ False -> checkError $ s <+> "type of" <+> ppTerm Unqualified 0 trm $$
text "expected:" <+> ppTerm Qualified 0 t $$ -- ppqType t u $$ "expected:" <+> ppTerm Qualified 0 t $$ -- ppqType t u $$
text "inferred:" <+> ppTerm Qualified 0 u -- ppqType u t "inferred:" <+> ppTerm Qualified 0 u -- ppqType u t
checkIfEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check (Bool,Type,Type,String) checkIfEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check (Bool,Type,Type,String)
checkIfEqLType gr g t u trm = do checkIfEqLType gr g t u trm = do
@@ -644,7 +644,7 @@ checkIfEqLType gr g t u trm = do
--- better: use a flag to forgive? (AR 31/1/2006) --- better: use a flag to forgive? (AR 31/1/2006)
_ -> case missingLock [] t' u' of _ -> case missingLock [] t' u' of
Ok lo -> do Ok lo -> do
checkWarn $ text "missing lock field" <+> fsep (map ppLabel lo) checkWarn $ "missing lock field" <+> fsep lo
return (True,t',u',[]) return (True,t',u',[])
Bad s -> return (False,t',u',s) Bad s -> return (False,t',u',s)
@@ -699,7 +699,7 @@ checkIfEqLType gr g t u trm = do
not (any (\ (k,b) -> alpha g a b && l == k) ts)] not (any (\ (k,b) -> alpha g a b && l == k) ts)]
(locks,others) = partition isLockLabel ls (locks,others) = partition isLockLabel ls
in case others of in case others of
_:_ -> Bad $ render (text "missing record fields:" <+> fsep (punctuate comma (map ppLabel others))) _:_ -> Bad $ render ("missing record fields:" <+> fsep (punctuate ',' (others)))
_ -> return locks _ -> return locks
-- contravariance -- contravariance
(Prod _ x a b, Prod _ y c d) -> do (Prod _ x a b, Prod _ y c d) -> do
@@ -737,9 +737,9 @@ ppType :: Type -> Doc
ppType ty = ppType ty =
case ty of case ty of
RecType fs -> case filter isLockLabel $ map fst fs of RecType fs -> case filter isLockLabel $ map fst fs of
[lock] -> text (drop 5 (showIdent (label2ident lock))) [lock] -> pp (drop 5 (showIdent (label2ident lock)))
_ -> ppTerm Unqualified 0 ty _ -> ppTerm Unqualified 0 ty
Prod _ x a b -> ppType a <+> text "->" <+> ppType b Prod _ x a b -> ppType a <+> "->" <+> ppType b
_ -> ppTerm Unqualified 0 ty _ -> ppTerm Unqualified 0 ty
ppqType :: Type -> Type -> Doc ppqType :: Type -> Type -> Doc
@@ -750,5 +750,5 @@ ppqType t u = case (ppType t, ppType u) of
checkLookup :: Ident -> Context -> Check Type checkLookup :: Ident -> Context -> Check Type
checkLookup x g = checkLookup x g =
case [ty | (b,y,ty) <- g, x == y] of case [ty | (b,y,ty) <- g, x == y] of
[] -> checkError (text "unknown variable" <+> ppIdent x) [] -> checkError ("unknown variable" <+> x)
(ty:_) -> return ty (ty:_) -> return ty

22
src/compiler/GF/Compile/TypeCheck/TC.hs
View File

@@ -28,7 +28,7 @@ import GF.Grammar.Predef
import Control.Monad import Control.Monad
--import Data.List (sortBy) --import Data.List (sortBy)
import Data.Maybe import Data.Maybe
import Text.PrettyPrint import GF.Text.Pretty
data AExp = data AExp =
AVr Ident Val AVr Ident Val
@@ -57,7 +57,7 @@ lookupConst :: Theory -> QIdent -> Err Val
lookupConst th f = th f lookupConst th f = th f
lookupVar :: Env -> Ident -> Err Val lookupVar :: Env -> Ident -> Err Val
lookupVar g x = maybe (Bad (render (text "unknown variable" <+> ppIdent x))) return $ lookup x ((identW,uVal):g) lookupVar g x = maybe (Bad (render ("unknown variable" <+> x))) return $ lookup x ((identW,uVal):g)
-- wild card IW: no error produced, ?0 instead. -- wild card IW: no error produced, ?0 instead.
type TCEnv = (Int,Env,Env) type TCEnv = (Int,Env,Env)
@@ -129,7 +129,7 @@ checkExp th tenv@(k,rho,gamma) e ty = do
(t',cs) <- checkExp th (t',cs) <- checkExp th
(k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b) (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
return (AAbs x a' t', cs) return (AAbs x a' t', cs)
_ -> Bad (render (text "function type expected for" <+> ppTerm Unqualified 0 e <+> text "instead of" <+> ppValue Unqualified 0 typ)) _ -> Bad (render ("function type expected for" <+> ppTerm Unqualified 0 e <+> "instead of" <+> ppValue Unqualified 0 typ))
Prod _ x a b -> do Prod _ x a b -> do
testErr (typ == vType) "expected Type" testErr (typ == vType) "expected Type"
@@ -141,11 +141,11 @@ checkExp th tenv@(k,rho,gamma) e ty = do
case typ of case typ of
VRecType ys -> do case [l | (l,_) <- ys, isNothing (lookup l xs)] of VRecType ys -> do case [l | (l,_) <- ys, isNothing (lookup l xs)] of
[] -> return () [] -> return ()
ls -> fail (render (text "no value given for label:" <+> fsep (punctuate comma (map ppLabel ls)))) ls -> fail (render ("no value given for label:" <+> fsep (punctuate ',' ls)))
r <- mapM (checkAssign th tenv ys) xs r <- mapM (checkAssign th tenv ys) xs
let (xs,css) = unzip r let (xs,css) = unzip r
return (AR xs, concat css) return (AR xs, concat css)
_ -> Bad (render (text "record type expected for" <+> ppTerm Unqualified 0 e <+> text "instead of" <+> ppValue Unqualified 0 typ)) _ -> Bad (render ("record type expected for" <+> ppTerm Unqualified 0 e <+> "instead of" <+> ppValue Unqualified 0 typ))
P r l -> do (r',cs) <- checkExp th tenv r (VRecType [(l,typ)]) P r l -> do (r',cs) <- checkExp th tenv r (VRecType [(l,typ)])
return (AP r' l typ,cs) return (AP r' l typ,cs)
@@ -180,8 +180,8 @@ inferExp th tenv@(k,rho,gamma) e = case e of
(a',csa) <- checkExp th tenv t (VClos env a) (a',csa) <- checkExp th tenv t (VClos env a)
b' <- whnf $ VClos ((x,VClos rho t):env) b b' <- whnf $ VClos ((x,VClos rho t):env) b
return $ (AApp f' a' b', b', csf ++ csa) return $ (AApp f' a' b', b', csf ++ csa)
_ -> Bad (render (text "Prod expected for function" <+> ppTerm Unqualified 0 f <+> text "instead of" <+> ppValue Unqualified 0 typ)) _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
_ -> Bad (render (text "cannot infer type of expression" <+> ppTerm Unqualified 0 e)) _ -> Bad (render ("cannot infer type of expression" <+> ppTerm Unqualified 0 e))
checkLabelling :: Theory -> TCEnv -> Labelling -> Err (ALabelling, [(Val,Val)]) checkLabelling :: Theory -> TCEnv -> Labelling -> Err (ALabelling, [(Val,Val)])
checkLabelling th tenv (lbl,typ) = do checkLabelling th tenv (lbl,typ) = do
@@ -223,7 +223,7 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
let tenv' = (length binds, sigma ++ rho, binds ++ gamma) let tenv' = (length binds, sigma ++ rho, binds ++ gamma)
((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b) ((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b)
return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
_ -> Bad (render (text "Product expected for definiens" <+> ppTerm Unqualified 0 t <+> text "instead of" <+> ppValue Unqualified 0 typ)) _ -> Bad (render ("Product expected for definiens" <+> ppTerm Unqualified 0 t <+> "instead of" <+> ppValue Unqualified 0 typ))
[] -> do [] -> do
(e,cs) <- checkExp th tenv t ty (e,cs) <- checkExp th tenv t ty
return (([],e),cs) return (([],e),cs)
@@ -244,7 +244,7 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
where (xss,j,g',k') = foldr p2t ([],i,g,k) xs where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
PImplArg p -> p2t p (ps,i,g,k) PImplArg p -> p2t p (ps,i,g,k)
PTilde t -> (t : ps, i, g, k) PTilde t -> (t : ps, i, g, k)
_ -> error $ render (text "undefined p2t case" <+> ppPatt Unqualified 0 p <+> text "in checkBranch") _ -> error $ render ("undefined p2t case" <+> ppPatt Unqualified 0 p <+> "in checkBranch")
upd x k g = (x, VGen k x) : g --- hack to recognize pattern variables upd x k g = (x, VGen k x) : g --- hack to recognize pattern variables
@@ -282,8 +282,8 @@ checkPatt th tenv exp val = do
(a',_,csa) <- checkExpP tenv t (VClos env a) (a',_,csa) <- checkExpP tenv t (VClos env a)
b' <- whnf $ VClos ((x,VClos rho t):env) b b' <- whnf $ VClos ((x,VClos rho t):env) b
return $ (AApp f' a' b', b', csf ++ csa) return $ (AApp f' a' b', b', csf ++ csa)
_ -> Bad (render (text "Prod expected for function" <+> ppTerm Unqualified 0 f <+> text "instead of" <+> ppValue Unqualified 0 typ)) _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
_ -> Bad (render (text "cannot typecheck pattern" <+> ppTerm Unqualified 0 exp)) _ -> Bad (render ("cannot typecheck pattern" <+> ppTerm Unqualified 0 exp))
-- auxiliaries -- auxiliaries

22
src/compiler/GF/Compile/Update.hs
View File

@@ -26,7 +26,7 @@ import GF.Data.Operations
import Data.List import Data.List
import qualified Data.Map as Map import qualified Data.Map as Map
import Control.Monad import Control.Monad
import Text.PrettyPrint import GF.Text.Pretty
-- | combine a list of definitions into a balanced binary search tree -- | combine a list of definitions into a balanced binary search tree
buildAnyTree :: Monad m => Ident -> [(Ident,Info)] -> m (BinTree Ident Info) buildAnyTree :: Monad m => Ident -> [(Ident,Info)] -> m (BinTree Ident Info)
@@ -37,9 +37,9 @@ buildAnyTree m = go Map.empty
case Map.lookup c map of case Map.lookup c map of
Just i -> case unifyAnyInfo m i j of Just i -> case unifyAnyInfo m i j of
Ok k -> go (Map.insert c k map) is Ok k -> go (Map.insert c k map) is
Bad _ -> fail $ render (text "conflicting information in module"<+>ppIdent m $$ Bad _ -> fail $ render ("conflicting information in module"<+>m $$
nest 4 (ppJudgement Qualified (c,i)) $$ nest 4 (ppJudgement Qualified (c,i)) $$
text "and" $+$ "and" $+$
nest 4 (ppJudgement Qualified (c,j))) nest 4 (ppJudgement Qualified (c,j)))
Nothing -> go (Map.insert c j map) is Nothing -> go (Map.insert c j map) is
@@ -58,7 +58,7 @@ extendModule cwd gr (name,m)
-- test that the module types match, and find out if the old is complete -- test that the module types match, and find out if the old is complete
unless (sameMType (mtype m) (mtype mo)) unless (sameMType (mtype m) (mtype mo))
(checkError (text "illegal extension type to module" <+> ppIdent name)) (checkError ("illegal extension type to module" <+> name))
let isCompl = isCompleteModule m0 let isCompl = isCompleteModule m0
@@ -88,13 +88,13 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
-- add the information given in interface into an instance module -- add the information given in interface into an instance module
Nothing -> do Nothing -> do
unless (null is || mstatus mi == MSIncomplete) unless (null is || mstatus mi == MSIncomplete)
(checkError (text "module" <+> ppIdent i <+> (checkError ("module" <+> i <+>
text "has open interfaces and must therefore be declared incomplete")) "has open interfaces and must therefore be declared incomplete"))
case mt of case mt of
MTInstance (i0,mincl) -> do MTInstance (i0,mincl) -> do
m1 <- lookupModule gr i0 m1 <- lookupModule gr i0
unless (isModRes m1) unless (isModRes m1)
(checkError (text "interface expected instead of" <+> ppIdent i0)) (checkError ("interface expected instead of" <+> i0))
js' <- extendMod gr False ((i0,m1), isInherited mincl) i (jments mi) js' <- extendMod gr False ((i0,m1), isInherited mincl) i (jments mi)
--- to avoid double inclusions, in instance I of I0 = J0 ** ... --- to avoid double inclusions, in instance I of I0 = J0 ** ...
case extends mi of case extends mi of
@@ -112,7 +112,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
let stat' = ifNull MSComplete (const MSIncomplete) let stat' = ifNull MSComplete (const MSIncomplete)
[i | i <- is, notElem i infs] [i | i <- is, notElem i infs]
unless (stat' == MSComplete || stat == MSIncomplete) unless (stat' == MSComplete || stat == MSIncomplete)
(checkError (text "module" <+> ppIdent i <+> text "remains incomplete")) (checkError ("module" <+> i <+> "remains incomplete"))
ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext
let ops1 = nub $ let ops1 = nub $
ops_ ++ -- N.B. js has been name-resolved already ops_ ++ -- N.B. js has been name-resolved already
@@ -149,11 +149,11 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme
(name,i) <- case i of (name,i) <- case i of
AnyInd _ m -> lookupOrigInfo gr (m,c) AnyInd _ m -> lookupOrigInfo gr (m,c)
_ -> return (name,i) _ -> return (name,i)
checkError (text "cannot unify the information" $$ checkError ("cannot unify the information" $$
nest 4 (ppJudgement Qualified (c,i)) $$ nest 4 (ppJudgement Qualified (c,i)) $$
text "in module" <+> ppIdent name <+> text "with" $$ "in module" <+> name <+> "with" $$
nest 4 (ppJudgement Qualified (c,j)) $$ nest 4 (ppJudgement Qualified (c,j)) $$
text "in module" <+> ppIdent base) "in module" <+> base)
Nothing-> if isCompl Nothing-> if isCompl
then return $ updateTree (c,indirInfo name i) new then return $ updateTree (c,indirInfo name i) new
else return $ updateTree (c,i) new else return $ updateTree (c,i) new

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

@@ -36,7 +36,7 @@ module GF.Grammar.Grammar (
PMCFG(..), Production(..), FId, FunId, SeqId, LIndex, Sequence, PMCFG(..), Production(..), FId, FunId, SeqId, LIndex, Sequence,
Info(..), Info(..),
Location(..), L(..), unLoc, noLoc, Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
Type, Type,
Cat, Cat,
Fun, Fun,
@@ -63,6 +63,7 @@ module GF.Grammar.Grammar (
import GF.Infra.Ident import GF.Infra.Ident
import GF.Infra.Option --- import GF.Infra.Option ---
import GF.Infra.Location
import GF.Data.Operations import GF.Data.Operations
@@ -74,7 +75,7 @@ import Data.Array.Unboxed
import qualified Data.Map as Map import qualified Data.Map as Map
--import qualified Data.Set as Set --import qualified Data.Set as Set
--import qualified Data.IntMap as IntMap --import qualified Data.IntMap as IntMap
import Text.PrettyPrint import GF.Text.Pretty
--import System.FilePath --import System.FilePath
--import Control.Monad.Identity --import Control.Monad.Identity
@@ -98,6 +99,8 @@ data SourceModInfo = ModInfo {
jments :: Map.Map Ident Info jments :: Map.Map Ident Info
} }
instance HasSourcePath SourceModInfo where sourcePath = msrc
type SourceModule = (Ident, SourceModInfo) type SourceModule = (Ident, SourceModInfo)
-- | encoding the type of the module -- | encoding the type of the module
@@ -200,12 +203,12 @@ abstractOfConcrete gr c = do
n <- lookupModule gr c n <- lookupModule gr c
case mtype n of case mtype n of
MTConcrete a -> return a MTConcrete a -> return a
_ -> raise $ render (text "expected concrete" <+> ppIdent c) _ -> raise $ render ("expected concrete" <+> c)
lookupModule :: ErrorMonad m => SourceGrammar -> Ident -> m SourceModInfo lookupModule :: ErrorMonad m => SourceGrammar -> Ident -> m SourceModInfo
lookupModule gr m = case Map.lookup m (moduleMap gr) of lookupModule gr m = case Map.lookup m (moduleMap gr) of
Just i -> return i Just i -> return i
Nothing -> raise $ render (text "unknown module" <+> ppIdent m <+> text "among" <+> hsep (map (ppIdent . fst) (modules gr))) Nothing -> raise $ render ("unknown module" <+> m <+> "among" <+> hsep (map fst (modules gr)))
isModAbs :: SourceModInfo -> Bool isModAbs :: SourceModInfo -> Bool
isModAbs m = isModAbs m =
@@ -263,7 +266,7 @@ allAbstracts :: SourceGrammar -> [Ident]
allAbstracts gr = allAbstracts gr =
case topoTest [(i,extends m) | (i,m) <- modules gr, mtype m == MTAbstract] of case topoTest [(i,extends m) | (i,m) <- modules gr, mtype m == MTAbstract] of
Left is -> is Left is -> is
Right cycles -> error $ render (text "Cyclic abstract modules:" <+> vcat (map (hsep . map ppIdent) cycles)) Right cycles -> error $ render ("Cyclic abstract modules:" <+> vcat (map hsep cycles))
-- | the last abstract in dependency order (head of list) -- | the last abstract in dependency order (head of list)
greatestAbstract :: SourceGrammar -> Maybe Ident greatestAbstract :: SourceGrammar -> Maybe Ident
@@ -332,23 +335,6 @@ data Info =
| AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical | AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical
deriving Show deriving Show
data Location
= NoLoc
| Local Int Int
| External FilePath Location
deriving (Show,Eq,Ord)
data L a = L Location a -- location information
deriving Show
instance Functor L where
fmap f (L loc x) = L loc (f x)
unLoc :: L a -> a
unLoc (L _ x) = x
noLoc = L NoLoc
type Type = Term type Type = Term
type Cat = QIdent type Cat = QIdent
type Fun = QIdent type Fun = QIdent

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

@@ -42,7 +42,7 @@ import GF.Grammar.Lockfield
import Data.List (sortBy) import Data.List (sortBy)
--import Data.Maybe (maybe) --import Data.Maybe (maybe)
--import Control.Monad --import Control.Monad
import Text.PrettyPrint import GF.Text.Pretty
import qualified Data.Map as Map import qualified Data.Map as Map
-- whether lock fields are added in reuse -- whether lock fields are added in reuse
@@ -83,7 +83,7 @@ lookupResDefLoc gr (m,c)
AnyInd _ n -> look n c AnyInd _ n -> look n c
ResParam _ _ -> return (noLoc (QC (m,c))) ResParam _ _ -> return (noLoc (QC (m,c)))
ResValue _ -> return (noLoc (QC (m,c))) ResValue _ -> return (noLoc (QC (m,c)))
_ -> raise $ render (ppIdent c <+> text "is not defined in resource" <+> ppIdent m) _ -> raise $ render (c <+> "is not defined in resource" <+> m)
lookupResType :: ErrorMonad m => SourceGrammar -> QIdent -> m Type lookupResType :: ErrorMonad m => SourceGrammar -> QIdent -> m Type
lookupResType gr (m,c) = do lookupResType gr (m,c) = do
@@ -99,7 +99,7 @@ lookupResType gr (m,c) = do
AnyInd _ n -> lookupResType gr (n,c) AnyInd _ n -> lookupResType gr (n,c)
ResParam _ _ -> return typePType ResParam _ _ -> return typePType
ResValue (L _ t) -> return t ResValue (L _ t) -> return t
_ -> raise $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m) _ -> raise $ render (c <+> "has no type defined in resource" <+> m)
lookupOverload :: ErrorMonad m => SourceGrammar -> QIdent -> m [([Type],(Type,Term))] lookupOverload :: ErrorMonad m => SourceGrammar -> QIdent -> m [([Type],(Type,Term))]
lookupOverload gr (m,c) = do lookupOverload gr (m,c) = do
@@ -112,7 +112,7 @@ lookupOverload gr (m,c) = do
concat tss concat tss
AnyInd _ n -> lookupOverload gr (n,c) AnyInd _ n -> lookupOverload gr (n,c)
_ -> raise $ render (ppIdent c <+> text "is not an overloaded operation") _ -> raise $ render (c <+> "is not an overloaded operation")
-- | returns the original 'Info' and the module where it was found -- | returns the original 'Info' and the module where it was found
lookupOrigInfo :: ErrorMonad m => SourceGrammar -> QIdent -> m (Ident,Info) lookupOrigInfo :: ErrorMonad m => SourceGrammar -> QIdent -> m (Ident,Info)
@@ -132,7 +132,7 @@ lookupParamValues gr c = do
(_,info) <- lookupOrigInfo gr c (_,info) <- lookupOrigInfo gr c
case info of case info of
ResParam _ (Just pvs) -> return pvs ResParam _ (Just pvs) -> return pvs
_ -> raise $ render (ppQIdent Qualified c <+> text "has no parameter values defined") _ -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined")
allParamValues :: ErrorMonad m => SourceGrammar -> Type -> m [Term] allParamValues :: ErrorMonad m => SourceGrammar -> Type -> m [Term]
allParamValues cnc ptyp = allParamValues cnc ptyp =
@@ -148,13 +148,13 @@ allParamValues cnc ptyp =
pvs <- allParamValues cnc pt pvs <- allParamValues cnc pt
vvs <- allParamValues cnc vt vvs <- allParamValues cnc vt
return [V pt ts | ts <- combinations (replicate (length pvs) vvs)] return [V pt ts | ts <- combinations (replicate (length pvs) vvs)]
_ -> raise (render (text "cannot find parameter values for" <+> ppTerm Unqualified 0 ptyp)) _ -> raise (render ("cannot find parameter values for" <+> ptyp))
where where
-- to normalize records and record types -- to normalize records and record types
sortByFst = sortBy (\ x y -> compare (fst x) (fst y)) sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
lookupAbsDef :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m (Maybe Int,Maybe [Equation]) lookupAbsDef :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m (Maybe Int,Maybe [Equation])
lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c)) $ do lookupAbsDef gr m c = errIn (render ("looking up absdef of" <+> c)) $ do
info <- lookupQIdentInfo gr (m,c) info <- lookupQIdentInfo gr (m,c)
case info of case info of
AbsFun _ a d _ -> return (a,fmap (map unLoc) d) AbsFun _ a d _ -> return (a,fmap (map unLoc) d)
@@ -168,7 +168,7 @@ lookupLincat gr m c = do
case info of case info of
CncCat (Just (L _ t)) _ _ _ _ -> return t CncCat (Just (L _ t)) _ _ _ _ -> return t
AnyInd _ n -> lookupLincat gr n c AnyInd _ n -> lookupLincat gr n c
_ -> raise (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m)) _ -> raise (render (c <+> "has no linearization type in" <+> m))
-- | this is needed at compile time -- | this is needed at compile time
lookupFunType :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Type lookupFunType :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Type
@@ -177,7 +177,7 @@ lookupFunType gr m c = do
case info of case info of
AbsFun (Just (L _ t)) _ _ _ -> return t AbsFun (Just (L _ t)) _ _ _ -> return t
AnyInd _ n -> lookupFunType gr n c AnyInd _ n -> lookupFunType gr n c
_ -> raise (render (text "cannot find type of" <+> ppIdent c)) _ -> raise (render ("cannot find type of" <+> c))
-- | this is needed at compile time -- | this is needed at compile time
lookupCatContext :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Context lookupCatContext :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Context
@@ -186,7 +186,7 @@ lookupCatContext gr m c = do
case info of case info of
AbsCat (Just (L _ co)) -> return co AbsCat (Just (L _ co)) -> return co
AnyInd _ n -> lookupCatContext gr n c AnyInd _ n -> lookupCatContext gr n c
_ -> raise (render (text "unknown category" <+> ppIdent c)) _ -> raise (render ("unknown category" <+> c))
-- this gives all opers and param constructors, also overloaded opers and funs, and the types, and locations -- this gives all opers and param constructors, also overloaded opers and funs, and the types, and locations

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

@@ -31,7 +31,7 @@ import qualified Data.Traversable as T(mapM)
import Control.Monad (liftM, liftM2, liftM3) import Control.Monad (liftM, liftM2, liftM3)
--import Data.Char (isDigit) --import Data.Char (isDigit)
import Data.List (sortBy,nub) import Data.List (sortBy,nub)
import Text.PrettyPrint import GF.Text.Pretty
typeForm :: Type -> (Context, Cat, [Term]) typeForm :: Type -> (Context, Cat, [Term])
typeForm t = typeForm t =
@@ -45,7 +45,7 @@ typeForm t =
Q c -> ([],c,[]) Q c -> ([],c,[])
QC c -> ([],c,[]) QC c -> ([],c,[])
Sort c -> ([],(identW, c),[]) Sort c -> ([],(identW, c),[])
_ -> error (render (text "no normal form of type" <+> ppTerm Unqualified 0 t)) _ -> error (render ("no normal form of type" <+> ppTerm Unqualified 0 t))
typeFormCnc :: Type -> (Context, Type) typeFormCnc :: Type -> (Context, Type)
typeFormCnc t = typeFormCnc t =
@@ -170,7 +170,7 @@ projectRec :: Label -> [Assign] -> Term
projectRec l rs = projectRec l rs =
case lookup l rs of case lookup l rs of
Just (_,t) -> t Just (_,t) -> t
Nothing -> error (render (text "no value for label" <+> ppLabel l)) Nothing -> error (render ("no value for label" <+> l))
zipAssign :: [Label] -> [Term] -> [Assign] zipAssign :: [Label] -> [Term] -> [Assign]
zipAssign ls ts = [assign l t | (l,t) <- zip ls ts] zipAssign ls ts = [assign l t | (l,t) <- zip ls ts]
@@ -194,7 +194,7 @@ mkRecType = mkRecTypeN 0
record2subst :: Term -> Err Substitution record2subst :: Term -> Err Substitution
record2subst t = case t of record2subst t = case t of
R fs -> return [(identC x, t) | (LIdent x,(_,t)) <- fs] R fs -> return [(identC x, t) | (LIdent x,(_,t)) <- fs]
_ -> Bad (render (text "record expected, found" <+> ppTerm Unqualified 0 t)) _ -> Bad (render ("record expected, found" <+> ppTerm Unqualified 0 t))
typeType, typePType, typeStr, typeTok, typeStrs :: Term typeType, typePType, typeStr, typeTok, typeStrs :: Term
@@ -273,8 +273,8 @@ plusRecType t1 t2 = case (t1, t2) of
(RecType r1, RecType r2) -> case (RecType r1, RecType r2) -> case
filter (`elem` (map fst r1)) (map fst r2) of filter (`elem` (map fst r1)) (map fst r2) of
[] -> return (RecType (r1 ++ r2)) [] -> return (RecType (r1 ++ r2))
ls -> raise $ render (text "clashing labels" <+> hsep (map ppLabel ls)) ls -> raise $ render ("clashing labels" <+> hsep ls)
_ -> raise $ render (text "cannot add record types" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2) _ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)
--plusRecord :: Term -> Term -> Err Term --plusRecord :: Term -> Term -> Err Term
plusRecord t1 t2 = plusRecord t1 t2 =
@@ -283,7 +283,7 @@ plusRecord t1 t2 =
(l,v) <- r1, not (elem l (map fst r2)) ] ++ r2)) (l,v) <- r1, not (elem l (map fst r2)) ] ++ r2))
(_, FV rs) -> mapM (plusRecord t1) rs >>= return . FV (_, FV rs) -> mapM (plusRecord t1) rs >>= return . FV
(FV rs,_ ) -> mapM (`plusRecord` t2) rs >>= return . FV (FV rs,_ ) -> mapM (`plusRecord` t2) rs >>= return . FV
_ -> raise $ render (text "cannot add records" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2) _ -> raise $ render ("cannot add records" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)
-- | default linearization type -- | default linearization type
defLinType :: Type defLinType :: Type
@@ -386,7 +386,7 @@ term2patt trm = case termForm trm of
Ok ([], Cn c, []) -> do Ok ([], Cn c, []) -> do
return (PMacro c) return (PMacro c)
_ -> Bad $ render (text "no pattern corresponds to term" <+> ppTerm Unqualified 0 trm) _ -> Bad $ render ("no pattern corresponds to term" <+> ppTerm Unqualified 0 trm)
patt2term :: Patt -> Term patt2term :: Patt -> Term
patt2term pt = case pt of patt2term pt = case pt of
@@ -450,7 +450,7 @@ strsFromTerm t = case t of
] ]
FV ts -> mapM strsFromTerm ts >>= return . concat FV ts -> mapM strsFromTerm ts >>= return . concat
Strs ts -> mapM strsFromTerm ts >>= return . concat Strs ts -> mapM strsFromTerm ts >>= return . concat
_ -> raise (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t)) _ -> raise (render ("cannot get Str from term" <+> ppTerm Unqualified 0 t))
-- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg -- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg
stringFromTerm :: Term -> String stringFromTerm :: Term -> String
@@ -609,7 +609,7 @@ topoSortJments :: ErrorMonad m => SourceModule -> m [(Ident,Info)]
topoSortJments (m,mi) = do topoSortJments (m,mi) = do
is <- either is <- either
return return
(\cyc -> raise (render (text "circular definitions:" <+> fsep (map ppIdent (head cyc))))) (\cyc -> raise (render ("circular definitions:" <+> fsep (head cyc))))
(topoTest (allDependencies (==m) (jments mi))) (topoTest (allDependencies (==m) (jments mi)))
return (reverse [(i,info) | i <- is, Ok info <- [lookupTree showIdent i (jments mi)]]) return (reverse [(i,info) | i <- is, Ok info <- [lookupTree showIdent i (jments mi)]])
@@ -617,8 +617,8 @@ topoSortJments2 :: ErrorMonad m => SourceModule -> m [[(Ident,Info)]]
topoSortJments2 (m,mi) = do topoSortJments2 (m,mi) = do
iss <- either iss <- either
return return
(\cyc -> raise (render (text "circular definitions:" (\cyc -> raise (render ("circular definitions:"
<+> fsep (map ppIdent (head cyc))))) <+> fsep (head cyc))))
(topoTest2 (allDependencies (==m) (jments mi))) (topoTest2 (allDependencies (==m) (jments mi)))
return return
[[(i,info) | i<-is,Ok info<-[lookupTree showIdent i (jments mi)]] | is<-iss] [[(i,info) | i<-is,Ok info<-[lookupTree showIdent i (jments mi)]] | is<-iss]

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

@@ -22,20 +22,20 @@ import GF.Data.Operations
import GF.Grammar.Grammar import GF.Grammar.Grammar
import GF.Infra.Ident import GF.Infra.Ident
import GF.Grammar.Macros import GF.Grammar.Macros
import GF.Grammar.Printer --import GF.Grammar.Printer
--import Data.List --import Data.List
import Control.Monad import Control.Monad
import Text.PrettyPrint import GF.Text.Pretty
--import Debug.Trace --import Debug.Trace
matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution) matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution)
matchPattern pts term = matchPattern pts term =
if not (isInConstantForm term) if not (isInConstantForm term)
then raise (render (text "variables occur in" <+> ppTerm Unqualified 0 term)) then raise (render ("variables occur in" <+> pp term))
else do else do
term' <- mkK term term' <- mkK term
errIn (render (text "trying patterns" <+> hsep (punctuate comma (map (ppPatt Unqualified 0 . fst) pts)))) $ errIn (render ("trying patterns" <+> hsep (punctuate ',' (map fst pts)))) $
findMatch [([p],t) | (p,t) <- pts] [term'] findMatch [([p],t) | (p,t) <- pts] [term']
where where
-- to capture all Str with string pattern matching -- to capture all Str with string pattern matching
@@ -49,7 +49,7 @@ matchPattern pts term =
K w -> return [w] K w -> return [w]
C v w -> liftM2 (++) (getS v) (getS w) C v w -> liftM2 (++) (getS v) (getS w)
Empty -> return [] Empty -> return []
_ -> raise (render (text "cannot get string from" <+> ppTerm Unqualified 0 s)) _ -> raise (render ("cannot get string from" <+> s))
testOvershadow :: ErrorMonad m => [Patt] -> [Term] -> m [Patt] testOvershadow :: ErrorMonad m => [Patt] -> [Term] -> m [Patt]
testOvershadow pts vs = do testOvershadow pts vs = do
@@ -60,10 +60,10 @@ testOvershadow pts vs = do
findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution) findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution)
findMatch cases terms = case cases of findMatch cases terms = case cases of
[] -> raise (render (text "no applicable case for" <+> hsep (punctuate comma (map (ppTerm Unqualified 0) terms)))) [] -> raise (render ("no applicable case for" <+> hsep (punctuate ',' terms)))
(patts,_):_ | length patts /= length terms -> (patts,_):_ | length patts /= length terms ->
raise (render (text "wrong number of args for patterns :" <+> hsep (map (ppPatt Unqualified 0) patts) <+> raise (render ("wrong number of args for patterns :" <+> hsep patts <+>
text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms))) "cannot take" <+> hsep terms))
(patts,val):cc -> case mapM tryMatch (zip patts terms) of (patts,val):cc -> case mapM tryMatch (zip patts terms) of
Ok substs -> return (val, concat substs) Ok substs -> return (val, concat substs)
_ -> findMatch cc terms _ -> findMatch cc terms
@@ -116,7 +116,7 @@ tryMatch (p,t) = do
(PNeg p',_) -> case tryMatch (p',t) of (PNeg p',_) -> case tryMatch (p',t) of
Bad _ -> return [] Bad _ -> return []
_ -> raise (render (text "no match with negative pattern" <+> ppPatt Unqualified 0 p)) _ -> raise (render ("no match with negative pattern" <+> p))
(PSeq p1 p2, ([],K s, [])) -> matchPSeq p1 p2 s (PSeq p1 p2, ([],K s, [])) -> matchPSeq p1 p2 s
(PMSeq mp1 mp2, ([],K s, [])) -> matchPMSeq mp1 mp2 s (PMSeq mp1 mp2, ([],K s, [])) -> matchPMSeq mp1 mp2 s
@@ -130,7 +130,7 @@ tryMatch (p,t) = do
(PChar, ([],K [_], [])) -> return [] (PChar, ([],K [_], [])) -> return []
(PChars cs, ([],K [c], [])) | elem c cs -> return [] (PChars cs, ([],K [c], [])) | elem c cs -> return []
_ -> raise (render (text "no match in case expr for" <+> ppTerm Unqualified 0 t)) _ -> raise (render ("no match in case expr for" <+> t))
matchPMSeq (m1,p1) (m2,p2) s = matchPSeq' m1 p1 m2 p2 s matchPMSeq (m1,p1) (m2,p2) s = matchPSeq' m1 p1 m2 p2 s
--matchPSeq p1 p2 s = matchPSeq' (0,maxBound::Int) p1 (0,maxBound::Int) p2 s --matchPSeq p1 p2 s = matchPSeq' (0,maxBound::Int) p1 (0,maxBound::Int) p2 s

313
src/compiler/GF/Grammar/Printer.hs
View File

@@ -9,8 +9,6 @@
module GF.Grammar.Printer module GF.Grammar.Printer
( TermPrintQual(..) ( TermPrintQual(..)
, ppLabel
, ppGrammar
, ppModule , ppModule
, ppJudgement , ppJudgement
, ppParams , ppParams
@@ -18,7 +16,6 @@ module GF.Grammar.Printer
, ppPatt , ppPatt
, ppValue , ppValue
, ppConstrs , ppConstrs
, ppLocation
, ppQIdent , ppQIdent
, ppMeta , ppMeta
, getAbs , getAbs
@@ -31,7 +28,7 @@ import GF.Grammar.Grammar
import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq) import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq)
import Text.PrettyPrint import GF.Text.Pretty
import Data.Maybe (isNothing) import Data.Maybe (isNothing)
import Data.List (intersperse) import Data.List (intersperse)
import qualified Data.Map as Map import qualified Data.Map as Map
@@ -43,8 +40,8 @@ data TermPrintQual
= Unqualified | Qualified | Internal = Unqualified | Qualified | Internal
deriving Eq deriving Eq
ppGrammar :: SourceGrammar -> Doc instance Pretty SourceGrammar where
ppGrammar sgr = vcat $ map (ppModule Qualified) $ modules sgr pp = vcat . map (ppModule Qualified) . modules
ppModule :: TermPrintQual -> SourceModule -> Doc ppModule :: TermPrintQual -> SourceModule -> Doc
ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) = ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
@@ -54,288 +51,286 @@ ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
maybe empty (ppSequences q) mseqs) $$ maybe empty (ppSequences q) mseqs) $$
ftr ftr
where where
hdr = complModDoc <+> modTypeDoc <+> equals <+> hdr = complModDoc <+> modTypeDoc <+> '=' <+>
hsep (intersperse (text "**") $ hsep (intersperse (pp "**") $
filter (not . isEmpty) $ [ commaPunct ppExtends exts filter (not . isEmpty) $ [ commaPunct ppExtends exts
, maybe empty ppWith with , maybe empty ppWith with
, if null opens , if null opens
then lbrace then pp '{'
else text "open" <+> commaPunct ppOpenSpec opens <+> text "in" <+> lbrace else "open" <+> commaPunct ppOpenSpec opens <+> "in" <+> '{'
]) ])
ftr = rbrace ftr = '}'
complModDoc = complModDoc =
case mstat of case mstat of
MSComplete -> empty MSComplete -> empty
MSIncomplete -> text "incomplete" MSIncomplete -> pp "incomplete"
modTypeDoc = modTypeDoc =
case mtype of case mtype of
MTAbstract -> text "abstract" <+> ppIdent mn MTAbstract -> "abstract" <+> mn
MTResource -> text "resource" <+> ppIdent mn MTResource -> "resource" <+> mn
MTConcrete abs -> text "concrete" <+> ppIdent mn <+> text "of" <+> ppIdent abs MTConcrete abs -> "concrete" <+> mn <+> "of" <+> abs
MTInterface -> text "interface" <+> ppIdent mn MTInterface -> "interface" <+> mn
MTInstance ie -> text "instance" <+> ppIdent mn <+> text "of" <+> ppExtends ie MTInstance ie -> "instance" <+> mn <+> "of" <+> ppExtends ie
ppExtends (id,MIAll ) = ppIdent id ppExtends (id,MIAll ) = pp id
ppExtends (id,MIOnly incs) = ppIdent id <+> brackets (commaPunct ppIdent incs) ppExtends (id,MIOnly incs) = id <+> brackets (commaPunct pp incs)
ppExtends (id,MIExcept incs) = ppIdent id <+> char '-' <+> brackets (commaPunct ppIdent incs) ppExtends (id,MIExcept incs) = id <+> '-' <+> brackets (commaPunct pp incs)
ppWith (id,ext,opens) = ppExtends (id,ext) <+> text "with" <+> commaPunct ppInstSpec opens ppWith (id,ext,opens) = ppExtends (id,ext) <+> "with" <+> commaPunct ppInstSpec opens
ppOptions opts = ppOptions opts =
text "flags" $$ "flags" $$
nest 2 (vcat [text option <+> equals <+> ppLit value <+> semi | (option,value) <- optionsGFO opts]) nest 2 (vcat [option <+> '=' <+> ppLit value <+> ';' | (option,value) <- optionsGFO opts])
ppJudgement q (id, AbsCat pcont ) = ppJudgement q (id, AbsCat pcont ) =
text "cat" <+> ppIdent id <+> "cat" <+> id <+>
(case pcont of (case pcont of
Just (L _ cont) -> hsep (map (ppDecl q) cont) Just (L _ cont) -> hsep (map (ppDecl q) cont)
Nothing -> empty) <+> semi Nothing -> empty) <+> ';'
ppJudgement q (id, AbsFun ptype _ pexp poper) = ppJudgement q (id, AbsFun ptype _ pexp poper) =
let kind | isNothing pexp = "data" let kind | isNothing pexp = "data"
| poper == Just False = "oper" | poper == Just False = "oper"
| otherwise = "fun" | otherwise = "fun"
in in
(case ptype of (case ptype of
Just (L _ typ) -> text kind <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi Just (L _ typ) -> kind <+> id <+> ':' <+> ppTerm q 0 typ <+> ';'
Nothing -> empty) $$ Nothing -> empty) $$
(case pexp of (case pexp of
Just [] -> empty Just [] -> empty
Just eqs -> text "def" <+> vcat [ppIdent id <+> hsep (map (ppPatt q 2) ps) <+> equals <+> ppTerm q 0 e <+> semi | L _ (ps,e) <- eqs] Just eqs -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs]
Nothing -> empty) Nothing -> empty)
ppJudgement q (id, ResParam pparams _) = ppJudgement q (id, ResParam pparams _) =
text "param" <+> ppIdent id <+> "param" <+> id <+>
(case pparams of (case pparams of
Just (L _ ps) -> equals <+> ppParams q ps Just (L _ ps) -> '=' <+> ppParams q ps
_ -> empty) <+> semi _ -> empty) <+> ';'
ppJudgement q (id, ResValue pvalue) = ppJudgement q (id, ResValue pvalue) =
text "-- param constructor" <+> ppIdent id <+> colon <+> "-- param constructor" <+> id <+> ':' <+>
(case pvalue of (case pvalue of
(L _ ty) -> ppTerm q 0 ty) <+> semi (L _ ty) -> ppTerm q 0 ty) <+> ';'
ppJudgement q (id, ResOper ptype pexp) = ppJudgement q (id, ResOper ptype pexp) =
text "oper" <+> ppIdent id <+> "oper" <+> id <+>
(case ptype of {Just (L _ t) -> colon <+> ppTerm q 0 t; Nothing -> empty} $$ (case ptype of {Just (L _ t) -> ':' <+> ppTerm q 0 t; Nothing -> empty} $$
case pexp of {Just (L _ e) -> equals <+> ppTerm q 0 e; Nothing -> empty}) <+> semi case pexp of {Just (L _ e) -> '=' <+> ppTerm q 0 e; Nothing -> empty}) <+> ';'
ppJudgement q (id, ResOverload ids defs) = ppJudgement q (id, ResOverload ids defs) =
text "oper" <+> ppIdent id <+> equals <+> "oper" <+> id <+> '=' <+>
(text "overload" <+> lbrace $$ ("overload" <+> '{' $$
nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e <+> semi) | (L _ ty,L _ e) <- defs]) $$ nest 2 (vcat [id <+> (':' <+> ppTerm q 0 ty $$ '=' <+> ppTerm q 0 e <+> ';') | (L _ ty,L _ e) <- defs]) $$
rbrace) <+> semi '}') <+> ';'
ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) = ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) =
(case pcat of (case pcat of
Just (L _ typ) -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi Just (L _ typ) -> "lincat" <+> id <+> '=' <+> ppTerm q 0 typ <+> ';'
Nothing -> empty) $$ Nothing -> empty) $$
(case pdef of (case pdef of
Just (L _ exp) -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi Just (L _ exp) -> "lindef" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
Nothing -> empty) $$ Nothing -> empty) $$
(case pref of (case pref of
Just (L _ exp) -> text "linref" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi Just (L _ exp) -> "linref" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
Nothing -> empty) $$ Nothing -> empty) $$
(case pprn of (case pprn of
Just (L _ prn) -> text "printname" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
Nothing -> empty) $$ Nothing -> empty) $$
(case (mpmcfg,q) of (case (mpmcfg,q) of
(Just (PMCFG prods funs),Internal) (Just (PMCFG prods funs),Internal)
-> text "pmcfg" <+> ppIdent id <+> equals <+> char '{' $$ -> "pmcfg" <+> id <+> '=' <+> '{' $$
nest 2 (vcat (map ppProduction prods) $$ nest 2 (vcat (map ppProduction prods) $$
space $$ ' ' $$
vcat (map (\(funid,arr) -> ppFunId funid <+> text ":=" <+> vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
parens (hcat (punctuate comma (map ppSeqId (Array.elems arr))))) parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
(Array.assocs funs))) $$ (Array.assocs funs))) $$
char '}' '}'
_ -> empty) _ -> empty)
ppJudgement q (id, CncFun ptype pdef pprn mpmcfg) = ppJudgement q (id, CncFun ptype pdef pprn mpmcfg) =
(case pdef of (case pdef of
Just (L _ e) -> let (xs,e') = getAbs e Just (L _ e) -> let (xs,e') = getAbs e
in text "lin" <+> ppIdent id <+> hsep (map ppBind xs) <+> equals <+> ppTerm q 0 e' <+> semi in "lin" <+> id <+> hsep (map ppBind xs) <+> '=' <+> ppTerm q 0 e' <+> ';'
Nothing -> empty) $$ Nothing -> empty) $$
(case pprn of (case pprn of
Just (L _ prn) -> text "printname" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
Nothing -> empty) $$ Nothing -> empty) $$
(case (mpmcfg,q) of (case (mpmcfg,q) of
(Just (PMCFG prods funs),Internal) (Just (PMCFG prods funs),Internal)
-> text "pmcfg" <+> ppIdent id <+> equals <+> char '{' $$ -> "pmcfg" <+> id <+> '=' <+> '{' $$
nest 2 (vcat (map ppProduction prods) $$ nest 2 (vcat (map ppProduction prods) $$
space $$ ' ' $$
vcat (map (\(funid,arr) -> ppFunId funid <+> text ":=" <+> vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
parens (hcat (punctuate comma (map ppSeqId (Array.elems arr))))) parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
(Array.assocs funs))) $$ (Array.assocs funs))) $$
char '}' '}'
_ -> empty) _ -> empty)
ppJudgement q (id, AnyInd cann mid) = ppJudgement q (id, AnyInd cann mid) =
case q of case q of
Internal -> text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
_ -> empty _ -> empty
instance Pretty Term where pp = ppTerm Unqualified 0
ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e) ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e)
in prec d 0 (char '\\' <> commaPunct ppBind xs <+> text "->" <+> ppTerm q 0 e') in prec d 0 ('\\' <> commaPunct ppBind xs <+> "->" <+> ppTerm q 0 e')
ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of
([],_) -> text "table" <+> lbrace $$ ([],_) -> "table" <+> '{' $$
nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$ nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
rbrace '}'
(vs,e) -> prec d 0 (text "\\\\" <> commaPunct ppIdent vs <+> text "=>" <+> ppTerm q 0 e) (vs,e) -> prec d 0 ("\\\\" <> commaPunct pp vs <+> "=>" <+> ppTerm q 0 e)
ppTerm q d (T (TTyped t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$ ppTerm q d (T (TTyped t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$ nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
rbrace '}'
ppTerm q d (T (TComp t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$ ppTerm q d (T (TComp t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$ nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
rbrace '}'
ppTerm q d (T (TWild t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$ ppTerm q d (T (TWild t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$ nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
rbrace '}'
ppTerm q d (Prod bt x a b)= if x == identW && bt == Explicit ppTerm q d (Prod bt x a b)= if x == identW && bt == Explicit
then prec d 0 (ppTerm q 4 a <+> text "->" <+> ppTerm q 0 b) then prec d 0 (ppTerm q 4 a <+> "->" <+> ppTerm q 0 b)
else prec d 0 (parens (ppBind (bt,x) <+> colon <+> ppTerm q 0 a) <+> text "->" <+> ppTerm q 0 b) else prec d 0 (parens (ppBind (bt,x) <+> ':' <+> ppTerm q 0 a) <+> "->" <+> ppTerm q 0 b)
ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> text "=>" <+> ppTerm q 0 vt) ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> "=>" <+> ppTerm q 0 vt)
ppTerm q d (Let l e) = let (ls,e') = getLet e ppTerm q d (Let l e) = let (ls,e') = getLet e
in prec d 0 (text "let" <+> vcat (map (ppLocDef q) (l:ls)) $$ text "in" <+> ppTerm q 0 e') in prec d 0 ("let" <+> vcat (map (ppLocDef q) (l:ls)) $$ "in" <+> ppTerm q 0 e')
ppTerm q d (Example e s)=prec d 0 (text "in" <+> ppTerm q 5 e <+> str s) ppTerm q d (Example e s)=prec d 0 ("in" <+> ppTerm q 5 e <+> str s)
ppTerm q d (C e1 e2) =prec d 1 (hang (ppTerm q 2 e1) 2 (text "++" <+> ppTerm q 1 e2)) ppTerm q d (C e1 e2) =prec d 1 (hang (ppTerm q 2 e1) 2 ("++" <+> ppTerm q 1 e2))
ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> char '+' <+> ppTerm q 2 e2) ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> '+' <+> ppTerm q 2 e2)
ppTerm q d (S x y) = case x of ppTerm q d (S x y) = case x of
T annot xs -> let e = case annot of T annot xs -> let e = case annot of
TRaw -> y TRaw -> y
TTyped t -> Typed y t TTyped t -> Typed y t
TComp t -> Typed y t TComp t -> Typed y t
TWild t -> Typed y t TWild t -> Typed y t
in text "case" <+> ppTerm q 0 e <+> text "of" <+> lbrace $$ in "case" <+> ppTerm q 0 e <+>"of" <+> '{' $$
nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$ nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
rbrace '}'
_ -> prec d 3 (hang (ppTerm q 3 x) 2 (text "!" <+> ppTerm q 4 y)) _ -> prec d 3 (hang (ppTerm q 3 x) 2 ("!" <+> ppTerm q 4 y))
ppTerm q d (ExtR x y) = prec d 3 (ppTerm q 3 x <+> text "**" <+> ppTerm q 4 y) ppTerm q d (ExtR x y) = prec d 3 (ppTerm q 3 x <+> "**" <+> ppTerm q 4 y)
ppTerm q d (App x y) = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y) ppTerm q d (App x y) = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y)
ppTerm q d (V e es) = hang (text "table") 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate semi (map (ppTerm q 0) es)))]) ppTerm q d (V e es) = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))])
ppTerm q d (FV es) = text "variants" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es))) ppTerm q d (FV es) = "variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
ppTerm q d (AdHocOverload es) = text "overload" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es))) ppTerm q d (AdHocOverload es) = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
ppTerm q d (Alts e xs) = prec d 4 (text "pre" <+> braces (ppTerm q 0 e <> semi <+> fsep (punctuate semi (map (ppAltern q) xs)))) ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
ppTerm q d (Strs es) = text "strs" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es))) ppTerm q d (Strs es) = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
ppTerm q d (EPatt p) = prec d 4 (char '#' <+> ppPatt q 2 p) ppTerm q d (EPatt p) = prec d 4 ('#' <+> ppPatt q 2 p)
ppTerm q d (EPattType t)=prec d 4 (text "pattern" <+> ppTerm q 0 t) ppTerm q d (EPattType t)=prec d 4 ("pattern" <+> ppTerm q 0 t)
ppTerm q d (P t l) = prec d 5 (ppTerm q 5 t <> char '.' <> ppLabel l) ppTerm q d (P t l) = prec d 5 (ppTerm q 5 t <> '.' <> l)
ppTerm q d (Cn id) = ppIdent id ppTerm q d (Cn id) = pp id
ppTerm q d (Vr id) = ppIdent id ppTerm q d (Vr id) = pp id
ppTerm q d (Q id) = ppQIdent q id ppTerm q d (Q id) = ppQIdent q id
ppTerm q d (QC id) = ppQIdent q id ppTerm q d (QC id) = ppQIdent q id
ppTerm q d (Sort id) = ppIdent id ppTerm q d (Sort id) = pp id
ppTerm q d (K s) = str s ppTerm q d (K s) = str s
ppTerm q d (EInt n) = int n ppTerm q d (EInt n) = pp n
ppTerm q d (EFloat f) = double f ppTerm q d (EFloat f) = pp f
ppTerm q d (Meta i) = ppMeta i ppTerm q d (Meta i) = ppMeta i
ppTerm q d (Empty) = text "[]" ppTerm q d (Empty) = pp "[]"
ppTerm q d (R []) = text "<>" -- to distinguish from {} empty RecType ppTerm q d (R []) = pp "<>" -- to distinguish from {} empty RecType
ppTerm q d (R xs) = braces (fsep (punctuate semi [ppLabel l <+> ppTerm q d (R xs) = braces (fsep (punctuate ';' [l <+>
fsep [case mb_t of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty}, fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty},
equals <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs])) '=' <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))
ppTerm q d (RecType xs)= braces (fsep (punctuate semi [ppLabel l <+> colon <+> ppTerm q 0 t | (l,t) <- xs])) ppTerm q d (RecType xs)= braces (fsep (punctuate ';' [l <+> ':' <+> ppTerm q 0 t | (l,t) <- xs]))
ppTerm q d (Typed e t) = char '<' <> ppTerm q 0 e <+> colon <+> ppTerm q 0 t <> char '>' ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>'
ppTerm q d (ImplArg e) = braces (ppTerm q 0 e) ppTerm q d (ImplArg e) = braces (ppTerm q 0 e)
ppTerm q d (ELincat cat t) = prec d 4 (text "lincat" <+> ppIdent cat <+> ppTerm q 5 t) ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t)
ppTerm q d (ELin cat t) = prec d 4 (text "lin" <+> ppIdent cat <+> ppTerm q 5 t) ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t)
ppTerm q d (Error s) = prec d 4 (text "Predef.error" <+> str s) ppTerm q d (Error s) = prec d 4 ("Predef.error" <+> str s)
ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> text "->" <+> ppTerm q 0 e ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e
ppCase q (p,e) = ppPatt q 0 p <+> text "=>" <+> ppTerm q 0 e ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e
ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> char '|' <+> ppPatt q 1 p2) instance Pretty Patt where pp = ppPatt Unqualified 0
ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> char '+' <+> ppPatt q 1 p2)
ppPatt q d (PMSeq (_,p1) (_,p2)) = prec d 0 (ppPatt q 0 p1 <+> char '+' <+> ppPatt q 1 p2) ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '|' <+> ppPatt q 1 p2)
ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
ppPatt q d (PMSeq (_,p1) (_,p2)) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
ppPatt q d (PC f ps) = if null ps ppPatt q d (PC f ps) = if null ps
then ppIdent f then pp f
else prec d 1 (ppIdent f <+> hsep (map (ppPatt q 3) ps)) else prec d 1 (f <+> hsep (map (ppPatt q 3) ps))
ppPatt q d (PP f ps) = if null ps ppPatt q d (PP f ps) = if null ps
then ppQIdent q f then ppQIdent q f
else prec d 1 (ppQIdent q f <+> hsep (map (ppPatt q 3) ps)) else prec d 1 (ppQIdent q f <+> hsep (map (ppPatt q 3) ps))
ppPatt q d (PRep p) = prec d 1 (ppPatt q 3 p <> char '*') ppPatt q d (PRep p) = prec d 1 (ppPatt q 3 p <> '*')
ppPatt q d (PAs f p) = prec d 2 (ppIdent f <> char '@' <> ppPatt q 3 p) ppPatt q d (PAs f p) = prec d 2 (f <> '@' <> ppPatt q 3 p)
ppPatt q d (PNeg p) = prec d 2 (char '-' <> ppPatt q 3 p) ppPatt q d (PNeg p) = prec d 2 ('-' <> ppPatt q 3 p)
ppPatt q d (PChar) = char '?' ppPatt q d (PChar) = pp '?'
ppPatt q d (PChars s) = brackets (str s) ppPatt q d (PChars s) = brackets (str s)
ppPatt q d (PMacro id) = char '#' <> ppIdent id ppPatt q d (PMacro id) = '#' <> id
ppPatt q d (PM id) = char '#' <> ppQIdent q id ppPatt q d (PM id) = '#' <> ppQIdent q id
ppPatt q d PW = char '_' ppPatt q d PW = pp '_'
ppPatt q d (PV id) = ppIdent id ppPatt q d (PV id) = pp id
ppPatt q d (PInt n) = int n ppPatt q d (PInt n) = pp n
ppPatt q d (PFloat f) = double f ppPatt q d (PFloat f) = pp f
ppPatt q d (PString s) = str s ppPatt q d (PString s) = str s
ppPatt q d (PR xs) = braces (hsep (punctuate semi [ppLabel l <+> equals <+> ppPatt q 0 e | (l,e) <- xs])) ppPatt q d (PR xs) = braces (hsep (punctuate ';' [l <+> '=' <+> ppPatt q 0 e | (l,e) <- xs]))
ppPatt q d (PImplArg p) = braces (ppPatt q 0 p) ppPatt q d (PImplArg p) = braces (ppPatt q 0 p)
ppPatt q d (PTilde t) = prec d 2 (char '~' <> ppTerm q 6 t) ppPatt q d (PTilde t) = prec d 2 ('~' <> ppTerm q 6 t)
ppValue :: TermPrintQual -> Int -> Val -> Doc ppValue :: TermPrintQual -> Int -> Val -> Doc
ppValue q d (VGen i x) = ppIdent x <> text "{-" <> int i <> text "-}" ---- latter part for debugging ppValue q d (VGen i x) = x <> "{-" <> i <> "-}" ---- latter part for debugging
ppValue q d (VApp u v) = prec d 4 (ppValue q 4 u <+> ppValue q 5 v) ppValue q d (VApp u v) = prec d 4 (ppValue q 4 u <+> ppValue q 5 v)
ppValue q d (VCn (_,c)) = ppIdent c ppValue q d (VCn (_,c)) = pp c
ppValue q d (VClos env e) = case e of ppValue q d (VClos env e) = case e of
Meta _ -> ppTerm q d e <> ppEnv env Meta _ -> ppTerm q d e <> ppEnv env
_ -> ppTerm q d e ---- ++ prEnv env ---- for debugging _ -> ppTerm q d e ---- ++ prEnv env ---- for debugging
ppValue q d (VRecType xs) = braces (hsep (punctuate comma [ppLabel l <> char '=' <> ppValue q 0 v | (l,v) <- xs])) ppValue q d (VRecType xs) = braces (hsep (punctuate ',' [l <> '=' <> ppValue q 0 v | (l,v) <- xs]))
ppValue q d VType = text "Type" ppValue q d VType = pp "Type"
ppConstrs :: Constraints -> [Doc] ppConstrs :: Constraints -> [Doc]
ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> text "<>" <+> ppValue Unqualified 0 w)) ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> "<>" <+> ppValue Unqualified 0 w))
ppEnv :: Env -> Doc ppEnv :: Env -> Doc
ppEnv e = hcat (map (\(x,t) -> braces (ppIdent x <> text ":=" <> ppValue Unqualified 0 t)) e) ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e)
str s = doubleQuotes (text s) str s = doubleQuotes s
ppDecl q (_,id,typ) ppDecl q (_,id,typ)
| id == identW = ppTerm q 3 typ | id == identW = ppTerm q 3 typ
| otherwise = parens (ppIdent id <+> colon <+> ppTerm q 0 typ) | otherwise = parens (id <+> ':' <+> ppTerm q 0 typ)
ppDDecl q (_,id,typ) ppDDecl q (_,id,typ)
| id == identW = ppTerm q 6 typ | id == identW = ppTerm q 6 typ
| otherwise = parens (ppIdent id <+> colon <+> ppTerm q 0 typ) | otherwise = parens (id <+> ':' <+> ppTerm q 0 typ)
ppQIdent :: TermPrintQual -> QIdent -> Doc
ppQIdent q (m,id) = ppQIdent q (m,id) =
case q of case q of
Unqualified -> ppIdent id Unqualified -> pp id
Qualified -> ppIdent m <> char '.' <> ppIdent id Qualified -> m <> '.' <> id
Internal -> ppIdent m <> char '.' <> ppIdent id Internal -> m <> '.' <> id
ppLabel = ppIdent . label2ident instance Pretty Label where pp = pp . label2ident
ppOpenSpec (OSimple id) = ppIdent id ppOpenSpec (OSimple id) = pp id
ppOpenSpec (OQualif id n) = parens (ppIdent id <+> equals <+> ppIdent n) ppOpenSpec (OQualif id n) = parens (id <+> '=' <+> n)
ppInstSpec (id,n) = parens (ppIdent id <+> equals <+> ppIdent n) ppInstSpec (id,n) = parens (id <+> '=' <+> n)
ppLocDef q (id, (mbt, e)) = ppLocDef q (id, (mbt, e)) =
ppIdent id <+> id <+>
(case mbt of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty} <+> equals <+> ppTerm q 0 e) <+> semi (case mbt of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty} <+> '=' <+> ppTerm q 0 e) <+> ';'
ppBind (Explicit,v) = ppIdent v ppBind (Explicit,v) = pp v
ppBind (Implicit,v) = braces (ppIdent v) ppBind (Implicit,v) = braces v
ppAltern q (x,y) = ppTerm q 0 x <+> char '/' <+> ppTerm q 0 y ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
ppParams q ps = fsep (intersperse (char '|') (map (ppParam q) ps)) ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps))
ppParam q (id,cxt) = ppIdent id <+> hsep (map (ppDDecl q) cxt) ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
ppLocation :: FilePath -> Location -> Doc
ppLocation fpath NoLoc = text fpath
ppLocation fpath (External p l) = ppLocation p l
ppLocation fpath (Local b e)
| b == e = text fpath <> colon <> int b
| otherwise = text fpath <> colon <> int b <> text "-" <> int e
ppProduction (Production fid funid args) = ppProduction (Production fid funid args) =
ppFId fid <+> text "->" <+> ppFunId funid <> ppFId fid <+> "->" <+> ppFunId funid <>
brackets (hcat (punctuate comma (map (hsep . intersperse (char '|') . map ppFId) args))) brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args)))
ppSequences q seqsArr ppSequences q seqsArr
| null seqs || q /= Internal = empty | null seqs || q /= Internal = empty
| otherwise = text "sequences" <+> char '{' $$ | otherwise = "sequences" <+> '{' $$
nest 2 (vcat (map ppSeq seqs)) $$ nest 2 (vcat (map ppSeq seqs)) $$
char '}' '}'
where where
seqs = Array.assocs seqsArr seqs = Array.assocs seqsArr
commaPunct f ds = (hcat (punctuate comma (map f ds))) commaPunct f ds = (hcat (punctuate "," (map f ds)))
prec d1 d2 doc prec d1 d2 doc
| d1 > d2 = parens doc | d1 > d2 = parens doc

14
src/compiler/GF/Grammar/ShowTerm.hs
View File

@@ -5,7 +5,7 @@ import GF.Grammar.Printer
import GF.Grammar.Lookup import GF.Grammar.Lookup
import GF.Data.Operations import GF.Data.Operations
import Text.PrettyPrint import GF.Text.Pretty
import Data.List (intersperse) import Data.List (intersperse)
showTerm :: SourceGrammar -> TermPrintStyle -> TermPrintQual -> Term -> String showTerm :: SourceGrammar -> TermPrintStyle -> TermPrintQual -> Term -> String
@@ -13,7 +13,7 @@ showTerm gr sty q t = case sty of
TermPrintTable -> render $ vcat [p <+> s | (p,s) <- ppTermTabular gr q t] TermPrintTable -> render $ vcat [p <+> s | (p,s) <- ppTermTabular gr q t]
TermPrintAll -> render $ vcat [ s | (p,s) <- ppTermTabular gr q t] TermPrintAll -> render $ vcat [ s | (p,s) <- ppTermTabular gr q t]
TermPrintList -> renderStyle (style{mode = OneLineMode}) $ TermPrintList -> renderStyle (style{mode = OneLineMode}) $
vcat (punctuate comma [s | (p,s) <- ppTermTabular gr q t]) vcat (punctuate ',' [s | (p,s) <- ppTermTabular gr q t])
TermPrintOne -> render $ vcat [ s | (p,s) <- take 1 (ppTermTabular gr q t)] TermPrintOne -> render $ vcat [ s | (p,s) <- take 1 (ppTermTabular gr q t)]
TermPrintDefault -> render $ ppTerm q 0 t TermPrintDefault -> render $ ppTerm q 0 t
@@ -21,19 +21,19 @@ ppTermTabular :: SourceGrammar -> TermPrintQual -> Term -> [(Doc,Doc)]
ppTermTabular gr q = pr where ppTermTabular gr q = pr where
pr t = case t of pr t = case t of
R rs -> R rs ->
[(ppLabel lab <+> char '.' <+> path, str) | (lab,(_,val)) <- rs, (path,str) <- pr val] [(lab <+> '.' <+> path, str) | (lab,(_,val)) <- rs, (path,str) <- pr val]
T _ cs -> T _ cs ->
[(ppPatt q 0 patt <+> text "=>" <+> path, str) | (patt, val ) <- cs, (path,str) <- pr val] [(ppPatt q 0 patt <+> "=>" <+> path, str) | (patt, val ) <- cs, (path,str) <- pr val]
V ty cs -> V ty cs ->
let pvals = case allParamValues gr ty of let pvals = case allParamValues gr ty of
Ok pvals -> pvals Ok pvals -> pvals
Bad _ -> map Meta [1..] Bad _ -> map Meta [1..]
in [(ppTerm q 0 pval <+> text "=>" <+> path, str) | (pval, val) <- zip pvals cs, (path,str) <- pr val] in [(ppTerm q 0 pval <+> "=>" <+> path, str) | (pval, val) <- zip pvals cs, (path,str) <- pr val]
_ -> [(empty,ps t)] _ -> [(empty,ps t)]
ps t = case t of ps t = case t of
K s -> text s K s -> pp s
C s u -> ps s <+> ps u C s u -> ps s <+> ps u
FV ts -> hsep (intersperse (char '/') (map ps ts)) FV ts -> hsep (intersperse (pp '/') (map ps ts))
_ -> ppTerm q 0 t _ -> ppTerm q 0 t
data TermPrintStyle data TermPrintStyle

14
src/compiler/GF/Infra/CheckM.hs
View File

@@ -21,11 +21,11 @@ module GF.Infra.CheckM
import GF.Data.Operations import GF.Data.Operations
--import GF.Infra.Ident --import GF.Infra.Ident
import GF.Grammar.Grammar(msrc) -- ,Context --import GF.Grammar.Grammar(msrc) -- ,Context
import GF.Grammar.Printer(ppLocation) import GF.Infra.Location(ppLocation,sourcePath)
import qualified Data.Map as Map import qualified Data.Map as Map
import Text.PrettyPrint import GF.Text.Pretty
import System.FilePath(makeRelative) import System.FilePath(makeRelative)
import Control.Parallel.Strategies(parList,rseq,using) import Control.Parallel.Strategies(parList,rseq,using)
import Control.Monad(liftM) import Control.Monad(liftM)
@@ -51,7 +51,7 @@ instance Monad Check where
(ws,Fail msg) -> (ws,Fail msg) (ws,Fail msg) -> (ws,Fail msg)
instance ErrorMonad Check where instance ErrorMonad Check where
raise s = checkError (text s) raise s = checkError (pp s)
handle f h = handle' f (h . render) handle f h = handle' f (h . render)
handle' f h = Check (\{-ctxt-} msgs -> case unCheck f {-ctxt-} msgs of handle' f h = Check (\{-ctxt-} msgs -> case unCheck f {-ctxt-} msgs of
@@ -67,7 +67,7 @@ checkCond s b = if b then return () else checkError s
-- | warnings should be reversed in the end -- | warnings should be reversed in the end
checkWarn :: Message -> Check () checkWarn :: Message -> Check ()
checkWarn msg = Check $ \{-ctxt-} (es,ws) -> ((es,(text "Warning:" <+> msg) : ws),Success ()) checkWarn msg = Check $ \{-ctxt-} (es,ws) -> ((es,("Warning:" <+> msg) : ws),Success ())
checkWarnings = mapM_ checkWarn checkWarnings = mapM_ checkWarn
@@ -151,6 +151,6 @@ checkIn msg c = Check $ \{-ctxt-} msgs0 ->
-- | Augment error messages with a relative path to the source module and -- | Augment error messages with a relative path to the source module and
-- an contextual hint (which can be left 'empty') -- an contextual hint (which can be left 'empty')
checkInModule cwd mi loc context = checkInModule cwd mi loc context =
checkIn (ppLocation relpath loc <> colon $$ nest 2 context) checkIn (ppLocation relpath loc <> ':' $$ nest 2 context)
where where
relpath = makeRelative cwd (msrc mi) relpath = makeRelative cwd (sourcePath mi)

7
src/compiler/GF/Infra/Ident.hs
View File

@@ -13,7 +13,7 @@
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module GF.Infra.Ident (-- * Identifiers module GF.Infra.Ident (-- * Identifiers
Ident, ident2utf8, showIdent, ppIdent, prefixIdent, Ident, ident2utf8, showIdent, prefixIdent,
identS, identC, identV, identA, identAV, identW, identS, identC, identV, identA, identAV, identW,
argIdent, isArgIdent, getArgIndex, argIdent, isArgIdent, getArgIndex,
varStr, varX, isWildIdent, varIndex, varStr, varX, isWildIdent, varIndex,
@@ -31,7 +31,7 @@ import qualified Data.ByteString.Char8 as BS(append,isPrefixOf)
-- UTF-8-encoded bytestrings! -- UTF-8-encoded bytestrings!
import Data.Char(isDigit) import Data.Char(isDigit)
import PGF.Internal(Binary(..)) import PGF.Internal(Binary(..))
import Text.PrettyPrint(Doc,text) import GF.Text.Pretty
-- | the constructors labelled /INTERNAL/ are -- | the constructors labelled /INTERNAL/ are
@@ -81,8 +81,7 @@ ident2raw = Id . ident2utf8
showIdent :: Ident -> String showIdent :: Ident -> String
showIdent i = unpack $! ident2utf8 i showIdent i = unpack $! ident2utf8 i
ppIdent :: Ident -> Doc instance Pretty Ident where pp = pp . showIdent
ppIdent = text . showIdent
identS :: String -> Ident identS :: String -> Ident
identS = identC . rawIdentS identS = identC . rawIdentS

2
src/compiler/GF/Infra/UseIO.hs
View File

@@ -54,7 +54,7 @@ errOptIO os e m = case m of
return e return e
-} -}
type FileName = String type FileName = String
type InitPath = String type InitPath = String -- ^ the directory portion of a pathname
type FullPath = String type FullPath = String
gfLibraryPath = "GF_LIB_PATH" gfLibraryPath = "GF_LIB_PATH"

4
src/compiler/GFI.hs
View File

@@ -42,7 +42,7 @@ import qualified Text.ParserCombinators.ReadP as RP
import System.Directory({-getCurrentDirectory,-}getAppUserDataDirectory) import System.Directory({-getCurrentDirectory,-}getAppUserDataDirectory)
import Control.Exception(SomeException,fromException,evaluate,try) import Control.Exception(SomeException,fromException,evaluate,try)
import Control.Monad import Control.Monad
import Text.PrettyPrint (render) import GF.Text.Pretty (render)
import qualified GF.System.Signal as IO(runInterruptibly) import qualified GF.System.Signal as IO(runInterruptibly)
#ifdef SERVER_MODE #ifdef SERVER_MODE
import GFServer(server) import GFServer(server)
@@ -247,7 +247,7 @@ execute1 opts gfenv0 s0 =
(\ m@(i,_) -> let file = (showIdent i ++ ".gfh") in (\ m@(i,_) -> let file = (showIdent i ++ ".gfh") in
restricted $ writeFile file (render (ppModule Qualified m)) >> P.putStrLn ("wrote " ++ file)) restricted $ writeFile file (render (ppModule Qualified m)) >> P.putStrLn ("wrote " ++ file))
(modules mygr) (modules mygr)
_ -> putStrLn $ render $ ppGrammar mygr _ -> putStrLn $ render mygr
continue gfenv continue gfenv
dependency_graph ws = dependency_graph ws =

6
src/compiler/SimpleEditor/Convert.hs
View File

@@ -6,7 +6,7 @@ import Data.List(sortBy)
import Data.Function(on) import Data.Function(on)
import qualified Data.Map as Map import qualified Data.Map as Map
import Text.JSON(makeObj) --encode import Text.JSON(makeObj) --encode
import Text.PrettyPrint(render,text,(<+>)) import GF.Text.Pretty(render,(<+>))
import qualified Data.ByteString.UTF8 as UTF8(fromString) import qualified Data.ByteString.UTF8 as UTF8(fromString)
@@ -124,11 +124,11 @@ convCncJment (name,jment) =
ResOper oltyp (Just lterm) -> return $ Op $ Oper lhs rhs ResOper oltyp (Just lterm) -> return $ Op $ Oper lhs rhs
where where
lhs = i++maybe "" ((" : "++) . render . ppTerm q 0 . unLoc) oltyp lhs = i++maybe "" ((" : "++) . render . ppTerm q 0 . unLoc) oltyp
rhs = render (text " ="<+>ppTerm q 0 (unLoc lterm)) rhs = render (" ="<+>ppTerm q 0 (unLoc lterm))
ResOverload [] defs -> return $ Op $ Oper lhs rhs ResOverload [] defs -> return $ Op $ Oper lhs rhs
where where
lhs = i lhs = i
rhs = render $ text " = overload"<+>ppTerm q 0 r rhs = render $ " = overload"<+>ppTerm q 0 r
r = R [(lab,(Just ty,fu)) | (L _ ty,L _ fu) <-defs] r = R [(lab,(Just ty,fu)) | (L _ ty,L _ fu) <-defs]
lab = ident2label name lab = ident2label name
CncFun _ (Just ldef) pprn _ -> -- ignores printname !! CncFun _ (Just ldef) pprn _ -> -- ignores printname !!