summaryrefslogtreecommitdiff
path: root/src/runtime/haskell
diff options
context:
space:
mode:
Diffstat (limited to 'src/runtime/haskell')
-rw-r--r--src/runtime/haskell/PGF.hs32
-rw-r--r--src/runtime/haskell/PGF/Binary.hs32
-rw-r--r--src/runtime/haskell/PGF/ByteCode.hs47
-rw-r--r--src/runtime/haskell/PGF/Data.hs19
-rw-r--r--src/runtime/haskell/PGF/Expr.hs30
-rw-r--r--src/runtime/haskell/PGF/Forest.hs2
-rw-r--r--src/runtime/haskell/PGF/Internal.hs1
-rw-r--r--src/runtime/haskell/PGF/Linearize.hs2
-rw-r--r--src/runtime/haskell/PGF/Macros.hs17
-rw-r--r--src/runtime/haskell/PGF/OldBinary.hs6
-rw-r--r--src/runtime/haskell/PGF/Paraphrase.hs2
-rw-r--r--src/runtime/haskell/PGF/Printer.hs25
-rw-r--r--src/runtime/haskell/PGF/Probabilistic.hs20
-rw-r--r--src/runtime/haskell/PGF/SortTop.hs6
-rw-r--r--src/runtime/haskell/PGF/TypeCheck.hs12
15 files changed, 156 insertions, 97 deletions
diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs
index 77eac1ada..8c901c7a9 100644
--- a/src/runtime/haskell/PGF.hs
+++ b/src/runtime/haskell/PGF.hs
@@ -293,8 +293,8 @@ categories pgf = [c | (c,hs) <- Map.toList (cats (abstract pgf))]
categoryContext pgf cat =
case Map.lookup cat (cats (abstract pgf)) of
- Just (hypos,_,_,_) -> Just hypos
- Nothing -> Nothing
+ Just (hypos,_,_) -> Just hypos
+ Nothing -> Nothing
startCat pgf = DTyp [] (lookStartCat pgf) []
@@ -302,13 +302,13 @@ functions pgf = Map.keys (funs (abstract pgf))
functionsByCat pgf cat =
case Map.lookup cat (cats (abstract pgf)) of
- Just (_,fns,_,_) -> map snd fns
- Nothing -> []
+ Just (_,fns,_) -> map snd fns
+ Nothing -> []
functionType pgf fun =
case Map.lookup fun (funs (abstract pgf)) of
- Just (ty,_,_,_,_) -> Just ty
- Nothing -> Nothing
+ Just (ty,_,_,_) -> Just ty
+ Nothing -> Nothing
-- | Converts an expression to normal form
compute :: PGF -> Expr -> Expr
@@ -318,20 +318,20 @@ browse :: PGF -> CId -> Maybe (String,[CId],[CId])
browse pgf id = fmap (\def -> (def,producers,consumers)) definition
where
definition = case Map.lookup id (funs (abstract pgf)) of
- Just (ty,_,Just eqs,_,_) -> Just $ render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$
- if null eqs
- then empty
- else text "def" <+> vcat [let scope = foldl pattScope [] patts
- ds = map (ppPatt 9 scope) patts
- in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs])
- Just (ty,_,Nothing, _,_) -> Just $ render (text "data" <+> ppCId id <+> colon <+> ppType 0 [] ty)
+ Just (ty,_,Just (eqs,_),_) -> Just $ render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$
+ if null eqs
+ then empty
+ else text "def" <+> vcat [let scope = foldl pattScope [] patts
+ ds = map (ppPatt 9 scope) patts
+ in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs])
+ Just (ty,_,Nothing,_) -> Just $ render (text "data" <+> ppCId id <+> colon <+> ppType 0 [] ty)
Nothing -> case Map.lookup id (cats (abstract pgf)) of
- Just (hyps,_,_,_) -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)))
- Nothing -> Nothing
+ Just (hyps,_,_) -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)))
+ Nothing -> Nothing
(producers,consumers) = Map.foldWithKey accum ([],[]) (funs (abstract pgf))
where
- accum f (ty,_,_,_,_) (plist,clist) =
+ accum f (ty,_,_,_) (plist,clist) =
let !plist' = if id `elem` ps then f : plist else plist
!clist' = if id `elem` cs then f : clist else clist
in (plist',clist')
diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs
index 4d4c53102..b2bfda069 100644
--- a/src/runtime/haskell/PGF/Binary.hs
+++ b/src/runtime/haskell/PGF/Binary.hs
@@ -3,12 +3,12 @@ module PGF.Binary(putSplitAbs) where
import PGF.CId
import PGF.Data
import PGF.Optimize
+import PGF.ByteCode
import qualified PGF.OldBinary as Old
import Data.Binary
import Data.Binary.Put
import Data.Binary.Get
import Data.Array.IArray
-import qualified Data.ByteString as BS
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
--import qualified Data.Set as Set
@@ -43,16 +43,15 @@ instance Binary CId where
get = liftM CId get
instance Binary Abstr where
- put abs = put (aflags abs,
- fmap (\(w,x,y,z,_) -> (w,x,y,z)) (funs abs),
- fmap (\(x,y,z,_) -> (x,y,z)) (cats abs))
+ put abs = do put (aflags abs)
+ put (Map.map (\(ty,arity,mb_eq,prob) -> (ty,arity,fmap fst mb_eq,prob)) (funs abs))
+ put (cats abs)
get = do aflags <- get
funs <- get
cats <- get
return (Abstr{ aflags=aflags
- , funs=fmap (\(w,x,y,z) -> (w,x,y,z,0)) funs
- , cats=fmap (\(x,y,z) -> (x,y,z,0)) cats
- , code=BS.empty
+ , funs=Map.map (\(ty,arity,mb_eq,prob) -> (ty,arity,fmap (\eq -> (eq,[])) mb_eq,prob)) funs
+ , cats=cats
})
putSplitAbs :: PGF -> Put
@@ -136,6 +135,25 @@ instance Binary Equation where
put (Equ ps e) = put (ps,e)
get = liftM2 Equ get get
+instance Binary Instr where
+ put (EVAL n) = putWord8 0 >> put n
+ put (CASE id l ) = putWord8 1 >> put (id,l)
+ put (CASE_INT n l ) = putWord8 2 >> put (n,l)
+ put (CASE_STR s l ) = putWord8 3 >> put (s,l)
+ put (CASE_FLT d l ) = putWord8 4 >> put (d,l)
+ put (ALLOC n) = putWord8 5 >> put n
+ put (PUT_CONSTR id) = putWord8 6 >> put id
+ put (PUT_CLOSURE l) = putWord8 7 >> put l
+ put (PUT_INT n) = putWord8 8 >> put n
+ put (PUT_STR s) = putWord8 9 >> put s
+ put (PUT_FLT d) = putWord8 10 >> put d
+ put (SET_VALUE n) = putWord8 11 >> put n
+ put (SET_VARIABLE n) = putWord8 12 >> put n
+ put (TAIL_CALL id) = putWord8 13 >> put id
+ put (FAIL ) = putWord8 14
+ put (RET n) = putWord8 15 >> put n
+
+
instance Binary Type where
put (DTyp hypos cat exps) = put (hypos,cat,exps)
get = liftM3 DTyp get get get
diff --git a/src/runtime/haskell/PGF/ByteCode.hs b/src/runtime/haskell/PGF/ByteCode.hs
new file mode 100644
index 000000000..b8e7d889d
--- /dev/null
+++ b/src/runtime/haskell/PGF/ByteCode.hs
@@ -0,0 +1,47 @@
+module PGF.ByteCode(CodeLabel, Instr(..), ppCode, ppInstr) where
+
+import PGF.CId
+import Text.PrettyPrint
+
+type CodeLabel = Int
+
+data Instr
+ = EVAL {-# UNPACK #-} !Int
+ | CASE CId {-# UNPACK #-} !CodeLabel
+ | CASE_INT Int {-# UNPACK #-} !CodeLabel
+ | CASE_STR String {-# UNPACK #-} !CodeLabel
+ | CASE_FLT Double {-# UNPACK #-} !CodeLabel
+ | ALLOC {-# UNPACK #-} !Int
+ | PUT_CONSTR CId
+ | PUT_CLOSURE {-# UNPACK #-} !CodeLabel
+ | PUT_INT {-# UNPACK #-} !Int
+ | PUT_STR String
+ | PUT_FLT {-# UNPACK #-} !Double
+ | SET_VALUE {-# UNPACK #-} !Int
+ | SET_VARIABLE {-# UNPACK #-} !Int
+ | TAIL_CALL CId
+ | FAIL
+ | RET {-# UNPACK #-} !Int
+
+ppCode :: CodeLabel -> [Instr] -> Doc
+ppCode l [] = empty
+ppCode l (i:is) = ppLabel l <+> ppInstr l i $$ ppCode (l+1) is
+
+ppInstr l (EVAL n) = text "EVAL " <+> int n
+ppInstr l (CASE id o ) = text "CASE " <+> ppCId id <+> ppLabel (l+o+1)
+ppInstr l (CASE_INT n o ) = text "CASE_INT " <+> int n <+> ppLabel (l+o+1)
+ppInstr l (CASE_STR s o ) = text "CASE_STR " <+> text (show s) <+> ppLabel (l+o+1)
+ppInstr l (CASE_FLT d o ) = text "CASE_FLT " <+> double d <+> ppLabel (l+o+1)
+ppInstr l (ALLOC n) = text "ALLOC " <+> int n
+ppInstr l (SET_VALUE n) = text "SET_VALUE " <+> int n
+ppInstr l (PUT_CONSTR id) = text "PUT_CONSTR " <+> ppCId id
+ppInstr l (PUT_CLOSURE c) = text "PUT_CLOSURE " <+> ppLabel c
+ppInstr l (PUT_INT n ) = text "PUT_INT " <+> int n
+ppInstr l (PUT_STR s ) = text "PUT_STR " <+> text (show s)
+ppInstr l (PUT_FLT d ) = text "PUT_FLT " <+> double d
+ppInstr l (SET_VARIABLE n) = text "SET_VARIABLE" <+> int n
+ppInstr l (TAIL_CALL id) = text "TAIL_CALL " <+> ppCId id
+ppInstr l (FAIL ) = text "FAIL"
+ppInstr l (RET n) = text "RET " <+> int n
+
+ppLabel l = text (let s = show l in replicate (4-length s) '0' ++ s)
diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs
index 3222867d2..76dbc616a 100644
--- a/src/runtime/haskell/PGF/Data.hs
+++ b/src/runtime/haskell/PGF/Data.hs
@@ -2,6 +2,7 @@ module PGF.Data (module PGF.Data, module PGF.Expr, module PGF.Type) where
import PGF.CId
import PGF.Expr hiding (Value, Sig, Env, Tree, eval, apply, applyValue, value2expr)
+import PGF.ByteCode
import PGF.Type
import qualified Data.Map as Map
@@ -9,7 +10,6 @@ import qualified Data.Set as Set
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified PGF.TrieMap as TMap
-import qualified Data.ByteString as BS
import Data.Array.IArray
import Data.Array.Unboxed
--import Data.List
@@ -28,12 +28,11 @@ data PGF = PGF {
data Abstr = Abstr {
aflags :: Map.Map CId Literal, -- ^ value of a flag
- funs :: Map.Map CId (Type,Int,Maybe [Equation],Double,BCAddr), -- ^ type, arrity and definition of function + probability
- cats :: Map.Map CId ([Hypo],[(Double, CId)],Double,BCAddr), -- ^ 1. context of a category
- -- 2. functions of a category. The functions are stored
- -- in decreasing probability order.
- -- 3. probability
- code :: BS.ByteString
+ funs :: Map.Map CId (Type,Int,Maybe ([Equation],[Instr]),Double),-- ^ type, arrity and definition of function + probability
+ cats :: Map.Map CId ([Hypo],[(Double, CId)],Double) -- ^ 1. context of a category
+ -- 2. functions of a category. The functions are stored
+ -- in decreasing probability order.
+ -- 3. probability
}
data Concr = Concr {
@@ -76,8 +75,6 @@ data CncFun = CncFun CId {-# UNPACK #-} !(UArray LIndex SeqId) deriving (Eq,Ord,
type Sequence = Array DotPos Symbol
type FunId = Int
type SeqId = Int
-type BCAddr = Int
-
-- merge two PGFs; fails is differens absnames; priority to second arg
@@ -105,8 +102,8 @@ emptyPGF = PGF {
haveSameFunsPGF :: PGF -> PGF -> Bool
haveSameFunsPGF one two =
let
- fsone = [(f,t) | (f,(t,_,_,_,_)) <- Map.toList (funs (abstract one))]
- fstwo = [(f,t) | (f,(t,_,_,_,_)) <- Map.toList (funs (abstract two))]
+ fsone = [(f,t) | (f,(t,_,_,_)) <- Map.toList (funs (abstract one))]
+ fstwo = [(f,t) | (f,(t,_,_,_)) <- Map.toList (funs (abstract two))]
in fsone == fstwo
-- | This is just a 'CId' with the language name.
diff --git a/src/runtime/haskell/PGF/Expr.hs b/src/runtime/haskell/PGF/Expr.hs
index 264be4aaa..0b4ccc554 100644
--- a/src/runtime/haskell/PGF/Expr.hs
+++ b/src/runtime/haskell/PGF/Expr.hs
@@ -21,6 +21,7 @@ module PGF.Expr(Tree, BindType(..), Expr(..), Literal(..), Patt(..), Equation(..
import PGF.CId
import PGF.Type
+import PGF.ByteCode
import Data.Char
--import Data.Maybe
@@ -324,21 +325,22 @@ data Value
| VClosure Env Expr
| VImplArg Value
-type Sig = ( Map.Map CId (Type,Int,Maybe [Equation],Double,Int) -- type and def of a fun
- , Int -> Maybe Expr -- lookup for metavariables
+type Sig = ( Map.Map CId (Type,Int,Maybe ([Equation],[Instr]),Double) -- type and def of a fun
+ , Int -> Maybe Expr -- lookup for metavariables
)
type Env = [Value]
eval :: Sig -> Env -> Expr -> Value
eval sig env (EVar i) = env !! i
eval sig env (EFun f) = case Map.lookup f (fst sig) of
- Just (_,a,meqs,_,_) -> case meqs of
- Just eqs -> if a == 0
- then case eqs of
- Equ [] e : _ -> eval sig [] e
- _ -> VConst f []
- else VApp f []
- Nothing -> VApp f []
+ Just (_,a,meqs,_) -> case meqs of
+ Just (eqs,_)
+ -> if a == 0
+ then case eqs of
+ Equ [] e : _ -> eval sig [] e
+ _ -> VConst f []
+ else VApp f []
+ Nothing -> VApp f []
Nothing -> error ("unknown function "++showCId f)
eval sig env (EApp e1 e2) = apply sig env e1 [eval sig env e2]
eval sig env (EAbs b x e) = VClosure env (EAbs b x e)
@@ -353,11 +355,11 @@ apply :: Sig -> Env -> Expr -> [Value] -> Value
apply sig env e [] = eval sig env e
apply sig env (EVar i) vs = applyValue sig (env !! i) vs
apply sig env (EFun f) vs = case Map.lookup f (fst sig) of
- Just (_,a,meqs,_,_) -> case meqs of
- Just eqs -> if a <= length vs
- then match sig f eqs vs
- else VApp f vs
- Nothing -> VApp f vs
+ Just (_,a,meqs,_) -> case meqs of
+ Just (eqs,_) -> if a <= length vs
+ then match sig f eqs vs
+ else VApp f vs
+ Nothing -> VApp f vs
Nothing -> error ("unknown function "++showCId f)
apply sig env (EApp e1 e2) vs = apply sig env e1 (eval sig env e2 : vs)
apply sig env (EAbs b x e) (v:vs) = case (b,v) of
diff --git a/src/runtime/haskell/PGF/Forest.hs b/src/runtime/haskell/PGF/Forest.hs
index 8a38948be..bb4ba29af 100644
--- a/src/runtime/haskell/PGF/Forest.hs
+++ b/src/runtime/haskell/PGF/Forest.hs
@@ -75,7 +75,7 @@ bracketedTokn dp f@(Forest abs cnc forest root) =
cat = case isLindefCId fun of
Just cat -> cat
Nothing -> case Map.lookup fun (funs abs) of
- Just (DTyp _ cat _,_,_,_,_) -> cat
+ Just (DTyp _ cat _,_,_,_) -> cat
largs = map (render forest) args
ltable = mkLinTable cnc isTrusted [] funid largs
in ((cat,fid),0,wildCId,either (const []) id $ getAbsTrees f arg Nothing dp,ltable)
diff --git a/src/runtime/haskell/PGF/Internal.hs b/src/runtime/haskell/PGF/Internal.hs
index f2c79596c..3b252a36b 100644
--- a/src/runtime/haskell/PGF/Internal.hs
+++ b/src/runtime/haskell/PGF/Internal.hs
@@ -11,6 +11,7 @@ import PGF.Macros as Internal
import PGF.Optimize as Internal
import PGF.Printer as Internal
import PGF.Utilities as Internal
+import PGF.ByteCode as Internal
import Data.Binary as Internal
import Data.Binary.Get as Internal
diff --git a/src/runtime/haskell/PGF/Linearize.hs b/src/runtime/haskell/PGF/Linearize.hs
index ea560165d..3f11f93d1 100644
--- a/src/runtime/haskell/PGF/Linearize.hs
+++ b/src/runtime/haskell/PGF/Linearize.hs
@@ -101,7 +101,7 @@ linTree pgf cnc e = nub (map snd (lin Nothing 0 e [] [] e []))
Nothing -> concat [toApp fid prod | (fid,set) <- IntMap.toList prods, prod <- Set.toList set]
where
toApp fid (PApply funid pargs) =
- let Just (ty,_,_,_,_) = Map.lookup f (funs (abstract pgf))
+ let Just (ty,_,_,_) = Map.lookup f (funs (abstract pgf))
(args,res) = catSkeleton ty
in [(funid,(res,fid),zip args [fid | PArg _ fid <- pargs])]
toApp _ (PCoerce fid) =
diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs
index 0e73180d5..7cf2661cc 100644
--- a/src/runtime/haskell/PGF/Macros.hs
+++ b/src/runtime/haskell/PGF/Macros.hs
@@ -21,18 +21,13 @@ mapConcretes f pgf = pgf { concretes = Map.map f (concretes pgf) }
lookType :: Abstr -> CId -> Type
lookType abs f =
case lookMap (error $ "lookType " ++ show f) f (funs abs) of
- (ty,_,_,_,_) -> ty
-
-lookDef :: Abstr -> CId -> Maybe [Equation]
-lookDef abs f =
- case lookMap (error $ "lookDef " ++ show f) f (funs abs) of
- (_,a,eqs,_,_) -> eqs
+ (ty,_,_,_) -> ty
isData :: Abstr -> CId -> Bool
isData abs f =
case Map.lookup f (funs abs) of
- Just (_,_,Nothing,_,_) -> True -- the encoding of data constrs
- _ -> False
+ Just (_,_,Nothing,_) -> True -- the encoding of data constrs
+ _ -> False
lookValCat :: Abstr -> CId -> CId
lookValCat abs = valCat . lookType abs
@@ -65,9 +60,9 @@ lookConcrFlag pgf lang f = Map.lookup f $ cflags $ lookConcr pgf lang
functionsToCat :: PGF -> CId -> [(CId,Type)]
functionsToCat pgf cat =
- [(f,ty) | (_,f) <- fs, Just (ty,_,_,_,_) <- [Map.lookup f $ funs $ abstract pgf]]
+ [(f,ty) | (_,f) <- fs, Just (ty,_,_,_) <- [Map.lookup f $ funs $ abstract pgf]]
where
- (_,fs,_,_) = lookMap ([],[],0,0) cat $ cats $ abstract pgf
+ (_,fs,_) = lookMap ([],[],0) cat $ cats $ abstract pgf
-- | List of functions that lack linearizations in the given language.
missingLins :: PGF -> Language -> [CId]
@@ -82,7 +77,7 @@ restrictPGF :: (CId -> Bool) -> PGF -> PGF
restrictPGF cond pgf = pgf {
abstract = abstr {
funs = Map.filterWithKey (\c _ -> cond c) (funs abstr),
- cats = Map.map (\(hyps,fs,p,addr) -> (hyps,filter (cond . snd) fs,p,addr)) (cats abstr)
+ cats = Map.map (\(hyps,fs,p) -> (hyps,filter (cond . snd) fs,p)) (cats abstr)
}
} ---- restrict concrs also, might be needed
where
diff --git a/src/runtime/haskell/PGF/OldBinary.hs b/src/runtime/haskell/PGF/OldBinary.hs
index 55a1f1a5c..9a65b0fa6 100644
--- a/src/runtime/haskell/PGF/OldBinary.hs
+++ b/src/runtime/haskell/PGF/OldBinary.hs
@@ -7,7 +7,6 @@ import PGF.Optimize
import Data.Binary
import Data.Binary.Get
import Data.Array.IArray
-import qualified Data.ByteString as BS
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import qualified Data.Set as Set
@@ -40,9 +39,8 @@ getAbstract =
funs <- getMap getCId getFun
cats <- getMap getCId getCat
return (Abstr{ aflags=aflags
- , funs=fmap (\(w,x,y,z) -> (w,x,y,z,0)) funs
- , cats=fmap (\(x,y) -> (x,y,0,0)) cats
- , code=BS.empty
+ , funs=fmap (\(w,x,y,z) -> (w,x,fmap (flip (,) []) y,z)) funs
+ , cats=fmap (\(x,y) -> (x,y,0)) cats
})
getFun :: Get (Type,Int,Maybe [Equation],Double)
getFun = (,,,) `fmap` getType `ap` get `ap` getMaybe (getList getEquation) `ap` get
diff --git a/src/runtime/haskell/PGF/Paraphrase.hs b/src/runtime/haskell/PGF/Paraphrase.hs
index 57697b8d2..8bee81f43 100644
--- a/src/runtime/haskell/PGF/Paraphrase.hs
+++ b/src/runtime/haskell/PGF/Paraphrase.hs
@@ -53,7 +53,7 @@ fromDef pgf t@(Fun f ts) = defDown t ++ defUp t where
isClosed d || (length equs == 1 && isLinear d)]
equss = [(f,[(Fun f (map patt2tree ps), expr2tree d) | (Equ ps d) <- eqs]) |
- (f,(_,_,Just eqs,_,_)) <- Map.assocs (funs (abstract pgf)), not (null eqs)]
+ (f,(_,_,Just (eqs,_),_)) <- Map.assocs (funs (abstract pgf)), not (null eqs)]
---- AR 14/12/2010: (expr2tree d) fails unless we send the variable list from ps in eqs;
---- cf. PGF.Tree.expr2tree
trequ s f e = True ----trace (s ++ ": " ++ show f ++ " " ++ show e) True
diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs
index 4945667f4..1aabce09d 100644
--- a/src/runtime/haskell/PGF/Printer.hs
+++ b/src/runtime/haskell/PGF/Printer.hs
@@ -2,7 +2,7 @@ module PGF.Printer (ppPGF,ppCat,ppFId,ppFunId,ppSeqId,ppSeq,ppFun) where
import PGF.CId
import PGF.Data
---import PGF.Macros
+import PGF.ByteCode
import qualified Data.Map as Map
import qualified Data.Set as Set
@@ -26,17 +26,18 @@ ppAbs name a = text "abstract" <+> ppCId name <+> char '{' $$
ppFlag :: CId -> Literal -> Doc
ppFlag flag value = text "flag" <+> ppCId flag <+> char '=' <+> ppLit value <+> char ';'
-ppCat :: CId -> ([Hypo],[(Double,CId)],Double,BCAddr) -> Doc
-ppCat c (hyps,_,_,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';'
-
-ppFun :: CId -> (Type,Int,Maybe [Equation],Double,BCAddr) -> Doc
-ppFun f (t,_,Just eqs,_,_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$
- if null eqs
- then empty
- else text "def" <+> vcat [let scope = foldl pattScope [] patts
- ds = map (ppPatt 9 scope) patts
- in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs]
-ppFun f (t,_,Nothing,_,_) = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';'
+ppCat :: CId -> ([Hypo],[(Double,CId)],Double) -> Doc
+ppCat c (hyps,_,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';'
+
+ppFun :: CId -> (Type,Int,Maybe ([Equation],[Instr]),Double) -> Doc
+ppFun f (t,_,Just (eqs,code),_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$
+ if null eqs
+ then empty
+ else text "def" <+> vcat [let scope = foldl pattScope [] patts
+ ds = map (ppPatt 9 scope) patts
+ in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs] $$
+ ppCode 0 code
+ppFun f (t,_,Nothing,_) = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';'
ppCnc :: Language -> Concr -> Doc
ppCnc name cnc =
diff --git a/src/runtime/haskell/PGF/Probabilistic.hs b/src/runtime/haskell/PGF/Probabilistic.hs
index 7d8d58134..555ae0ce9 100644
--- a/src/runtime/haskell/PGF/Probabilistic.hs
+++ b/src/runtime/haskell/PGF/Probabilistic.hs
@@ -52,7 +52,7 @@ readProbabilitiesFromFile file pgf = do
mkProbabilities :: PGF -> Map.Map CId Double -> Probabilities
mkProbabilities pgf probs =
let funs1 = Map.fromList [(f,p) | (_,(_,fns)) <- Map.toList cats1, (p,f) <- fns]
- cats1 = Map.mapWithKey (\c (_,fns,_,_) ->
+ cats1 = Map.mapWithKey (\c (_,fns,_) ->
let p' = fromMaybe 0 (Map.lookup c probs)
fns' = sortBy cmpProb (fill fns)
in (p', fns'))
@@ -76,15 +76,15 @@ defaultProbabilities pgf = mkProbabilities pgf Map.empty
getProbabilities :: PGF -> Probabilities
getProbabilities pgf = Probs {
- funProbs = Map.map (\(_,_,_,p,_) -> p ) (funs (abstract pgf)),
- catProbs = Map.map (\(_,fns,p,_) -> (p,fns)) (cats (abstract pgf))
+ funProbs = Map.map (\(_,_,_,p) -> p ) (funs (abstract pgf)),
+ catProbs = Map.map (\(_,fns,p) -> (p,fns)) (cats (abstract pgf))
}
setProbabilities :: Probabilities -> PGF -> PGF
setProbabilities probs pgf = pgf {
abstract = (abstract pgf) {
- funs = mapUnionWith (\(ty,a,df,_,addr) p -> (ty,a,df, p,addr)) (funs (abstract pgf)) (funProbs probs),
- cats = mapUnionWith (\(hypos,_,_,addr) (p,fns) -> (hypos,fns,p,addr)) (cats (abstract pgf)) (catProbs probs)
+ funs = mapUnionWith (\(ty,a,df,_) p -> (ty,a,df, p)) (funs (abstract pgf)) (funProbs probs),
+ cats = mapUnionWith (\(hypos,_,_) (p,fns) -> (hypos,fns,p)) (cats (abstract pgf)) (catProbs probs)
}}
where
mapUnionWith f map1 map2 =
@@ -95,8 +95,8 @@ probTree :: PGF -> Expr -> Double
probTree pgf t = case t of
EApp f e -> probTree pgf f * probTree pgf e
EFun f -> case Map.lookup f (funs (abstract pgf)) of
- Just (_,_,_,p,_) -> p
- Nothing -> 1
+ Just (_,_,_,p) -> p
+ Nothing -> 1
_ -> 1
-- | rank from highest to lowest probability
@@ -107,13 +107,13 @@ rankTreesByProbs pgf ts = sortBy (\ (_,p) (_,q) -> compare q p)
mkProbDefs :: PGF -> ([[CId]],[(CId,Type,[Equation])])
mkProbDefs pgf =
- let cs = [(c,hyps,fns) | (c,(hyps0,fs,_,_)) <- Map.toList (cats (abstract pgf)),
+ let cs = [(c,hyps,fns) | (c,(hyps0,fs,_)) <- Map.toList (cats (abstract pgf)),
not (elem c [cidString,cidInt,cidFloat]),
let hyps = zipWith (\(bt,_,ty) n -> (bt,mkCId ('v':show n),ty))
hyps0
[1..]
fns = [(f,ty) | (_,f) <- fs,
- let Just (ty,_,_,_,_) = Map.lookup f (funs (abstract pgf))]
+ let Just (ty,_,_,_) = Map.lookup f (funs (abstract pgf))]
]
((_,css),eqss) = mapAccumL (\(ngen,css) (c,hyps,fns) ->
let st0 = (1,Map.empty)
@@ -263,7 +263,7 @@ computeConstrs pgf st fns =
where
addArgs (cn,fns) = addArg (length args) cn [] fns
where
- Just (ty@(DTyp args _ es),_,_,_,_) = Map.lookup cn (funs (abstract pgf))
+ Just (ty@(DTyp args _ es),_,_,_) = Map.lookup cn (funs (abstract pgf))
addArg 0 cn ps fns = [(PApp cn (reverse ps),fns)]
addArg n cn ps fns = concat [addArg (n-1) cn (arg:ps) fns' | (arg,fns') <- computeConstr fns]
diff --git a/src/runtime/haskell/PGF/SortTop.hs b/src/runtime/haskell/PGF/SortTop.hs
index 5bebd89d6..f3747b805 100644
--- a/src/runtime/haskell/PGF/SortTop.hs
+++ b/src/runtime/haskell/PGF/SortTop.hs
@@ -38,7 +38,7 @@ showInOrder abs fset remset avset =
isArg :: Abstr -> Map.Map CId CId -> Set.Set CId -> CId -> Maybe [CId]
isArg abs mtypes scid cid =
let p = Map.lookup cid $ funs abs
- (ty,_,_,_,_) = fromJust p
+ (ty,_,_,_) = fromJust p
args = arguments ty
setargs = Set.fromList args
cond = Set.null $ Set.difference setargs scid
@@ -51,7 +51,7 @@ typesInterm :: Abstr -> Set.Set CId -> Map.Map CId CId
typesInterm abs fset =
let fs = funs abs
fsetTypes = Set.map (\x ->
- let (DTyp _ c _,_,_,_,_)=fromJust $ Map.lookup x fs
+ let (DTyp _ c _,_,_,_)=fromJust $ Map.lookup x fs
in (x,c)) fset
in Map.fromList $ Set.toList fsetTypes
@@ -67,7 +67,7 @@ doesReturnCat (DTyp _ c _) cat = c == cat
returnCat :: Abstr -> CId -> CId
returnCat abs cid =
let p = Map.lookup cid $ funs abs
- (DTyp _ c _,_,_,_,_) = fromJust p
+ (DTyp _ c _,_,_,_) = fromJust p
in if isNothing p then error $ "not found "++ show cid ++ " in abstract "
else c
diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs
index e582f97af..0818aeb4a 100644
--- a/src/runtime/haskell/PGF/TypeCheck.hs
+++ b/src/runtime/haskell/PGF/TypeCheck.hs
@@ -121,13 +121,13 @@ runTcM abstr f ms s = unTcM f abstr (\x ms s cp b -> let (es,xs) = cp b
lookupCatHyps :: CId -> TcM s [Hypo]
lookupCatHyps cat = TcM (\abstr k h ms -> case Map.lookup cat (cats abstr) of
- Just (hyps,_,_,_) -> k hyps ms
- Nothing -> h (UnknownCat cat))
+ Just (hyps,_,_) -> k hyps ms
+ Nothing -> h (UnknownCat cat))
lookupFunType :: CId -> TcM s Type
lookupFunType fun = TcM (\abstr k h ms -> case Map.lookup fun (funs abstr) of
- Just (ty,_,_,_,_) -> k ty ms
- Nothing -> h (UnknownFun fun))
+ Just (ty,_,_,_) -> k ty ms
+ Nothing -> h (UnknownFun fun))
typeGenerators :: Scope -> CId -> TcM s [(Double,Expr,TType)]
typeGenerators scope cat = fmap normalize (liftM2 (++) x y)
@@ -143,8 +143,8 @@ typeGenerators scope cat = fmap normalize (liftM2 (++) x y)
| cat == cidString = return [(1.0,ELit (LStr "Foo"),TTyp [] (DTyp [] cat []))]
| otherwise = TcM (\abstr k h ms ->
case Map.lookup cat (cats abstr) of
- Just (_,fns,_,_) -> unTcM (mapM helper fns) abstr k h ms
- Nothing -> h (UnknownCat cat))
+ Just (_,fns,_) -> unTcM (mapM helper fns) abstr k h ms
+ Nothing -> h (UnknownCat cat))
helper (p,fn) = do
ty <- lookupFunType fn
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 15:33:49 +0000