mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-21 18:59:32 -06:00
a partial support for def rules in the C runtime
The def rules are now compiled to byte code by the compiler and then to native code by the JIT compiler in the runtime. Not all constructions are implemented yet. The partial implementation is now in the repository but it is not activated by default since this requires changes in the PGF format. I will enable it only after it is complete.
This commit is contained in:
kr.angelov
@@ -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')
|
||||
|
||||
@@ -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
|
||||
|
||||
47
src/runtime/haskell/PGF/ByteCode.hs
Normal file
47
src/runtime/haskell/PGF/ByteCode.hs
Normal file
@@ -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)
|
||||
@@ -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.
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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) =
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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 ';'
|
||||
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],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 ';'
|
||||
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 =
|
||||
|
||||
@@ -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]
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user