diff options
| author | krasimir <krasimir@chalmers.se> | 2009-12-13 18:50:29 +0000 |
|---|---|---|
| committer | krasimir <krasimir@chalmers.se> | 2009-12-13 18:50:29 +0000 |
| commit | f85232947e74ee7ef8c7b0ad2338212e7e68f1be (patch) | |
| tree | 667b886a5e3a4b026a63d4e3597f32497d824761 /src/PGF/Linearize.hs | |
| parent | d88a865faff59c98fc91556ff8700b10ee5f2df8 (diff) | |
reorganize the directories under src, and rescue the JavaScript interpreter from deprecated
Diffstat (limited to 'src/PGF/Linearize.hs')
| -rw-r--r-- | src/PGF/Linearize.hs | 166 |
1 files changed, 0 insertions, 166 deletions
diff --git a/src/PGF/Linearize.hs b/src/PGF/Linearize.hs deleted file mode 100644 index fdd4cecb5..000000000 --- a/src/PGF/Linearize.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# LANGUAGE ParallelListComp #-} -module PGF.Linearize - (linearizes,realize,realizes,linTree, linTreeMark,linearizesMark) where - -import PGF.CId -import PGF.Data -import PGF.Macros -import PGF.Tree - -import Control.Monad -import qualified Data.Map as Map -import Data.List - -import Debug.Trace - --- linearization and computation of concrete PGF Terms - -linearizes :: PGF -> CId -> Expr -> [String] -linearizes pgf lang = realizes . linTree pgf lang - -realize :: Term -> String -realize = concat . take 1 . realizes - -realizes :: Term -> [String] -realizes = map (unwords . untokn) . realizest - -realizest :: Term -> [[Tokn]] -realizest trm = case trm of - R ts -> realizest (ts !! 0) - S ss -> map concat $ combinations $ map realizest ss - K t -> [[t]] - W s t -> [[KS (s ++ r)] | [KS r] <- realizest t] - FV ts -> concatMap realizest ts - TM s -> [[KS s]] - _ -> [[KS $ "REALIZE_ERROR " ++ show trm]] ---- debug - -untokn :: [Tokn] -> [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 - [] -> [] - where - sel d vs w = case [v | Alt v cs <- vs, any (\c -> isPrefixOf c w) cs] of - v:_ -> v - _ -> d - --- Lifts all variants to the top level (except those in macros). -liftVariants :: Term -> [Term] -liftVariants = f - where - f (R ts) = liftM R $ mapM f ts - f (P t1 t2) = liftM2 P (f t1) (f t2) - f (S ts) = liftM S $ mapM f ts - f (FV ts) = ts >>= f - f (W s t) = liftM (W s) $ f t - f t = return t - -linTree :: PGF -> CId -> Expr -> Term -linTree pgf lang e = lin (expr2tree e) Nothing - where - cnc = lookMap (error "no lang") lang (concretes pgf) - - lin (Abs xs e ) mty = case lin e Nothing of - R ts -> R $ ts ++ (Data.List.map (kks . showCId . snd) xs) - TM s -> R $ (TM s) : (Data.List.map (kks . showCId . snd) xs) - lin (Fun fun es) mty = case Map.lookup fun (funs (abstract pgf)) of - Just (DTyp hyps _ _,_,_) -> let argVariants = sequence [liftVariants (lin e (Just ty)) | e <- es | (_,_,ty) <- hyps] - in variants [compute pgf lang args $ lookMap tm0 fun (lins cnc) | args <- argVariants] - Nothing -> tm0 - lin (Lit (LStr s)) mty = R [kks (show s)] -- quoted - lin (Lit (LInt i)) mty = R [kks (show i)] - lin (Lit (LFlt d)) mty = R [kks (show d)] - lin (Var x) mty = case mty of - Just (DTyp _ cat _) -> compute pgf lang [K (KS (showCId x))] (lookMap tm0 cat (lindefs cnc)) - Nothing -> TM (showCId x) - lin (Meta i) mty = case mty of - Just (DTyp _ cat _) -> compute pgf lang [K (KS (show i))] (lookMap tm0 cat (lindefs cnc)) - Nothing -> TM (show i) - -variants :: [Term] -> Term -variants ts = case ts of - [t] -> t - _ -> FV ts - -unvariants :: Term -> [Term] -unvariants t = case t of - FV ts -> ts - _ -> [t] - -compute :: PGF -> CId -> [Term] -> Term -> Term -compute pgf lang args = comp where - comp trm = case trm of - P r p -> proj (comp r) (comp p) - W s t -> W s (comp t) - R ts -> R $ map comp ts - V i -> idx args i -- already computed - F c -> comp $ look c -- not computed (if contains argvar) - FV ts -> FV $ map comp ts - S ts -> S $ filter (/= S []) $ map comp ts - _ -> trm - - look = lookOper pgf lang - - idx xs i = if i > length xs - 1 - then trace - ("too large " ++ show i ++ " for\n" ++ unlines (map show xs) ++ "\n") tm0 - else xs !! i - - proj r p = case (r,p) of - (_, FV ts) -> FV $ map (proj r) ts - (FV ts, _ ) -> FV $ map (\t -> proj t p) ts - (W s t, _) -> kks (s ++ getString (proj t p)) - _ -> comp $ getField r (getIndex p) - - getString t = case t of - K (KS s) -> s - _ -> error ("ERROR in grammar compiler: string from "++ show t) "ERR" - - getIndex t = case t of - C i -> i - TM _ -> 0 -- default value for parameter - _ -> trace ("ERROR in grammar compiler: index from " ++ show t) 666 - - getField t i = case t of - R rs -> idx rs i - TM s -> TM s - _ -> error ("ERROR in grammar compiler: field from " ++ show t) t - ---------- --- markup with tree positions - -linearizesMark :: PGF -> CId -> Expr -> [String] -linearizesMark pgf lang = realizes . linTreeMark pgf lang - -linTreeMark :: PGF -> CId -> Expr -> Term -linTreeMark pgf lang = lin [] . expr2tree - where - lin p (Abs xs e ) = case lin p e of - R ts -> R $ ts ++ (Data.List.map (kks . showCId . snd) xs) - TM s -> R $ (TM s) : (Data.List.map (kks . showCId . snd) xs) - lin p (Fun fun es) = - let argVariants = - mapM (\ (i,e) -> liftVariants $ lin (sub p i) e) (zip [0..] es) - in variants [mark (fun,p) $ compute pgf lang args $ look fun | - args <- argVariants] - lin p (Lit (LStr s)) = mark p $ R [kks (show s)] -- quoted - lin p (Lit (LInt i)) = mark p $ R [kks (show i)] - lin p (Lit (LFlt d)) = mark p $ R [kks (show d)] - lin p (Var x) = mark p $ TM (showCId x) - lin p (Meta i) = mark p $ TM (show i) - - look = lookLin pgf lang - - mark :: Show a => a -> Term -> Term - mark p t = case t of - R ts -> R $ map (mark p) ts - FV ts -> R $ map (mark p) ts - S ts -> S $ bracket p ts - K s -> S $ bracket p [t] - W s (R ts) -> R [mark p $ kks (s ++ u) | K (KS u) <- ts] - _ -> t - -- otherwise in normal form - - bracket p ts = [kks ("("++show p)] ++ ts ++ [kks ")"] - sub p i = p ++ [i] |
