removed src for 2.9

6 files changed, 0 insertions, 952 deletions

diff --git a/src/GF/Formalism/CFG.hs b/src/GF/Formalism/CFG.hs
deleted file mode 100644
index c38adb4e2..000000000
--- a/src/GF/Formalism/CFG.hs
+++ /dev/null
@@ -1,50 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Maintainer  : PL
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/11 13:52:49 $ 
--- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
---
--- CFG formalism
------------------------------------------------------------------------------
-
-module GF.Formalism.CFG where
-
-import GF.Formalism.Utilities
-import GF.Infra.Print
-import GF.Data.Assoc (accumAssoc)
-import GF.Data.SortedList (groupPairs)
-import GF.Data.Utilities (mapSnd)
-
-------------------------------------------------------------
--- type definitions
-
-type CFGrammar  c n t = [CFRule c n t]
-data CFRule     c n t = CFRule c [Symbol c t] n
-			deriving (Eq, Ord, Show)
-
-type CFChart    c n t = CFGrammar (Edge c) n t
-
-
-------------------------------------------------------------
--- building syntax charts from grammars
-
-grammar2chart :: (Ord n, Ord e) => CFGrammar e n t -> SyntaxChart n e
-grammar2chart cfchart = accumAssoc groupSyntaxNodes $
-			[ (lhs, SNode name (filterCats rhs)) |
-				     CFRule lhs rhs name <- cfchart ]
-
-
-----------------------------------------------------------------------
--- pretty-printing
-
-instance (Print n, Print c, Print t) => Print (CFRule c n t) where
-    prt (CFRule cat rhs name) = prt name ++ " : " ++ prt cat ++ 
-				( if null rhs then "" 
-				  else " --> " ++ prtSep " " rhs )
-    prtList = prtSep "\n"
-
-
diff --git a/src/GF/Formalism/FCFG.hs b/src/GF/Formalism/FCFG.hs
deleted file mode 100644
index 5f9656658..000000000
--- a/src/GF/Formalism/FCFG.hs
+++ /dev/null
@@ -1,106 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Maintainer  : Krasimir Angelov
--- Stability   : (stable)
--- Portability : (portable)
---
--- Definitions of fast multiple context-free grammars
------------------------------------------------------------------------------
-
-module GF.Formalism.FCFG
-         ( 
-         -- * Token
-           FToken
-
-         -- * Category
-         , FPath
-         , FCat
-
-         , fcatString, fcatInt, fcatFloat, fcatVar
-
-         -- * Symbol
-         , FIndex
-         , FSymbol(..)
-
-         -- * Name
-         , FName
-         , isCoercionF
-
-         -- * Grammar
-         , FPointPos
-         , FGrammar
-         , FRule(..)
-         ) where
-
-import Control.Monad (liftM)
-import Data.List (groupBy)
-import Data.Array
-import qualified Data.Map as Map
-
-import GF.Formalism.Utilities
-import qualified GF.GFCC.CId as AbsGFCC
-import GF.Infra.PrintClass
-
-
-------------------------------------------------------------
--- Token
-type FToken    = String
-
-
-------------------------------------------------------------
--- Category
-type FPath     = [FIndex]
-type FCat      = Int
-
-fcatString, fcatInt, fcatFloat, fcatVar :: Int
-fcatString = (-1)
-fcatInt    = (-2)
-fcatFloat  = (-3)
-fcatVar    = (-4)
-
-
-------------------------------------------------------------
--- Symbol
-type FIndex    = Int
-data FSymbol
-  = FSymCat {-# UNPACK #-} !FCat {-# UNPACK #-} !FIndex {-# UNPACK #-} !Int 
-  | FSymTok FToken
-
-
-------------------------------------------------------------
--- Name
-type FName     = NameProfile AbsGFCC.CId
-
-isCoercionF :: FName -> Bool
-isCoercionF (Name fun [Unify [0]]) = fun == AbsGFCC.CId "_"
-isCoercionF _ = False
-
-
-------------------------------------------------------------
--- Grammar
-
-type FPointPos = Int
-type FGrammar  = ([FRule], Map.Map AbsGFCC.CId [FCat])
-data FRule     = FRule FName [FCat] FCat (Array FIndex (Array FPointPos FSymbol))
-
-------------------------------------------------------------
--- pretty-printing
-
-instance Print AbsGFCC.CId where
-  prt (AbsGFCC.CId s) = s
-
-instance Print FSymbol where
-    prt (FSymCat c l n) = "($" ++ prt n ++ "!" ++ prt l ++ ")"
-    prt (FSymTok t)     = simpleShow (prt t)
-      where simpleShow str = "\"" ++ concatMap mkEsc str ++ "\""
-            mkEsc '\\' = "\\\\"
-            mkEsc '\"' = "\\\""
-            mkEsc '\n' = "\\n"
-            mkEsc '\t' = "\\t"
-            mkEsc chr  = [chr]
-    prtList = prtSep " "
-
-instance Print FRule where
-    prt (FRule name args res lins) = prt name ++ " : " ++ (if null args then "" else prtSep " " args ++ " -> ") ++ prt res ++
-                                     " =\n   [" ++ prtSep "\n    " ["("++prtSep " " [prt sym | (_,sym) <- assocs syms]++")" | (_,syms) <- assocs lins]++"]"
-    prtList = prtSep "\n"
diff --git a/src/GF/Formalism/GCFG.hs b/src/GF/Formalism/GCFG.hs
deleted file mode 100644
index 5242081c7..000000000
--- a/src/GF/Formalism/GCFG.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Maintainer  : PL
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/05/09 09:28:44 $ 
--- > CVS $Author: peb $
--- > CVS $Revision: 1.3 $
---
--- Basic GCFG formalism (derived from Pollard 1984)
------------------------------------------------------------------------------
-
-module GF.Formalism.GCFG where
-
-import GF.Formalism.Utilities (SyntaxChart)
-import GF.Data.Assoc (assocMap, accumAssoc)
-import GF.Data.SortedList (nubsort, groupPairs)
-import GF.Infra.PrintClass
-
-----------------------------------------------------------------------
-
-type Grammar c n l t  = [Rule c n l t]
-data Rule    c n l t  = Rule (Abstract c n) (Concrete l t)
-			deriving (Eq, Ord, Show)
-
-data Abstract cat name = Abs cat [cat] name 
-			 deriving (Eq, Ord, Show)
-data Concrete lin term = Cnc lin [lin] term 
-			 deriving (Eq, Ord, Show)
-
-----------------------------------------------------------------------
-
-instance (Print c, Print n, Print l, Print t) => Print (Rule n c l t) where
-    prt (Rule abs cnc) = prt abs ++ " := " ++ prt cnc 
-    prtList = prtSep "\n"
-
-instance (Print c, Print n) => Print (Abstract c n) where
-    prt (Abs cat args name) = prt name ++ ". " ++ prt cat ++ 
-			      ( if null args then ""
-				else " --> " ++ prtSep " " args )
-
-instance (Print l, Print t) => Print (Concrete l t) where
-    prt (Cnc lcat args term) = prt term 
-			       ++ " : " ++ prt lcat ++ 
-			       ( if null args then ""
-			         else " / " ++ prtSep " " args)
diff --git a/src/GF/Formalism/MCFG.hs b/src/GF/Formalism/MCFG.hs
deleted file mode 100644
index e6aa965e7..000000000
--- a/src/GF/Formalism/MCFG.hs
+++ /dev/null
@@ -1,58 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Maintainer  : PL
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/05/09 09:28:45 $ 
--- > CVS $Author: peb $
--- > CVS $Revision: 1.2 $
---
--- Definitions of multiple context-free grammars
------------------------------------------------------------------------------
-
-module GF.Formalism.MCFG where
-
-import Control.Monad (liftM)
-import Data.List (groupBy)
-
-import GF.Formalism.Utilities
-import GF.Formalism.GCFG
-
-import GF.Infra.PrintClass
-
-
-------------------------------------------------------------
--- grammar types
-
--- | the lables in the linearization record should be in the same
--- order as specified by the linearization type @[lbl]@
-type MCFGrammar cat name lbl tok = Grammar cat name [lbl] [Lin cat lbl tok]
-type MCFRule    cat name lbl tok = Rule    cat name [lbl] [Lin cat lbl tok]
-
--- | variants are encoded as several linearizations with the same label
-data Lin        cat      lbl tok = Lin lbl [Symbol (cat, lbl, Int) tok]
-				   deriving (Eq, Ord, Show)
-
-instantiateArgs :: [cat] -> Lin cat' lbl tok -> Lin cat lbl tok
-instantiateArgs args (Lin lbl lin) = Lin lbl (map instSym lin)
-    where instSym = mapSymbol instCat id
-	  instCat (_, lbl, nr) = (args !! nr, lbl, nr)
-
-expandVariants :: Eq lbl => MCFRule cat name lbl tok -> [MCFRule cat name lbl tok]
-expandVariants (Rule abs (Cnc typ typs lins)) = liftM (Rule abs . Cnc typ typs) $
-						expandLins lins
-    where expandLins = sequence . groupBy eqLbl 
-	  eqLbl (Lin l1 _) (Lin l2 _) = l1 == l2
-
-
-------------------------------------------------------------
--- pretty-printing
-
-instance (Print c, Print l, Print t) => Print (Lin c l t) where
-    prt (Lin lbl lin) = prt lbl ++ " = " ++ prtSep " " (map (symbol prArg (show.prt)) lin)
-	where prArg (cat, lbl, nr) = prt cat ++ "@" ++ prt nr ++ prt lbl
-    prtList = prtBefore "\n\t"
-
-
-
diff --git a/src/GF/Formalism/SimpleGFC.hs b/src/GF/Formalism/SimpleGFC.hs
deleted file mode 100644
index ea1f9dc12..000000000
--- a/src/GF/Formalism/SimpleGFC.hs
+++ /dev/null
@@ -1,268 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Maintainer  : PL
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/08/11 14:11:46 $ 
--- > CVS $Author: peb $
--- > CVS $Revision: 1.7 $
---
--- Simplistic GFC format
------------------------------------------------------------------------------
-
-module GF.Formalism.SimpleGFC where
-
-import Control.Monad (liftM)
-import qualified GF.Canon.AbsGFC as AbsGFC
-import qualified GF.Infra.Ident as Ident
-import GF.Formalism.GCFG
-import GF.Infra.Print
-
-----------------------------------------------------------------------
--- * basic (leaf) types
-
-type Constr = AbsGFC.CIdent
-type Var    = Ident.Ident
-type Label  = AbsGFC.Label
-
-anyVar :: Var
-anyVar = Ident.wildIdent
-
-----------------------------------------------------------------------
--- * simple GFC
-
-type SimpleGrammar c n t = Grammar  (Decl c) n (LinType c t) (Maybe (Term c t))
-type SimpleRule    c n t = Rule     (Decl c) n (LinType c t) (Maybe (Term c t))
-
--- ** dependent type declarations
-
--- 'Decl x c ts' == x is of type (c applied to ts)
--- data Decl c = Decl Var c [TTerm]
---  	      deriving (Eq, Ord, Show)
-
--- | 'Decl x t' == 'x' is of type 't'
-data Decl    c = Decl Var (AbsType c) deriving (Eq, Ord, Show)
--- | '[t1..tn] ::--> t' == 't1 -> ... -> tn -> t'
-data AbsType c = [FOType c] ::--> FOType c deriving (Eq, Ord, Show)
--- | 'c ::@ [t1..tn]' == '(c t1 ... tn)'
-data FOType  c = c ::@ [TTerm] deriving (Eq, Ord, Show)
-
--- including second order functions:
--- (A -> B)                ==>  Decl _ ([A ::@ []] ::--> (B ::@ []))
--- (x : A -> B -> C)       ==>  Decl x ([A ::@ [], B ::@ []] ::--> (C ::@ []))
--- (y : A t x -> B (t x))  ==>  Decl y ([A ::@ [t:@[],TVar x]] ::--> (B ::@ [t:@[TVar x]]))
-
-
-data TTerm  = Constr :@ [TTerm]
-	    | TVar Var
-	      deriving (Eq, Ord, Show)
-
-decl2cat :: Decl c -> c
-decl2cat (Decl _ (_ ::--> (cat ::@ _))) = cat
-
-varsInTTerm :: TTerm -> [Var]
-varsInTTerm tterm = vars tterm []
-    where vars (TVar x)  = (x:)
-	  vars (_ :@ ts) = foldr (.) id $ map vars ts
-
-tterm2term :: TTerm -> Term c t
-tterm2term (con :@ terms) = con :^ map tterm2term terms
--- tterm2term (TVar x) = Var x
-tterm2term term = error $ "tterm2term: illegal term"
-
-term2tterm :: Term c t -> TTerm
-term2tterm (con :^ terms) = con :@ map term2tterm terms
--- term2tterm (Var x) = TVar x
-term2tterm term = error $ "term2tterm: illegal term"
-
--- ** linearization types and terms
-
-data LinType c t = RecT [(Label, LinType c t)]
-		 | TblT [Term c t] (LinType c t)
-		 | ConT [Term c t]
-		 | StrT
-		   deriving (Eq, Ord, Show)
-
-isBaseType :: LinType c t -> Bool
-isBaseType (ConT _) = True
-isBaseType (StrT)   = True
-isBaseType _        = False
-
-data Term c t
-    = Arg Int c (Path c t)       -- ^ argument variable, the 'Path' is a path 
-			         -- pointing into the term 
-    | Constr :^ [Term c t]       -- ^ constructor
-    | Rec [(Label, Term c t)]    -- ^ record
-    | Term c t :. Label          -- ^ record projection
-    | Tbl [(Term c t, Term c t)] -- ^ table of patterns\/terms
-    | Term c t :! Term c t       -- ^ table selection
-    | Variants [Term c t]        -- ^ variants
-    | Term c t :++ Term c t      -- ^ concatenation
-    | Token t   -- ^ single token
-    | Empty     -- ^ empty string
-    ---- | Wildcard  -- ^ wildcard pattern variable
-    ---- | Var Var   -- ^ bound pattern variable
-
-     -- Res CIdent        -- ^ resource identifier
-     -- Int Integer       -- ^ integer
-	    deriving (Eq, Ord, Show)
-
--- ** calculations on terms
-
-(+.) :: Term c t -> Label -> Term c t
-Variants terms +. lbl = variants $ map (+. lbl) terms 
-Rec record +. lbl = maybe err id $ lookup lbl record
-    where err = error $ "(+.): label not in record"
-Arg arg cat path +. lbl = Arg arg cat (path ++. lbl)
-term +. lbl = term :. lbl
-
-(+!) :: (Eq c, Eq t) => Term c t -> Term c t -> Term c t
-Variants terms +! pat = variants $ map (+! pat) terms 
-term +! Variants pats = variants $ map (term +!) pats 
-term +! arg@(Arg _ _ _) = term :! arg
-Arg arg cat path +! pat = Arg arg cat (path ++! pat)
--- cannot handle tables with pattern variales or wildcards (yet):
-term@(Tbl table) +! pat = maybe (term :! pat) id $ lookup pat table
-term +! pat = term :! pat
-
-{- does not work correctly:
-lookupTbl term [] _ = term
-lookupTbl _ ((Wildcard, term) : _) _ = term
-lookupTbl _ ((Var x, term) : _) pat = subst x pat term
-lookupTbl _ ((pat', term) : _) pat | pat == pat' = term
-lookupTbl term (_ : tbl) pat = lookupTbl term tbl pat
-
-subst x a (Arg n c (Path path)) = Arg n c (Path (map substP path))
-    where substP (Right (Var y)) | x==y = Right a
-	  substP p = p
-subst x a (con :^ ts) = con :^ map (subst x a) ts
-subst x a (Rec rec) = Rec [ (l, subst x a t) | (l, t) <- rec ]
-subst x a (t :. l) = subst x a t +. l
-subst x a (Tbl tbl) = Tbl [ (subst x a p, subst x a t) | (p, t) <- tbl ]
-subst x a (t :! s) = subst x a t +! subst x a s
-subst x a (Variants ts) = variants $ map (subst x a) ts
-subst x a (t1 :++ t2) = subst x a t1 ?++ subst x a t2
-subst x a (Var y) | x==y = a
-subst x a t = t
--}
-
-(?++) :: Term c t -> Term c t -> Term c t
-Variants terms ?++ term  = variants $ map (?++ term) terms
-term  ?++ Variants terms = variants $ map (term ?++) terms
-Empty ?++ term  = term
-term  ?++ Empty = term
-term1 ?++ term2 = term1 :++ term2
-
-variants :: [Term c t] -> Term c t
-variants terms0 = case concatMap flatten terms0 of
-		    [term] -> term
-		    terms  -> Variants terms
-    where flatten (Variants ts) = ts
-	  flatten  t      = [t]
-
--- ** enumerations
-
-enumerateTerms :: (Eq c, Eq t) => Maybe (Term c t) -> LinType c t -> [Term c t]
-enumerateTerms arg (StrT) = maybe err return arg
-    where err = error "enumeratePatterns: parameter type should not be string"
-enumerateTerms arg (ConT terms) = terms
-enumerateTerms arg (RecT rtype) 
-    = liftM Rec $ mapM enumAssign rtype
-    where enumAssign (lbl, ctype) = liftM ((,) lbl) $ enumerateTerms arg ctype
-enumerateTerms arg (TblT terms ctype)
-    = liftM Tbl $ mapM enumCase terms
-    where enumCase pat = liftM ((,) pat) $ enumerateTerms (fmap (+! pat) arg) ctype
-
-enumeratePatterns :: (Eq c, Eq t) => LinType c t -> [Term c t]
-enumeratePatterns t = enumerateTerms Nothing t
-
-----------------------------------------------------------------------
--- * paths of record projections and table selections
-
--- | Note that the list of labels/selection terms is /reversed/
-newtype Path c t = Path [Either Label (Term c t)] deriving (Eq, Ord, Show)
-
-emptyPath :: Path c t
-emptyPath = Path []
-
--- ** calculations on paths
-
-(++.) :: Path c t -> Label -> Path c t 
-Path path ++. lbl = Path (Left lbl : path)
-
-(++!) :: Path c t -> Term c t -> Path c t 
-Path path ++! sel = Path (Right sel : path)
-
-lintypeFollowPath :: (Print c,Print t) => Path c t -> LinType c t -> LinType c t
-lintypeFollowPath (Path path0) ctype0 = follow (reverse path0) ctype0
-    where follow [] ctype = ctype
-	  follow (Right pat : path) (TblT _ ctype) = follow path ctype
-	  follow (Left  lbl : path) (RecT rec)
-	      = maybe err (follow path) $ lookup lbl rec
-	      where err = error $ "lintypeFollowPath: label not in record type"
-			    ++ "\nOriginal Path:  " ++ prt (Path path0)
-			    ++ "\nOriginal CType: " ++ prt ctype0
-                            ++ "\nCurrent Label:  " ++ prt lbl
-                            ++ "\nCurrent RType:  " ++ prt (RecT rec)
-                          --- by AR for debugging 23/11/2005
-
-termFollowPath :: (Eq c, Eq t) => Path c t -> Term c t -> Term c t
-termFollowPath (Path path0) = follow (reverse path0)
-    where follow [] term = term
-	  follow (Right pat : path) term = follow path (term +! pat)
-	  follow (Left  lbl : path) term = follow path (term +. lbl)
-
-lintype2paths :: (Eq c, Eq t) => Path c t -> LinType c t -> [Path c t]
-lintype2paths path (ConT _)     = []
-lintype2paths path (StrT)       = [ path ]
-lintype2paths path (RecT rec)   = concat [ lintype2paths (path ++. lbl) ctype |
-					   (lbl, ctype) <- rec ]
-lintype2paths path (TblT pts vt)= concat [ lintype2paths (path ++! pat) vt |
-					   pat <- pts ]
-
-----------------------------------------------------------------------
--- * pretty-printing
-
-instance Print c => Print (Decl c) where
-    prt (Decl var typ) | var == anyVar = prt typ
-		       | otherwise     = "(?" ++ prt var ++ ":" ++ prt typ ++ ")"
-
-instance Print c => Print (AbsType c) where
-    prt ([]   ::--> typ) = prt typ
-    prt (args ::--> typ) = "(" ++ prtAfter "->" args ++ prt typ ++ ")"
-
-instance Print c => Print (FOType c) where
-    prt (cat ::@ args) = prt cat ++ prtBefore " " args
-
-instance Print TTerm where
-    prt (con :@ args)
-	| null args = prt con
-	| otherwise = "(" ++ prt con ++ prtBefore " " args ++ ")"
-    prt (TVar var)  = "?" ++ prt var
-
-instance (Print c, Print t) => Print (LinType c t) where
-    prt (RecT rec) = "{" ++ prtPairList ":" "; " rec ++ "}"
-    prt (TblT ts t2) = "([" ++ prtSep "|" ts ++ "] => " ++ prt t2 ++ ")"
-    prt (ConT ts) = "[" ++ prtSep "|" ts ++ "]"
-    prt (StrT) = "Str"
-
-instance (Print c, Print t) => Print (Term c t) where
-    prt (Arg n c p) = prt c ++ prt n ++ prt p
-    prt (c :^ [])  = prt c 
-    prt (c :^ ts)  = "(" ++ prt c ++ prtBefore " " ts ++ ")"
-    prt (Rec rec)   = "{" ++ prtPairList "=" "; " rec ++ "}"
-    prt (Tbl tbl)   = "[" ++ prtPairList "=>" "; " tbl ++ "]"
-    prt (Variants ts)  = "{| " ++ prtSep " | " ts ++ " |}"
-    prt (t1 :++ t2) = prt t1 ++ "++" ++ prt t2
-    prt (Token t)   = "'" ++ prt t ++ "'"
-    prt (Empty)     = "[]"
-    prt (term :. lbl) = prt term ++ "." ++ prt lbl
-    prt (term :! sel) = prt term ++ "!" ++ prt sel
---    prt (Wildcard)  = "_"
---    prt (Var var) = "?" ++ prt var
-
-instance (Print c, Print t) => Print (Path c t) where
-    prt (Path path) = concatMap prtEither (reverse path)
-	where prtEither (Left  lbl)  = "." ++ prt lbl
-	      prtEither (Right patt) = "!" ++ prt patt
diff --git a/src/GF/Formalism/Utilities.hs b/src/GF/Formalism/Utilities.hs
deleted file mode 100644
index d1826d095..000000000
--- a/src/GF/Formalism/Utilities.hs
+++ /dev/null
@@ -1,423 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Maintainer  : PL
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/05/13 12:40:19 $ 
--- > CVS $Author: peb $
--- > CVS $Revision: 1.6 $
---
--- Basic type declarations and functions for grammar formalisms
------------------------------------------------------------------------------
-
-
-module GF.Formalism.Utilities where
-
-import Control.Monad
-import Data.Array
-import Data.List (groupBy)
-
-import GF.Data.SortedList
-import GF.Data.Assoc
-import GF.Data.Utilities (sameLength, foldMerge, splitBy)
-
-import GF.Infra.PrintClass
-
-------------------------------------------------------------
--- * symbols
-
-data Symbol c t = Cat c | Tok t
-		  deriving (Eq, Ord, Show)
-
-symbol :: (c -> a) -> (t -> a) -> Symbol c t -> a
-symbol fc ft (Cat cat) = fc cat
-symbol fc ft (Tok tok) = ft tok
-
-mapSymbol :: (c -> d) -> (t -> u) -> Symbol c t -> Symbol d u
-mapSymbol fc ft = symbol (Cat . fc) (Tok . ft)
-
-filterCats :: [Symbol c t] -> [c]
-filterCats syms = [ cat | Cat cat <- syms ]
-
-filterToks :: [Symbol c t] -> [t]
-filterToks syms = [ tok | Tok tok <- syms ]
-
-------------------------------------------------------------
--- * edges
-
-data Edge s = Edge Int Int s
-	      deriving (Eq, Ord, Show)
-
-instance Functor Edge where
-    fmap f (Edge i j s) = Edge i j (f s)
-
-
-------------------------------------------------------------
--- * representaions of input tokens
-
-data Input t = MkInput { inputEdges  :: [Edge t],
-			 inputBounds :: (Int, Int),
-			 inputFrom   :: Array Int (Assoc t [Int]),
-			 inputTo     :: Array Int (Assoc t [Int]),
-			 inputToken  :: Assoc t [(Int, Int)]
-		       }
-
-makeInput :: Ord t => [Edge t] -> Input t
-input     :: Ord t =>  [t]     -> Input t
-inputMany :: Ord t => [[t]]    -> Input t
-
-instance Show t => Show (Input t) where
-    show input = "makeInput " ++ show (inputEdges input)
-
-----------
-
-makeInput inEdges  | null inEdges = input []
-		   | otherwise    = MkInput inEdges inBounds inFrom inTo inToken
-    where inBounds = foldr1 minmax [ (i, j) | Edge i j _ <- inEdges ]
-	      where minmax (a, b) (a', b') = (min a a', max b b')
-	  inFrom   = fmap (accumAssoc id) $ accumArray (<++>) [] inBounds $
-		     [ (i, [(tok, j)]) | Edge i j tok <- inEdges ]
-	  inTo     = fmap (accumAssoc id) $ accumArray (<++>) [] inBounds
-		     [ (j, [(tok, i)]) | Edge i j tok <- inEdges ]
-	  inToken  = accumAssoc id [ (tok, (i, j)) | Edge i j tok <- inEdges ]
-
-input toks         = MkInput inEdges inBounds inFrom inTo inToken
-    where inEdges  = zipWith3 Edge [0..] [1..] toks
-	  inBounds = (0, length toks)
-	  inFrom   = listArray inBounds $
-		     [ listAssoc [(tok, [j])] | (tok, j) <- zip toks [1..] ] ++ [ listAssoc [] ]
-	  inTo     = listArray inBounds $
-		     [ listAssoc [] ] ++ [ listAssoc [(tok, [i])] | (tok, i) <- zip toks [0..] ]
-	  inToken  = accumAssoc id [ (tok, (i, j)) | Edge i j tok <- inEdges ]
-
-inputMany toks     = MkInput inEdges inBounds inFrom inTo inToken
-    where inEdges  = [ Edge i j t | (i, j, ts) <- zip3 [0..] [1..] toks, t <- ts ]
-	  inBounds = (0, length toks)
-	  inFrom   = listArray inBounds $
-		     [ listAssoc [ (t, [j]) | t <- nubsort ts ] | (ts, j) <- zip toks [1..] ]
-		     ++ [ listAssoc [] ]
-	  inTo     = listArray inBounds $
-		     [ listAssoc [] ] ++ 
-		     [ listAssoc [ (t, [i]) | t <- nubsort ts ] | (ts, i) <- zip toks [0..] ]
-	  inToken  = accumAssoc id [ (tok, (i, j)) | Edge i j tok <- inEdges ]
-
-
-------------------------------------------------------------
--- * representations of syntactical analyses
-
--- ** charts as finite maps over edges
-
--- | The values of the chart, a list of key-daughters pairs,
--- has unique keys. In essence, it is a map from 'n' to daughters.
--- The daughters should be a set (not necessarily sorted) of rhs's.
-type SyntaxChart n e = Assoc e [SyntaxNode n [e]]
-
-data SyntaxNode n e = SMeta
-                    | SNode n [e]
-                    | SString String
-                    | SInt    Integer
-                    | SFloat  Double
-                    deriving (Eq,Ord)
-
-groupSyntaxNodes :: Ord n => [SyntaxNode n e] -> [SyntaxNode n [e]]
-groupSyntaxNodes []                =  []
-groupSyntaxNodes (SNode n0 es0:xs) = (SNode n0 (es0:ess)) : groupSyntaxNodes xs'
-  where 
-    (ess,xs') = span xs
-
-    span []       = ([],[])
-    span xs@(SNode n es:xs')
-      | n0 == n   = let (ess,xs) = span xs' in (es:ess,xs)
-      | otherwise = ([],xs)
-groupSyntaxNodes (SString s:xs) = (SString s) : groupSyntaxNodes xs
-groupSyntaxNodes (SInt    n:xs) = (SInt    n) : groupSyntaxNodes xs
-groupSyntaxNodes (SFloat  f:xs) = (SFloat  f) : groupSyntaxNodes xs
-
--- better(?) representation of forests:
--- data Forest n = F (SMap n (SList [Forest n])) Bool
--- ==
--- type Forest n = GeneralTrie n (SList [Forest n]) Bool
--- (the Bool == isMeta)
-
--- ** syntax forests
-
-data SyntaxForest n = FMeta 
-		    | FNode n [[SyntaxForest n]]
-                      -- ^ The outer list should be a set (not necessarily sorted)
-		      -- of possible alternatives. Ie. the outer list 
-		      -- is a disjunctive node, and the inner lists 
-		      -- are (conjunctive) concatenative nodes
-		    | FString String
-		    | FInt    Integer
-		    | FFloat  Double
-		      deriving (Eq, Ord, Show)
-
-instance Functor SyntaxForest where
-    fmap f (FNode n forests) = FNode (f n) $ map (map (fmap f)) forests
-    fmap _ (FString s) = FString s
-    fmap _ (FInt    n) = FInt    n
-    fmap _ (FFloat  f) = FFloat  f
-    fmap _ (FMeta)     = FMeta
-
-forestName :: SyntaxForest n -> Maybe n
-forestName (FNode n _) = Just n
-forestName _           = Nothing
-
-unifyManyForests :: (Monad m, Eq n) => [SyntaxForest n] -> m (SyntaxForest n)
-unifyManyForests = foldM unifyForests FMeta
-
--- | two forests can be unified, if either is 'FMeta', or both have the same parent, 
--- and all children can be unified
-unifyForests :: (Monad m, Eq n) => SyntaxForest n -> SyntaxForest n -> m (SyntaxForest n)
-unifyForests FMeta  forest = return forest
-unifyForests forest FMeta  = return forest
-unifyForests (FNode name1 children1) (FNode name2 children2)
-    | name1 == name2 && not (null children) = return $ FNode name1 children
-    where children = [ forests | forests1 <- children1, forests2 <- children2,
-		       sameLength forests1 forests2,
-		       forests <- zipWithM unifyForests forests1 forests2 ]
-unifyForests (FString s1) (FString s2)
-    | s1 == s2  = return $ FString s1
-unifyForests (FInt n1) (FInt n2)
-    | n1 == n2  = return $ FInt n1
-unifyForests (FFloat f1) (FFloat f2)
-    | f1 == f2  = return $ FFloat f1
-unifyForests _ _ = fail "forest unification failure"
-
-{- måste tänka mer på detta:
-compactForests :: Ord n => [SyntaxForest n] -> SList (SyntaxForest n)
-compactForests = map joinForests . groupBy eqNames . sortForests
-    where eqNames f g    = forestName f == forestName g
-	  sortForests    = foldMerge mergeForests [] . map return 
-	  mergeForests [] gs = gs
-	  mergeForests fs [] = fs
-	  mergeForests fs@(f:fs') gs@(g:gs') 
-	      = case forestName f `compare` forestName g of
-		  LT ->     f : mergeForests fs' gs
-		  GT ->     g : mergeForests fs  gs'
-		  EQ -> f : g : mergeForests fs' gs'
-	  joinForests fs = case forestName (head fs) of
-			     Nothing   -> FMeta
-			     Just name -> FNode name $
-					  compactDaughters $
-					  concat [ fss | FNode _ fss <- fs ]
-	  compactDaughters fss = case head fss of
-				   []  -> [[]]
-				   [_] -> map return $ compactForests $ concat fss
-				   _   -> nubsort fss
--}
-
--- ** syntax trees
-
-data SyntaxTree n = TMeta
-                  | TNode n [SyntaxTree n]
-                  | TString  String
-                  | TInt     Integer
-                  | TFloat   Double
-		  deriving (Eq, Ord, Show)
-
-instance Functor SyntaxTree where
-    fmap f (TNode n trees) = TNode (f n) $ map (fmap f) trees
-    fmap _ (TString s)     = TString s
-    fmap _ (TInt    n)     = TInt    n
-    fmap _ (TFloat  f)     = TFloat  f
-    fmap _ (TMeta)         = TMeta 
-
-treeName :: SyntaxTree n -> Maybe n
-treeName (TNode n _) = Just n
-treeName (TMeta)     = Nothing
-
-unifyManyTrees :: (Monad m, Eq n) => [SyntaxTree n] -> m (SyntaxTree n)
-unifyManyTrees = foldM unifyTrees TMeta
-
--- | two trees can be unified, if either is 'TMeta', 
--- or both have the same parent, and their children can be unified
-unifyTrees :: (Monad m, Eq n) => SyntaxTree n -> SyntaxTree n -> m (SyntaxTree n)
-unifyTrees TMeta tree = return tree
-unifyTrees tree TMeta = return tree
-unifyTrees (TNode name1 children1) (TNode name2 children2)
-    | name1 == name2 && sameLength children1 children2 
-	= liftM (TNode name1) $ zipWithM unifyTrees children1 children2 
-unifyTrees (TString s1) (TString s2)
-    | s1 == s2 = return (TString s1)
-unifyTrees (TInt n1) (TInt n2)
-    | n1 == n2 = return (TInt n1)
-unifyTrees (TFloat f1) (TFloat f2)
-    | f1 == f2 = return (TFloat f1)
-unifyTrees _ _ = fail "tree unification failure"
-
--- ** conversions between representations
-
-chart2forests :: (Ord n, Ord e) => 
-		 SyntaxChart n e  -- ^ The complete chart
-	      -> (e -> Bool)      -- ^ When is an edge 'FMeta'?
-	      -> [e]              -- ^ The starting edges
-	      -> SList (SyntaxForest n) -- ^ The result has unique keys, ie. all 'n' are joined together.
-					-- In essence, the result is a map from 'n' to forest daughters
-
--- simplest implementation
-
-chart2forests chart isMeta = concatMap (edge2forests [])
-    where edge2forests edges edge
-              | isMeta edge       = [FMeta]
-              | edge `elem` edges = []
-              | otherwise         = map (item2forest (edge:edges)) $ chart ? edge
-          item2forest edges (SMeta)               = FMeta
-          item2forest edges (SNode name children) = 
-                                    FNode name $ children >>= mapM (edge2forests edges)
-          item2forest edges (SString s)           = FString s
-          item2forest edges (SInt    n)           = FInt    n
-          item2forest edges (SFloat  f)           = FFloat  f
-
-{- -before AR inserted peb's patch 8/7/2007, this was:
-
-chart2forests chart isMeta  = concatMap edge2forests
-    where edge2forests edge = if isMeta edge then [FMeta]
-			      else map item2forest $ chart ? edge
-	  item2forest (SMeta)               = FMeta
-	  item2forest (SNode name children) = FNode name $ children >>= mapM edge2forests
-	  item2forest (SString s)           = FString s
-	  item2forest (SInt    n)           = FInt    n
-	  item2forest (SFloat  f)           = FFloat  f
-	  
--}
-
-{-
--- more intelligent(?) implementation,
--- requiring that charts and forests are sorted maps and sorted sets
-chart2forests chart isMeta = es2fs
-    where e2fs  e  = if isMeta e then [FMeta] else map i2f $ chart ? e
-	  es2fs es = if null metas then fs else FMeta : fs
-	      where (metas, nonMetas) = splitBy isMeta es
-		    fs = map i2f $ unionMap (<++>) $ map (chart ?) nonMetas
-	  i2f (name, children) = FNode name $ 
-				 case head children of
-				   []  -> [[]]
-				   [_] -> map return $ es2fs $ concat children
-				   _   -> children >>= mapM e2fs
--}
-
-
-forest2trees :: SyntaxForest n -> SList (SyntaxTree n)
-forest2trees (FNode n forests) = map (TNode n) $ forests >>= mapM forest2trees
-forest2trees (FString s) = [TString s]
-forest2trees (FInt    n) = [TInt    n]
-forest2trees (FFloat  f) = [TFloat  f]
-forest2trees (FMeta)     = [TMeta]
-
-----------------------------------------------------------------------
--- * profiles
-
--- | Pairing a rule name with a profile
-data NameProfile a = Name a [Profile (SyntaxForest a)]
-		     deriving (Eq, Ord, Show)
-
-name2fun :: NameProfile a -> a
-name2fun (Name fun _) = fun
-
--- | A profile is a simple representation of a function on a number of arguments.
--- We only use lists of profiles
-data Profile a = Unify [Int] -- ^ The Int's are the argument positions.
-			     -- 'Unify []' will become a metavariable,
-			     -- 'Unify [a,b]' means that the arguments are equal,
-	       | Constant a
-		 deriving (Eq, Ord, Show)
-
-instance Functor Profile where
-    fmap f (Constant a) = Constant (f a)
-    fmap f (Unify xs)   = Unify xs
-
--- | a function name where the profile does not contain arguments 
--- (i.e. denoting a constant, not a function)
-constantNameToForest :: NameProfile a -> SyntaxForest a
-constantNameToForest name@(Name fun profile) = FNode fun [map unConstant profile] 
-    where unConstant (Constant a) = a
-	  unConstant (Unify [])   = FMeta
-	  unConstant _ = error $ "constantNameToForest: the profile should not contain arguments"
-
--- | profile application; we need some way of unifying a list of arguments
-applyProfile :: ([b] -> a) -> [Profile a] -> [b] -> [a]
-applyProfile unify profile args = map apply profile
-    where apply (Unify xs)  = unify $ map (args !!) xs
-	  apply (Constant a) = a
-
--- | monadic profile application
-applyProfileM :: Monad m => ([b] -> m a) -> [Profile a] -> [b] -> m [a]
-applyProfileM unify profile args = mapM apply profile
-    where apply (Unify xs)  = unify $ map (args !!) xs
-	  apply (Constant a) = return a
-
--- | profile composition: 
--- 
--- >   applyProfile u z (ps `composeProfiles` qs) args
--- >      ==
--- >   applyProfile u z ps (applyProfile u z qs args)
---
--- compare with function composition
---
--- >   (p . q) arg
--- >      ==
--- >   p (q arg)
---
--- Note that composing an 'Constant' with two or more arguments returns an error
--- (since 'Unify' can only take arguments) -- this might change in the future, if there is a need.
-composeProfiles :: [Profile a] -> [Profile a] -> [Profile a]
-composeProfiles ps qs = map compose ps
-    where compose (Unify [x]) = qs !! x
-	  compose (Unify xs)  = Unify [ y | x <- xs, let Unify ys = qs !! x, y <- ys ]
-	  compose constant    = constant
-
-
-
-------------------------------------------------------------
--- pretty-printing
-
-instance (Print c, Print t) => Print (Symbol c t) where
-    prt = symbol prt (simpleShow . prt)
-	where simpleShow str = "\"" ++ concatMap mkEsc str ++ "\""
-	      mkEsc '\\' = "\\\\"
-	      mkEsc '\"' = "\\\""
-	      mkEsc '\n' = "\\n"
-	      mkEsc '\t' = "\\t"
-	      mkEsc chr  = [chr]
-    prtList = prtSep " "
-
-instance Print t => Print (Input t) where
-    prt input = "input " ++ prt (inputEdges input)
-
-instance (Print s) => Print (Edge s) where
-    prt (Edge i j s) = "[" ++ show i ++ "-" ++ show j ++ ": " ++ prt s ++ "]"
-    prtList = prtSep ""
-
-instance (Print s) => Print (SyntaxTree s) where
-    prt (TNode s trees)
-	| null trees = prt s
-	| otherwise  = "(" ++ prt s ++ prtBefore " " trees ++ ")"
-    prt (TString  s) = show s
-    prt (TInt     n) = show n
-    prt (TFloat   f) = show f
-    prt (TMeta)      = "?"
-    prtList = prtAfter "\n"
-
-instance (Print s) => Print (SyntaxForest s) where
-    prt (FNode s []) = "(" ++ prt s ++ " - ERROR: null forests)"
-    prt (FNode s [[]]) = prt s
-    prt (FNode s [forests]) = "(" ++ prt s ++ prtBefore " " forests ++ ")"
-    prt (FNode s children) = "{" ++ prtSep " | " [ prt s ++ prtBefore " " forests | 
-						   forests <- children ] ++ "}"
-    prt (FString s) = show s
-    prt (FInt    n) = show n
-    prt (FFloat  f) = show f
-    prt (FMeta)     = "?"
-    prtList = prtAfter "\n"
-
-instance Print a => Print (Profile a) where
-    prt (Unify [])   = "?"
-    prt (Unify args) = prtSep "=" args
-    prt (Constant a) = prt a
-
-instance Print a => Print (NameProfile a) where
-    prt (Name fun profile) = prt fun ++ prt profile
-
-