summaryrefslogtreecommitdiff
path: root/examples/gfcc/compiler/Profile.hs
diff options
context:
space:
mode:
authoraarne <aarne@cs.chalmers.se>2008-06-25 16:54:35 +0000
committeraarne <aarne@cs.chalmers.se>2008-06-25 16:54:35 +0000
commite9e80fc389365e24d4300d7d5390c7d833a96c50 (patch)
treef0b58473adaa670bd8fc52ada419d8cad470ee03 /examples/gfcc/compiler/Profile.hs
parentb96b36f43de3e2f8b58d5f539daa6f6d47f25870 (diff)
changed names of resource-1.3; added a note on homepage on release
Diffstat (limited to 'examples/gfcc/compiler/Profile.hs')
-rw-r--r--examples/gfcc/compiler/Profile.hs90
1 files changed, 0 insertions, 90 deletions
diff --git a/examples/gfcc/compiler/Profile.hs b/examples/gfcc/compiler/Profile.hs
deleted file mode 100644
index 0c549cd67..000000000
--- a/examples/gfcc/compiler/Profile.hs
+++ /dev/null
@@ -1,90 +0,0 @@
-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
-