reorganize the directories under src, and rescue the JavaScript interpreter from deprecated

src/runtime/haskell/PGF/Linearize.hs

@@ -0,0 +1,166 @@
+{-# 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]