summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/compiler/GF/Command/SourceCommands.hs23
-rw-r--r--src/compiler/GF/Compile/Compute/ConcreteNew.hs67
-rw-r--r--src/compiler/GF/Compile/Compute/Predef.hs6
-rw-r--r--src/compiler/GF/Compile/Compute/Value.hs2
-rw-r--r--src/compiler/GF/Grammar/Grammar.hs4
-rw-r--r--src/compiler/GF/Grammar/Predef.hs1
-rw-r--r--src/compiler/GF/Infra/Location.hs16
-rw-r--r--src/compiler/GF/Infra/Option.hs10
8 files changed, 89 insertions, 40 deletions
diff --git a/src/compiler/GF/Command/SourceCommands.hs b/src/compiler/GF/Command/SourceCommands.hs
index 0aedd5ddf..7d882e262 100644
--- a/src/compiler/GF/Command/SourceCommands.hs
+++ b/src/compiler/GF/Command/SourceCommands.hs
@@ -7,7 +7,7 @@ import qualified Data.ByteString.UTF8 as UTF8(fromString)
import qualified Data.Map as Map
import GF.Infra.SIO(MonadSIO(..),restricted)
-import GF.Infra.Option(noOptions)
+import GF.Infra.Option(modifyFlags,optTrace) --,noOptions
import GF.Data.Operations (chunks,err,raise)
import GF.Text.Pretty(render)
@@ -49,7 +49,8 @@ sourceCommands = Map.fromList [
("list","all strings, comma-separated on one line"),
("one","pick the first strings, if there is any, from records and tables"),
("table","show all strings labelled by parameters"),
- ("unqual","hide qualifying module names")
+ ("unqual","hide qualifying module names"),
+ ("trace","trace computations")
],
needsTypeCheck = False, -- why not True?
exec = withStrings compute_concrete
@@ -165,7 +166,7 @@ sourceCommands = Map.fromList [
Left (_,msg) -> return $ pipeMessage msg
Right t -> return $ err pipeMessage
(fromString . showTerm sgr style q)
- $ checkComputeTerm sgr t
+ $ checkComputeTerm opts sgr t
where
(style,q) = pOpts TermPrintDefault Qualified opts
s = unwords ws
@@ -207,7 +208,7 @@ sourceCommands = Map.fromList [
ops <- case ts of
_:_ -> do
let Right t = runP pExp (UTF8.fromString (unwords ts))
- ty <- err error return $ checkComputeTerm sgr t
+ ty <- err error return $ checkComputeTerm os sgr t
return $ allOpersTo sgr ty
_ -> return $ allOpers sgr
let sigs = [(op,ty) | ((mo,op),ty,pos) <- ops]
@@ -251,9 +252,11 @@ sourceCommands = Map.fromList [
P.putStrLn "wrote graph in file _gfdepgraph.dot"
return void
-checkComputeTerm sgr t = do
- mo <- maybe (raise "no source grammar in scope") return $ greatestResource sgr
- ((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
- inferLType sgr [] t
- t1 <- return (CN.normalForm (CN.resourceValues noOptions sgr) (L NoLoc identW) t)
- checkPredefError t1
+checkComputeTerm os sgr t =
+ do mo <- maybe (raise "no source grammar in scope") return $
+ greatestResource sgr
+ ((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
+ inferLType sgr [] t
+ let opts = modifyFlags (\fs->fs{optTrace=isOpt "trace" os})
+ t1 = CN.normalForm (CN.resourceValues opts sgr) (L NoLoc identW) t
+ checkPredefError t1
diff --git a/src/compiler/GF/Compile/Compute/ConcreteNew.hs b/src/compiler/GF/Compile/Compute/ConcreteNew.hs
index 54e57478e..eec9f446c 100644
--- a/src/compiler/GF/Compile/Compute/ConcreteNew.hs
+++ b/src/compiler/GF/Compile/Compute/ConcreteNew.hs
@@ -7,7 +7,7 @@ module GF.Compile.Compute.ConcreteNew
import GF.Grammar hiding (Env, VGen, VApp, VRecType)
import GF.Grammar.Lookup(lookupResDefLoc,allParamValues)
-import GF.Grammar.Predef(cPredef,cErrorType,cTok,cStr)
+import GF.Grammar.Predef(cPredef,cErrorType,cTok,cStr,cTrace)
import GF.Grammar.PatternMatch(matchPattern,measurePatt)
import GF.Grammar.Lockfield(isLockLabel,lockRecType) --unlockRecord,lockLabel
import GF.Compile.Compute.Value hiding (Error)
@@ -21,7 +21,7 @@ import Data.List (findIndex,intersect,nub,elemIndex,(\\)) --,isInfixOf
--import Data.Char (isUpper,toUpper,toLower)
import GF.Text.Pretty
import qualified Data.Map as Map
---import Debug.Trace(trace)
+import Debug.Trace(trace)
-- * Main entry points
@@ -41,10 +41,11 @@ eval ge t = ($[]) # value (toplevel ge) t
type ResourceValues = Map.Map ModuleName (Map.Map Ident (Err Value))
-data GlobalEnv = GE Grammar ResourceValues Options (L Ident)
+data GlobalEnv = GE Grammar ResourceValues Options GLocation
data CompleteEnv = CE {srcgr::Grammar,rvs::ResourceValues,
opts::Options,
- gloc::L Ident,local::LocalScope}
+ gloc::GLocation,local::LocalScope}
+type GLocation = L Ident
type LocalScope = [Ident]
type Stack = [Value]
type OpenValue = Stack->Value
@@ -85,7 +86,24 @@ resourceValues opts gr = env
rvs = Map.mapWithKey moduleResources (moduleMap gr)
moduleResources m = Map.mapWithKey (moduleResource m) . jments
moduleResource m c _info = do L l t <- lookupResDefLoc gr (m,c)
- eval (GE gr rvs opts (L l c)) t
+ let loc = L l c
+ qloc = L l (Q (m,c))
+ eval (GE gr rvs opts loc) (traceRes qloc t)
+
+ traceRes = if flag optTrace opts
+ then traceResource
+ else const id
+
+-- * Tracing
+
+-- | Insert a call to the trace function under the top-level lambdas
+traceResource (L l q) t =
+ case termFormCnc t of
+ (abs,body) -> mkAbs abs (mkApp traceQ [args,body])
+ where
+ args = R $ tuple2record (K lstr:[Vr x|(bt,x)<-abs,bt==Explicit])
+ lstr = render (l<>":"<>ppTerm Qualified 0 q)
+ traceQ = Q (cPredef,cTrace)
-- * Computing values
@@ -390,35 +408,38 @@ apply' env t vs =
in \ svs -> maybe constr id (Map.lookup f predefs)
$ map ($svs) vs
| otherwise -> do r <- resource env x
- return $ \ svs -> vapply r (map ($svs) vs)
+ return $ \ svs -> vapply (gloc env) r (map ($svs) vs)
-}
App t1 t2 -> apply' env t1 . (:vs) =<< value env t2
_ -> do fv <- value env t
- return $ \ svs -> vapply (fv svs) (map ($svs) vs)
+ return $ \ svs -> vapply (gloc env) (fv svs) (map ($svs) vs)
-vapply :: Value -> [Value] -> Value
-vapply v [] = v
-vapply v vs =
+vapply :: GLocation -> Value -> [Value] -> Value
+vapply loc v [] = v
+vapply loc v vs =
case v of
VError {} -> v
-- VClosure env (Abs b x t) -> beta gr env b x t vs
- VAbs bt _ (Bind f) -> vbeta bt f vs
- VApp pre vs1 -> err msg vfv $ mapM (delta pre) (varyList (vs1++vs))
+ VAbs bt _ (Bind f) -> vbeta loc bt f vs
+ VApp pre vs1 -> delta' pre (vs1++vs)
where
+ delta' Trace (v1:v2:vs) = let vr = vapply loc v2 vs
+ in vtrace loc v1 vr
+ delta' pre vs = err msg vfv $ mapM (delta pre) (varyList vs)
--msg = const (VApp pre (vs1++vs))
msg = bug . (("Applying Predef."++showIdent (predefName pre)++": ")++)
- VS (VV t pvs fs) s -> VS (VV t pvs [vapply f vs|f<-fs]) s
- VFV fs -> vfv [vapply f vs|f<-fs]
+ VS (VV t pvs fs) s -> VS (VV t pvs [vapply loc f vs|f<-fs]) s
+ VFV fs -> vfv [vapply loc f vs|f<-fs]
VCApp f vs0 -> VCApp f (vs0++vs)
v -> bug $ "vapply "++show v++" "++show vs
-vbeta bt f (v:vs) =
+vbeta loc bt f (v:vs) =
case (bt,v) of
(Implicit,VImplArg v) -> ap v
(Explicit, v) -> ap v
where
- ap (VFV avs) = vfv [vapply (f v) vs|v<-avs]
- ap v = vapply (f v) vs
+ ap (VFV avs) = vfv [vapply loc (f v) vs|v<-avs]
+ ap v = vapply loc (f v) vs
vary (VFV vs) = vs
vary v = [v]
@@ -431,10 +452,20 @@ beta env b x t (v:vs) =
(Explicit, v) -> apply' (ext (x,v) env) t vs
-}
+vtrace loc arg res = trace (render (hang (pv arg) 4 ("->"<+>pv res))) res
+ where
+ pv v = case v of
+ VRec (f:as) -> hang (pf f) 4 (fsep (map pa as))
+ _ -> ppV v
+ pf (_,VString n) = pp n
+ pf (_,v) = ppV v
+ pa (_,v) = ppV v
+ ppV v = ppT 10 (value2term loc [] v)
+
-- tr s f vs = trace (s++" "++show vs++" = "++show r) r where r = f vs
-- | Convert a value back to a term
-value2term :: L Ident -> [Ident] -> Value -> Term
+value2term :: GLocation -> [Ident] -> Value -> Term
value2term loc xs v0 =
case v0 of
VApp pre vs -> foldl App (Q (cPredef,predefName pre)) (map v2t vs)
diff --git a/src/compiler/GF/Compile/Compute/Predef.hs b/src/compiler/GF/Compile/Compute/Predef.hs
index 0900f3665..0e02402f7 100644
--- a/src/compiler/GF/Compile/Compute/Predef.hs
+++ b/src/compiler/GF/Compile/Compute/Predef.hs
@@ -75,7 +75,7 @@ predefList =
(cIsUpper,IsUpper),(cLength,Length),(cPlus,Plus),(cEqInt,EqInt),
(cLessInt,LessInt),
-- cShow, cRead, cMapStr, cEqVal
- (cError,Error),
+ (cError,Error),(cTrace,Trace),
-- Canonical values:
(cPBool,PBool),(cPFalse,PFalse),(cPTrue,PTrue),(cInt,Int),
(cInts,Ints),(cNonExist,NonExist)
@@ -101,6 +101,7 @@ delta f vs =
LessInt -> ap2 ((<)::Int->Int->Bool)
{- -- | Show | Read | ToStr | MapStr | EqVal -}
Error -> ap1 VError
+ Trace -> ap2 vtrace
-- Canonical values:
PBool -> canonical
Int -> canonical
@@ -129,6 +130,9 @@ delta f vs =
| null [v | v@(VApp NonExist _) <- vs] = b
| otherwise = return (toValue a)
+ vtrace :: Value -> Value -> Value
+ vtrace x y = y -- tracing is implemented elsewhere
+
-- unimpl id = bug $ "unimplemented predefined function: "++showIdent id
-- problem id vs = bug $ "unexpected arguments: Predef."++showIdent id++" "++show vs
diff --git a/src/compiler/GF/Compile/Compute/Value.hs b/src/compiler/GF/Compile/Compute/Value.hs
index 9bc258562..1cf1d88ee 100644
--- a/src/compiler/GF/Compile/Compute/Value.hs
+++ b/src/compiler/GF/Compile/Compute/Value.hs
@@ -49,7 +49,7 @@ type Env = [(Ident,Value)]
data Predefined = Drop | Take | Tk | Dp | EqStr | Occur | Occurs | ToUpper
| ToLower | IsUpper | Length | Plus | EqInt | LessInt
{- | Show | Read | ToStr | MapStr | EqVal -}
- | Error
+ | Error | Trace
-- Canonical values below:
| PBool | PFalse | PTrue | Int | Ints | NonExist
| BIND | SOFT_BIND | SOFT_SPACE | CAPIT | ALL_CAPIT
diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs
index 6f254e7d3..587b09a9f 100644
--- a/src/compiler/GF/Grammar/Grammar.hs
+++ b/src/compiler/GF/Grammar/Grammar.hs
@@ -291,7 +291,7 @@ greatestResource :: Grammar -> Maybe ModuleName
greatestResource gr =
case allResources gr of
[] -> Nothing
- a -> return $ head a ---- why not last as in Abstract? works though AR 24/5/2008
+ mo:_ -> Just mo ---- why not last as in Abstract? works though AR 24/5/2008
-- | all concretes for a given abstract
allConcretes :: Grammar -> ModuleName -> [ModuleName]
@@ -455,7 +455,7 @@ type Equation = ([Patt],Term)
type Labelling = (Label, Type)
type Assign = (Label, (Maybe Type, Term))
type Case = (Patt, Term)
-type Cases = ([Patt], Term)
+--type Cases = ([Patt], Term)
type LocalDef = (Ident, (Maybe Type, Term))
type Param = (Ident, Context)
diff --git a/src/compiler/GF/Grammar/Predef.hs b/src/compiler/GF/Grammar/Predef.hs
index e330f583c..95bdb1101 100644
--- a/src/compiler/GF/Grammar/Predef.hs
+++ b/src/compiler/GF/Grammar/Predef.hs
@@ -61,6 +61,7 @@ cRead = identS "read"
cToStr = identS "toStr"
cMapStr = identS "mapStr"
cError = identS "error"
+cTrace = identS "trace"
-- * Hacks: dummy identifiers used in various places.
-- Not very nice!
diff --git a/src/compiler/GF/Infra/Location.hs b/src/compiler/GF/Infra/Location.hs
index 36bfab044..0bf85b37f 100644
--- a/src/compiler/GF/Infra/Location.hs
+++ b/src/compiler/GF/Infra/Location.hs
@@ -25,10 +25,16 @@ noLoc = L NoLoc
ppLocation :: FilePath -> Location -> Doc
ppLocation fpath NoLoc = pp fpath
ppLocation fpath (External p l) = ppLocation p l
-ppLocation fpath (Local b e)
- | b == e = fpath <> ":" <> b
- | otherwise = fpath <> ":" <> b <> "-" <> e
+ppLocation fpath (Local b e) =
+ opt (fpath/="") (fpath <> ":") <> b <> opt (b/=e) ("-" <> e)
+ where
+ opt False x = empty
+ opt True x = x
+ppL (L loc x) msg = hang (loc<>":") 4 ("In"<+>x<>":"<+>msg)
+
+
+instance Pretty Location where pp = ppLocation ""
+
+instance Pretty a => Pretty (L a) where pp (L loc x) = loc<>":"<>x
-ppL (L loc x) msg = hang (ppLocation "" loc<>":") 4
- ("In"<+>x<>":"<+>msg)
diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs
index a9a517a6e..48cb25cc7 100644
--- a/src/compiler/GF/Infra/Option.hs
+++ b/src/compiler/GF/Infra/Option.hs
@@ -178,7 +178,8 @@ data Flags = Flags {
optHeuristicFactor :: Maybe Double,
optCaseSensitive :: Bool,
optPlusAsBind :: Bool,
- optJobs :: Maybe (Maybe Int)
+ optJobs :: Maybe (Maybe Int),
+ optTrace :: Bool
}
deriving (Show)
@@ -289,7 +290,8 @@ defaultFlags = Flags {
optHeuristicFactor = Nothing,
optCaseSensitive = True,
optPlusAsBind = False,
- optJobs = Nothing
+ optJobs = Nothing,
+ optTrace = False
}
-- | Option descriptions
@@ -318,6 +320,8 @@ optDescr =
Option [] ["make"] (NoArg (liftM2 addOptions (mode ModeCompiler) (phase Link))) "Build .pgf file and other output files and exit.",
Option [] ["cpu"] (NoArg (cpu True)) "Show compilation CPU time statistics.",
Option [] ["no-cpu"] (NoArg (cpu False)) "Don't show compilation CPU time statistics (default).",
+-- Option ['t'] ["trace"] (NoArg (trace True)) "Trace computations",
+-- Option [] ["no-trace"] (NoArg (trace False)) "Don't trace computations",
Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').",
Option ['f'] ["output-format"] (ReqArg outFmt "FMT")
(unlines ["Output format. FMT can be one of:",
@@ -383,7 +387,6 @@ optDescr =
dumpOption "refresh" Refresh,
dumpOption "opt" Optimize,
dumpOption "canon" Canon
-
]
where phase x = set $ \o -> o { optStopAfterPhase = x }
mode x = set $ \o -> o { optMode = x }
@@ -406,6 +409,7 @@ optDescr =
Just i -> set $ \o -> o { optVerbosity = i }
Nothing -> fail $ "Bad verbosity: " ++ show v
cpu x = set $ \o -> o { optShowCPUTime = x }
+-- trace x = set $ \o -> o { optTrace = x }
gfoDir x = set $ \o -> o { optGFODir = Just x }
outFmt x = readOutputFormat x >>= \f ->
set $ \o -> o { optOutputFormats = optOutputFormats o ++ [f] }
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 11:38:49 +0000