summaryrefslogtreecommitdiff
path: root/src/runtime/haskell
diff options
context:
space:
mode:
Diffstat (limited to 'src/runtime/haskell')
-rw-r--r--src/runtime/haskell/PGF/Check.hs173
-rw-r--r--src/runtime/haskell/PGF/Data.hs16
-rw-r--r--src/runtime/haskell/PGF/Macros.hs9
-rw-r--r--src/runtime/haskell/PGF/VisualizeTree.hs25
4 files changed, 13 insertions, 210 deletions
diff --git a/src/runtime/haskell/PGF/Check.hs b/src/runtime/haskell/PGF/Check.hs
deleted file mode 100644
index 94713a745..000000000
--- a/src/runtime/haskell/PGF/Check.hs
+++ /dev/null
@@ -1,173 +0,0 @@
-module PGF.Check (checkPGF,checkLin) where
-
-import PGF.CId
-import PGF.Data
-import PGF.Macros
-import GF.Data.ErrM
-
-import qualified Data.Map as Map
-import Control.Monad
-import Data.Maybe(fromMaybe)
-import Debug.Trace
-
-checkPGF :: PGF -> Err (PGF,Bool)
-checkPGF pgf = return (pgf,True) {- do
- (cs,bs) <- mapM (checkConcrete pgf)
- (Map.assocs (concretes pgf)) >>= return . unzip
- return (pgf {concretes = Map.fromAscList cs}, and bs)
--}
-
--- errors are non-fatal; replace with 'fail' to change this
-msg s = trace s (return ())
-
-andMapM :: Monad m => (a -> m Bool) -> [a] -> m Bool
-andMapM f xs = mapM f xs >>= return . and
-
-labelBoolErr :: String -> Err (x,Bool) -> Err (x,Bool)
-labelBoolErr ms iob = do
- (x,b) <- iob
- if b then return (x,b) else (msg ms >> return (x,b))
-
-{-
-checkConcrete :: PGF -> (CId,Concr) -> Err ((CId,Concr),Bool)
-checkConcrete pgf (lang,cnc) =
- labelBoolErr ("happened in language " ++ showCId lang) $ do
- (rs,bs) <- mapM checkl (Map.assocs (lins cnc)) >>= return . unzip
- return ((lang,cnc{lins = Map.fromAscList rs}),and bs)
- where
- checkl = checkLin pgf lang
--}
-
-type PGFSig = (Map.Map CId (Type,Int,Maybe [Equation]),Map.Map CId Term,Map.Map CId Term)
-
-checkLin :: PGFSig -> CId -> (CId,Term) -> Err ((CId,Term),Bool)
-checkLin pgf lang (f,t) =
- labelBoolErr ("happened in function " ++ showCId f) $ do
- (t',b) <- checkTerm (lintype pgf lang f) t --- $ inline pgf lang t
- return ((f,t'),b)
-
-inferTerm :: [CType] -> Term -> Err (Term,CType)
-inferTerm args trm = case trm of
- K _ -> returnt str
- C i -> returnt $ ints i
- V i -> do
- testErr (i < length args) ("too large index " ++ show i)
- returnt $ args !! i
- S ts -> do
- (ts',tys) <- mapM infer ts >>= return . unzip
- let tys' = filter (/=str) tys
- testErr (null tys')
- ("expected Str in " ++ show trm ++ " not " ++ unwords (map show tys'))
- return (S ts',str)
- R ts -> do
- (ts',tys) <- mapM infer ts >>= return . unzip
- return $ (R ts',tuple tys)
- P t u -> do
- (t',tt) <- infer t
- (u',tu) <- infer u
- case tt of
- R tys -> case tu of
- R vs -> infer $ foldl P t' [P u' (C i) | i <- [0 .. length vs - 1]]
- --- R [v] -> infer $ P t v
- --- R (v:vs) -> infer $ P (head tys) (R vs)
-
- C i -> do
- testErr (i < length tys)
- ("required more than " ++ show i ++ " fields in " ++ show (R tys))
- return (P t' u', tys !! i) -- record: index must be known
- _ -> do
- let typ = head tys
- testErr (all (==typ) tys) ("different types in table " ++ show trm)
- return (P t' u', typ) -- table: types must be same
- _ -> Bad $ "projection from " ++ show t ++ " : " ++ show tt
- FV [] -> returnt tm0 ----
- FV (t:ts) -> do
- (t',ty) <- infer t
- (ts',tys) <- mapM infer ts >>= return . unzip
- testErr (all (eqType True ty) tys) ("different types in variants " ++ show trm)
- return (FV (t':ts'),ty)
- W s r -> infer r
- _ -> Bad ("no type inference for " ++ show trm)
- where
- returnt ty = return (trm,ty)
- infer = inferTerm args
-
-checkTerm :: LinType -> Term -> Err (Term,Bool)
-checkTerm (args,val) trm = case inferTerm args trm of
- Ok (t,ty) -> if eqType False ty val
- then return (t,True)
- else do
- msg ("term: " ++ show trm ++
- "\nexpected type: " ++ show val ++
- "\ninferred type: " ++ show ty)
- return (t,False)
- Bad s -> do
- msg s
- return (trm,False)
-
--- symmetry in (Ints m == Ints n) is all we can use in variants
-
-eqType :: Bool -> CType -> CType -> Bool
-eqType symm inf exp = case (inf,exp) of
- (C k, C n) -> if symm then True else k <= n -- only run-time corr.
- (R rs,R ts) -> length rs == length ts && and [eqType symm r t | (r,t) <- zip rs ts]
- (TM _, _) -> True ---- for variants [] ; not safe
- _ -> inf == exp
-
--- should be in a generic module, but not in the run-time DataGFCC
-
-type CType = Term
-type LinType = ([CType],CType)
-
-tuple :: [CType] -> CType
-tuple = R
-
-ints :: Int -> CType
-ints = C
-
-str :: CType
-str = S []
-
-lintype :: PGFSig -> CId -> CId -> LinType
-lintype pgf lang fun = case typeSkeleton (lookFun pgf fun) of
- (cs,c) -> (map vlinc cs, linc c) ---- HOAS
- where
- linc = lookLincat pgf lang
- vlinc (0,c) = linc c
- vlinc (i,c) = case linc c of
- R ts -> R (ts ++ replicate i str)
-
-composOp :: Monad m => (Term -> m Term) -> Term -> m Term
-composOp f trm = case trm of
- R ts -> liftM R $ mapM f ts
- S ts -> liftM S $ mapM f ts
- FV ts -> liftM FV $ mapM f ts
- P t u -> liftM2 P (f t) (f u)
- W s t -> liftM (W s) $ f t
- _ -> return trm
-
-composSafeOp :: (Term -> Term) -> Term -> Term
-composSafeOp f = maybe undefined id . composOp (return . f)
-
--- from GF.Data.Oper
-
-maybeErr :: String -> Maybe a -> Err a
-maybeErr s = maybe (Bad s) Ok
-
-testErr :: Bool -> String -> Err ()
-testErr cond msg = if cond then return () else Bad msg
-
-errVal :: a -> Err a -> a
-errVal a = err (const a) id
-
-errIn :: String -> Err a -> Err a
-errIn msg = err (\s -> Bad (s ++ "\nOCCURRED IN\n" ++ msg)) return
-
-err :: (String -> b) -> (a -> b) -> Err a -> b
-err d f e = case e of
- Ok a -> f a
- Bad s -> d s
-
-lookFun (abs,lin,lincats) f = (\(a,b,c) -> a) $ fromMaybe (error "No abs") (Map.lookup f abs)
-lookLincat (abs,lin,lincats) _ c = fromMaybe (error "No lincat") (Map.lookup c lincats)
-lookLin (abs,lin,lincats) _ f = fromMaybe (error "No lin") (Map.lookup f lin)
diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs
index 12f945151..8b2fb41f8 100644
--- a/src/runtime/haskell/PGF/Data.hs
+++ b/src/runtime/haskell/PGF/Data.hs
@@ -68,22 +68,6 @@ data Alternative =
Alt [String] [String]
deriving (Eq,Ord,Show)
-data Term =
- R [Term]
- | P Term Term
- | S [Term]
- | K Tokn
- | V Int
- | C Int
- | FV [Term]
- | W String Term
- | TM String
- deriving (Eq,Ord,Show)
-
-data Tokn =
- KS String
- | KP [String] [Alternative]
- deriving (Eq,Ord,Show)
-- merge two PGFs; fails is differens absnames; priority to second arg
diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs
index 1bee56b9b..f6116ba60 100644
--- a/src/runtime/haskell/PGF/Macros.hs
+++ b/src/runtime/haskell/PGF/Macros.hs
@@ -117,15 +117,6 @@ contextLength ty = case ty of
showPrintName :: PGF -> Language -> CId -> String
showPrintName pgf lang id = lookMap (showCId id) id $ printnames $ lookMap (error "no lang") lang $ concretes pgf
-term0 :: CId -> Term
-term0 = TM . showCId
-
-tm0 :: Term
-tm0 = TM "?"
-
-kks :: String -> Term
-kks = K . KS
-
-- lookup with default value
lookMap :: (Show i, Ord i) => a -> i -> Map.Map i a -> a
lookMap d c m = Map.findWithDefault d c m
diff --git a/src/runtime/haskell/PGF/VisualizeTree.hs b/src/runtime/haskell/PGF/VisualizeTree.hs
index 68392422f..226fc5fa8 100644
--- a/src/runtime/haskell/PGF/VisualizeTree.hs
+++ b/src/runtime/haskell/PGF/VisualizeTree.hs
@@ -28,7 +28,8 @@ import PGF.CId (CId,showCId,ppCId,pCId,mkCId)
import PGF.Data
import PGF.Expr (showExpr, Tree)
import PGF.Linearize
-import PGF.Macros (lookValCat, lookMap, _B, _V, BracketedString(..), flattenBracketedString)
+import PGF.Macros (lookValCat, lookMap, _B, _V,
+ BracketedString(..), BracketedTokn(..), flattenBracketedString)
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
@@ -274,7 +275,7 @@ tag i
--
-- Uuuuugly!!! I hope that this code will be removed one day.
-type LinTable = Array LIndex [Tokn]
+type LinTable = Array LIndex [BracketedTokn]
linTree :: PGF -> Language -> (Maybe CId -> [Int] -> LinTable -> LinTable) -> Expr -> [LinTable]
@@ -299,7 +300,7 @@ linTree pgf lang mark e = lin0 [] [] [] Nothing e
lin path xs mb_fid (ETyped e _) es = lin path xs mb_fid e es
lin path xs mb_fid (EImplArg e) es = lin path xs mb_fid e es
- ss s = listArray (0,0) [[KS s]]
+ ss s = listArray (0,0) [[LeafKS [s]]]
apply path xs mb_fid f es =
case Map.lookup f lp of
@@ -332,15 +333,15 @@ linTree pgf lang mark e = lin0 [] [] [] Nothing e
compute (SymCat d r) = (args !! d) ! r
compute (SymLit d r) = (args !! d) ! r
- compute (SymKS ts) = map KS ts
- compute (SymKP ts alts) = [KP ts alts]
+ compute (SymKS ts) = [LeafKS ts]
+ compute (SymKP ts alts) = [LeafKP ts alts]
-untokn :: [Tokn] -> [String]
+untokn :: [BracketedTokn] -> [String]
untokn ts = case ts of
- KP d _ : [] -> d
- KP d vs : ws -> let ss@(s:_) = untokn ws in sel d vs s ++ ss
- KS s : ws -> s : untokn ws
- [] -> []
+ LeafKP d _ : [] -> d
+ LeafKP d vs : ws -> let ss@(s:_) = untokn ws in sel d vs s ++ ss
+ LeafKS s : ws -> s ++ untokn ws
+ [] -> []
where
sel d vs w = case [v | Alt v cs <- vs, any (\c -> isPrefixOf c w) cs] of
v:_ -> v
@@ -353,8 +354,8 @@ markLinearizes pgf lang = map (unwords . untokn . (! 0)) . linTree pgf lang mark
where
mark mb_f path lint = amap (bracket mb_f path) lint
- bracket Nothing path ts = [KS ("("++show (reverse path))] ++ ts ++ [KS ")"]
- bracket (Just f) path ts = [KS ("(("++showCId f++","++show (reverse path)++")")] ++ ts ++ [KS ")"]
+ bracket Nothing path ts = [LeafKS ["("++show (reverse path)]] ++ ts ++ [LeafKS [")"]]
+ bracket (Just f) path ts = [LeafKS ["(("++showCId f++","++show (reverse path)++")"]] ++ ts ++ [LeafKS [")"]]
graphvizDependencyTree :: String -> Bool -> Maybe Labels -> Maybe String -> PGF -> CId -> Expr -> String
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 09:26:29 +0000