1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
|
module Profile (postParse) where
import Trees
import ErrM
import Monad
import List (nub)
-- restoring parse trees for discontinuous constituents, bindings, etc. AR 25/1/2001
-- revised 8/4/2002 for the new profile structure
postParse :: CFTree -> Err Exp
postParse tree = do
iterm <- tree2term tree
return $ term2trm iterm
-- an intermediate data structure
data ITerm = ITerm (Atom, BindVs) [ITerm] | IMeta deriving (Eq,Show)
type BindVs = [[Ident]]
-- the job is done in two passes:
-- (1) tree2term: restore constituent order from Profile
-- (2) term2trm: restore Bindings from Binds
tree2term :: CFTree -> Err ITerm
tree2term (CFTree (cff@(CFFun (fun,pro)), trees)) = case fun of
AM -> return IMeta
_ -> do
args <- mapM mkArg pro
binds <- mapM mkBinds pro
return $ ITerm (fun, binds) args
where
mkArg (_,arg) = case arg of
[x] -> do -- one occurrence
trx <- trees !? x
tree2term trx
[] -> return IMeta -- suppression
_ -> do -- reduplication
trees' <- mapM (trees !?) arg
xs1 <- mapM tree2term trees'
xs2 <- checkArity xs1
unif xs2
checkArity xs = if length (nub [length xx | ITerm _ xx <- xs']) > 1
then Bad "arity error"
else return xs'
where xs' = [t | t@(ITerm _ _) <- xs]
unif xs = case [t | t@(ITerm _ _) <- xs] of
[] -> return $ IMeta
(ITerm fp@(f,_) xx : ts) -> do
let hs = [h | ITerm (h,_) _ <- ts, h /= f]
testErr (null hs) -- if fails, hs must be nonempty
("unification expects " ++ prt f ++ " but found " ++ prt (head hs))
xx' <- mapM unifArg [0 .. length xx - 1]
return $ ITerm fp xx'
where
unifArg i = unif [zz !! i | ITerm _ zz <- xs]
mkBinds (xss,_) = mapM mkBind xss
mkBind xs = do
ts <- mapM (trees !?) xs
let vs = [x | CFTree (CFFun (AV x,_),[]) <- ts]
testErr (length ts == length vs) "non-variable in bound position"
case vs of
[x] -> return x
[] -> return $ Ident "h_" ---- uBoundVar
y:ys -> do
testErr (all (==y) ys) ("fail to unify bindings of " ++ prt y)
return y
term2trm :: ITerm -> Exp
term2trm IMeta = EAtom AM
term2trm (ITerm (fun, binds) terms) =
let bterms = zip binds terms
in mkAppAtom fun [mkAbsR xs (term2trm t) | (xs,t) <- bterms]
--- these are deprecated
where
mkAbsR c e = foldr EAbs e c
mkAppAtom a = mkApp (EAtom a)
mkApp = foldl EApp
-- !! with the error monad
(!?) :: [a] -> Int -> Err a
xs !? i = foldr (const . return) (Bad "too few elements in list") $ drop i xs
testErr :: Bool -> String -> Err ()
testErr cond msg = if cond then return () else Bad msg
|
