summaryrefslogtreecommitdiff
path: root/src/PGF/Linearize.hs
diff options
context:
space:
mode:
authorkrasimir <krasimir@chalmers.se>2009-12-13 18:50:29 +0000
committerkrasimir <krasimir@chalmers.se>2009-12-13 18:50:29 +0000
commitf85232947e74ee7ef8c7b0ad2338212e7e68f1be (patch)
tree667b886a5e3a4b026a63d4e3597f32497d824761 /src/PGF/Linearize.hs
parentd88a865faff59c98fc91556ff8700b10ee5f2df8 (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.hs166
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]