{-# LANGUAGE MagicHash, BangPatterns, FlexibleContexts #-}
module PGF.Macros where
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint

import PGF.CId
import PGF.Data
import Control.Monad
import qualified Data.Map    as Map
--import qualified Data.Set    as Set
--import qualified Data.IntMap as IntMap
--import qualified Data.IntSet as IntSet
import qualified Data.Array  as Array
--import Data.Maybe
import Data.List
import Data.Array.IArray
import Text.PrettyPrint
import GHC.Prim
import GHC.Base(getTag)
import Data.Char

-- operations for manipulating PGF grammars and objects

mapConcretes :: (Concr -> Concr) -> PGF -> PGF
mapConcretes :: (Concr -> Concr) -> PGF -> PGF
mapConcretes Concr -> Concr
f PGF
pgf = PGF
pgf { concretes :: Map CId Concr
concretes = (Concr -> Concr) -> Map CId Concr -> Map CId Concr
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Concr -> Concr
f (PGF -> Map CId Concr
concretes PGF
pgf) }

lookType :: Abstr -> CId -> Type
lookType :: Abstr -> CId -> Type
lookType Abstr
abs CId
f = 
  case (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> CId
-> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> (Type, Int, Maybe ([Equation], [[Instr]]), Double)
forall i a. Ord i => a -> i -> Map i a -> a
lookMap ([Char] -> (Type, Int, Maybe ([Equation], [[Instr]]), Double)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (Type, Int, Maybe ([Equation], [[Instr]]), Double))
-> [Char] -> (Type, Int, Maybe ([Equation], [[Instr]]), Double)
forall a b. (a -> b) -> a -> b
$ [Char]
"lookType " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CId -> [Char]
forall a. Show a => a -> [Char]
show CId
f) CId
f (Abstr -> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
funs Abstr
abs) of
    (Type
ty,Int
_,Maybe ([Equation], [[Instr]])
_,Double
_) -> Type
ty

isData :: Abstr -> CId -> Bool
isData :: Abstr -> CId -> Bool
isData Abstr
abs CId
f =
  case CId
-> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CId
f (Abstr -> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
funs Abstr
abs) of
    Just (Type
_,Int
_,Maybe ([Equation], [[Instr]])
Nothing,Double
_) -> Bool
True       -- the encoding of data constrs
    Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double)
_                    -> Bool
False

lookValCat :: Abstr -> CId -> CId
lookValCat :: Abstr -> CId -> CId
lookValCat Abstr
abs = Type -> CId
valCat (Type -> CId) -> (CId -> Type) -> CId -> CId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Abstr -> CId -> Type
lookType Abstr
abs

lookStartCat :: PGF -> CId
lookStartCat :: PGF -> CId
lookStartCat PGF
pgf = [Char] -> CId
mkCId ([Char] -> CId) -> [Char] -> CId
forall a b. (a -> b) -> a -> b
$
  case [Maybe Literal] -> Maybe Literal
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe Literal] -> Maybe Literal)
-> [Maybe Literal] -> Maybe Literal
forall a b. (a -> b) -> a -> b
$ (Map CId Literal -> Maybe Literal)
-> [Map CId Literal] -> [Maybe Literal]
forall a b. (a -> b) -> [a] -> [b]
Data.List.map (CId -> Map CId Literal -> Maybe Literal
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ([Char] -> CId
mkCId [Char]
"startcat")) [PGF -> Map CId Literal
gflags PGF
pgf, Abstr -> Map CId Literal
aflags (PGF -> Abstr
abstract PGF
pgf)] of
    Just (LStr [Char]
s) -> [Char]
s
    Maybe Literal
_             -> [Char]
"S"

lookGlobalFlag :: PGF -> CId -> Maybe Literal
lookGlobalFlag :: PGF -> CId -> Maybe Literal
lookGlobalFlag PGF
pgf CId
f = CId -> Map CId Literal -> Maybe Literal
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CId
f (PGF -> Map CId Literal
gflags PGF
pgf)

lookAbsFlag :: PGF -> CId -> Maybe Literal
lookAbsFlag :: PGF -> CId -> Maybe Literal
lookAbsFlag PGF
pgf CId
f = CId -> Map CId Literal -> Maybe Literal
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CId
f (Abstr -> Map CId Literal
aflags (PGF -> Abstr
abstract PGF
pgf))

lookConcr :: PGF -> Language -> Concr
lookConcr :: PGF -> CId -> Concr
lookConcr PGF
pgf CId
cnc = 
    Concr -> CId -> Map CId Concr -> Concr
forall i a. Ord i => a -> i -> Map i a -> a
lookMap ([Char] -> Concr
forall a. HasCallStack => [Char] -> a
error ([Char] -> Concr) -> [Char] -> Concr
forall a b. (a -> b) -> a -> b
$ [Char]
"Missing concrete syntax: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CId -> [Char]
showCId CId
cnc) CId
cnc (Map CId Concr -> Concr) -> Map CId Concr -> Concr
forall a b. (a -> b) -> a -> b
$ PGF -> Map CId Concr
concretes PGF
pgf

-- use if name fails, use abstract + name; so e.g. "Eng" becomes "DemoEng" 
lookConcrComplete :: PGF -> CId -> Concr
lookConcrComplete :: PGF -> CId -> Concr
lookConcrComplete PGF
pgf CId
cnc = 
  case CId -> Map CId Concr -> Maybe Concr
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CId
cnc (PGF -> Map CId Concr
concretes PGF
pgf) of
    Just Concr
c -> Concr
c
    Maybe Concr
_ -> PGF -> CId -> Concr
lookConcr PGF
pgf ([Char] -> CId
mkCId (CId -> [Char]
showCId (PGF -> CId
absname PGF
pgf) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CId -> [Char]
showCId CId
cnc))

lookConcrFlag :: PGF -> CId -> CId -> Maybe Literal
lookConcrFlag :: PGF -> CId -> CId -> Maybe Literal
lookConcrFlag PGF
pgf CId
lang CId
f = CId -> Map CId Literal -> Maybe Literal
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CId
f (Map CId Literal -> Maybe Literal)
-> Map CId Literal -> Maybe Literal
forall a b. (a -> b) -> a -> b
$ Concr -> Map CId Literal
cflags (Concr -> Map CId Literal) -> Concr -> Map CId Literal
forall a b. (a -> b) -> a -> b
$ PGF -> CId -> Concr
lookConcr PGF
pgf CId
lang

functionsToCat :: PGF -> CId -> [(CId,Type)]
functionsToCat :: PGF -> CId -> [(CId, Type)]
functionsToCat PGF
pgf CId
cat =
  [(CId
f,Type
ty) | (Double
_,CId
f) <- [(Double, CId)]
fs, Just (Type
ty,Int
_,Maybe ([Equation], [[Instr]])
_,Double
_) <- [CId
-> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CId
f (Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
 -> Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double))
-> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> Maybe (Type, Int, Maybe ([Equation], [[Instr]]), Double)
forall a b. (a -> b) -> a -> b
$ Abstr -> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
funs (Abstr
 -> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double))
-> Abstr
-> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
forall a b. (a -> b) -> a -> b
$ PGF -> Abstr
abstract PGF
pgf]]
 where 
   ([Hypo]
_,[(Double, CId)]
fs,Double
_) = ([Hypo], [(Double, CId)], Double)
-> CId
-> Map CId ([Hypo], [(Double, CId)], Double)
-> ([Hypo], [(Double, CId)], Double)
forall i a. Ord i => a -> i -> Map i a -> a
lookMap ([],[],Double
0) CId
cat (Map CId ([Hypo], [(Double, CId)], Double)
 -> ([Hypo], [(Double, CId)], Double))
-> Map CId ([Hypo], [(Double, CId)], Double)
-> ([Hypo], [(Double, CId)], Double)
forall a b. (a -> b) -> a -> b
$ Abstr -> Map CId ([Hypo], [(Double, CId)], Double)
cats (Abstr -> Map CId ([Hypo], [(Double, CId)], Double))
-> Abstr -> Map CId ([Hypo], [(Double, CId)], Double)
forall a b. (a -> b) -> a -> b
$ PGF -> Abstr
abstract PGF
pgf

-- | List of functions that lack linearizations in the given language.
missingLins :: PGF -> Language -> [CId]
missingLins :: PGF -> CId -> [CId]
missingLins PGF
pgf CId
lang = [CId
c | CId
c <- [CId]
fs, Bool -> Bool
not (CId -> Bool
hasl CId
c)] where
  fs :: [CId]
fs = Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double) -> [CId]
forall k a. Map k a -> [k]
Map.keys (Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
 -> [CId])
-> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> [CId]
forall a b. (a -> b) -> a -> b
$ Abstr -> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
funs (Abstr
 -> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double))
-> Abstr
-> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
forall a b. (a -> b) -> a -> b
$ PGF -> Abstr
abstract PGF
pgf
  hasl :: CId -> Bool
hasl = PGF -> CId -> CId -> Bool
hasLin PGF
pgf CId
lang

hasLin :: PGF -> Language -> CId -> Bool
hasLin :: PGF -> CId -> CId -> Bool
hasLin PGF
pgf CId
lang CId
f = CId -> Map CId (IntMap (Set Production)) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member CId
f (Map CId (IntMap (Set Production)) -> Bool)
-> Map CId (IntMap (Set Production)) -> Bool
forall a b. (a -> b) -> a -> b
$ Concr -> Map CId (IntMap (Set Production))
lproductions (Concr -> Map CId (IntMap (Set Production)))
-> Concr -> Map CId (IntMap (Set Production))
forall a b. (a -> b) -> a -> b
$ PGF -> CId -> Concr
lookConcr PGF
pgf CId
lang

restrictPGF :: (CId -> Bool) -> PGF -> PGF
restrictPGF :: (CId -> Bool) -> PGF -> PGF
restrictPGF CId -> Bool
cond PGF
pgf = PGF
pgf {
  abstract :: Abstr
abstract = Abstr
abstr {
    funs :: Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
funs = (CId -> (Type, Int, Maybe ([Equation], [[Instr]]), Double) -> Bool)
-> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\CId
c (Type, Int, Maybe ([Equation], [[Instr]]), Double)
_ -> CId -> Bool
cond CId
c) (Abstr -> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
funs Abstr
abstr),
    cats :: Map CId ([Hypo], [(Double, CId)], Double)
cats = (([Hypo], [(Double, CId)], Double)
 -> ([Hypo], [(Double, CId)], Double))
-> Map CId ([Hypo], [(Double, CId)], Double)
-> Map CId ([Hypo], [(Double, CId)], Double)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\([Hypo]
hyps,[(Double, CId)]
fs,Double
p) -> ([Hypo]
hyps,((Double, CId) -> Bool) -> [(Double, CId)] -> [(Double, CId)]
forall a. (a -> Bool) -> [a] -> [a]
filter (CId -> Bool
cond (CId -> Bool) -> ((Double, CId) -> CId) -> (Double, CId) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double, CId) -> CId
forall a b. (a, b) -> b
snd) [(Double, CId)]
fs,Double
p)) (Abstr -> Map CId ([Hypo], [(Double, CId)], Double)
cats Abstr
abstr)
    }
  }  ---- restrict concrs also, might be needed
 where
  abstr :: Abstr
abstr = PGF -> Abstr
abstract PGF
pgf

depth :: Expr -> Int
depth :: Expr -> Int
depth (EAbs BindType
_ CId
_ Expr
t) = Expr -> Int
depth Expr
t
depth (EApp Expr
e1 Expr
e2) = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Expr -> Int
depth Expr
e1) (Expr -> Int
depth Expr
e2) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
depth Expr
_            = Int
1

cftype :: [CId] -> CId -> Type
cftype :: [CId] -> CId -> Type
cftype [CId]
args CId
val = [Hypo] -> CId -> [Expr] -> Type
DTyp [(BindType
Explicit,CId
wildCId,[CId] -> CId -> Type
cftype [] CId
arg) | CId
arg <- [CId]
args] CId
val []

typeOfHypo :: Hypo -> Type
typeOfHypo :: Hypo -> Type
typeOfHypo (BindType
_,CId
_,Type
ty) = Type
ty

catSkeleton :: Type -> ([CId],CId)
catSkeleton :: Type -> ([CId], CId)
catSkeleton Type
ty = case Type
ty of
  DTyp [Hypo]
hyps CId
val [Expr]
_ -> ([Type -> CId
valCat (Hypo -> Type
typeOfHypo Hypo
h) | Hypo
h <- [Hypo]
hyps],CId
val)

typeSkeleton :: Type -> ([(Int,CId)],CId)
typeSkeleton :: Type -> ([(Int, CId)], CId)
typeSkeleton Type
ty = case Type
ty of
  DTyp [Hypo]
hyps CId
val [Expr]
_ -> ([(Type -> Int
contextLength Type
ty, Type -> CId
valCat Type
ty) | Hypo
h <- [Hypo]
hyps, let ty :: Type
ty = Hypo -> Type
typeOfHypo Hypo
h],CId
val)

valCat :: Type -> CId
valCat :: Type -> CId
valCat Type
ty = case Type
ty of
  DTyp [Hypo]
_ CId
val [Expr]
_ -> CId
val

contextLength :: Type -> Int
contextLength :: Type -> Int
contextLength Type
ty = case Type
ty of
  DTyp [Hypo]
hyps CId
_ [Expr]
_ -> [Hypo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Hypo]
hyps

-- | Show the printname of function or category
showPrintName :: PGF -> Language -> CId -> String
showPrintName :: PGF -> CId -> CId -> [Char]
showPrintName PGF
pgf CId
lang CId
id = [Char] -> CId -> Map CId [Char] -> [Char]
forall i a. Ord i => a -> i -> Map i a -> a
lookMap (CId -> [Char]
showCId CId
id) CId
id (Map CId [Char] -> [Char]) -> Map CId [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Concr -> Map CId [Char]
printnames (Concr -> Map CId [Char]) -> Concr -> Map CId [Char]
forall a b. (a -> b) -> a -> b
$ Concr -> CId -> Map CId Concr -> Concr
forall i a. Ord i => a -> i -> Map i a -> a
lookMap ([Char] -> Concr
forall a. HasCallStack => [Char] -> a
error [Char]
"no lang") CId
lang (Map CId Concr -> Concr) -> Map CId Concr -> Concr
forall a b. (a -> b) -> a -> b
$ PGF -> Map CId Concr
concretes PGF
pgf

-- lookup with default value
lookMap :: Ord i => a -> i -> Map.Map i a -> a 
lookMap :: a -> i -> Map i a -> a
lookMap a
d i
c Map i a
m = a -> i -> Map i a -> a
forall i a. Ord i => a -> i -> Map i a -> a
Map.findWithDefault a
d i
c Map i a
m

--- from Operations
combinations :: [[a]] -> [[a]]
combinations :: [[a]] -> [[a]]
combinations [[a]]
t = case [[a]]
t of 
  []    -> [[]]
  [a]
aa:[[a]]
uu -> [a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
u | a
a <- [a]
aa, [a]
u <- [[a]] -> [[a]]
forall a. [[a]] -> [[a]]
combinations [[a]]
uu]

cidString :: CId
cidString = [Char] -> CId
mkCId [Char]
"String"
cidInt :: CId
cidInt    = [Char] -> CId
mkCId [Char]
"Int"
cidFloat :: CId
cidFloat  = [Char] -> CId
mkCId [Char]
"Float"
cidVar :: CId
cidVar    = [Char] -> CId
mkCId [Char]
"__gfVar"


-- Utilities for doing linearization

-- | BracketedString represents a sentence that is linearized
-- as usual but we also want to retain the ''brackets'' that
-- mark the beginning and the end of each constituent.
data BracketedString
  = Leaf Token                                                                -- ^ this is the leaf i.e. a single token
  | Bracket CId {-# UNPACK #-} !FId {-# UNPACK #-} !FId {-# UNPACK #-} !LIndex CId [Expr] [BracketedString]
                                                                               -- ^ this is a bracket. The 'CId' is the category of
                                                                               -- the phrase. The 'FId' is an unique identifier for
                                                                               -- every phrase in the sentence. For context-free grammars
                                                                               -- i.e. without discontinuous constituents this identifier
                                                                               -- is also unique for every bracket. When there are discontinuous 
                                                                               -- phrases then the identifiers are unique for every phrase but
                                                                               -- not for every bracket since the bracket represents a constituent.
                                                                               -- The different constituents could still be distinguished by using
                                                                               -- the constituent index i.e. 'LIndex'. If the grammar is reduplicating
                                                                               -- then the constituent indices will be the same for all brackets
                                                                               -- that represents the same constituent.

data BracketedTokn
  = Bracket_ CId {-# UNPACK #-} !FId {-# UNPACK #-} !FId {-# UNPACK #-} !LIndex CId [Expr] [BracketedTokn]    -- Invariant: the list is not empty
  | LeafKS Token
  | LeafNE
  | LeafBIND
  | LeafSOFT_BIND
  | LeafCAPIT
  | LeafKP [BracketedTokn] [([BracketedTokn],[String])]
  deriving BracketedTokn -> BracketedTokn -> Bool
(BracketedTokn -> BracketedTokn -> Bool)
-> (BracketedTokn -> BracketedTokn -> Bool) -> Eq BracketedTokn
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BracketedTokn -> BracketedTokn -> Bool
$c/= :: BracketedTokn -> BracketedTokn -> Bool
== :: BracketedTokn -> BracketedTokn -> Bool
$c== :: BracketedTokn -> BracketedTokn -> Bool
Eq

type LinTable = ([CId],Array.Array LIndex [BracketedTokn])

-- | Renders the bracketed string as string where 
-- the brackets are shown as @(S ...)@ where
-- @S@ is the category.
showBracketedString :: BracketedString -> String
showBracketedString :: BracketedString -> [Char]
showBracketedString = Doc -> [Char]
render (Doc -> [Char])
-> (BracketedString -> Doc) -> BracketedString -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BracketedString -> Doc
ppBracketedString

ppBracketedString :: BracketedString -> Doc
ppBracketedString (Leaf [Char]
t) = [Char] -> Doc
text [Char]
t
ppBracketedString (Bracket CId
cat Int
fid Int
fid' Int
index CId
_ [Expr]
_ [BracketedString]
bss) = Doc -> Doc
parens (CId -> Doc
ppCId CId
cat Doc -> Doc -> Doc
<> Doc
colon Doc -> Doc -> Doc
<> Int -> Doc
int Int
fid Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((BracketedString -> Doc) -> [BracketedString] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map BracketedString -> Doc
ppBracketedString [BracketedString]
bss))

-- | The length of the bracketed string in number of tokens.
lengthBracketedString :: BracketedString -> Int
lengthBracketedString :: BracketedString -> Int
lengthBracketedString (Leaf [Char]
_)                  = Int
1
lengthBracketedString (Bracket CId
_ Int
_ Int
_ Int
_ CId
_ [Expr]
_ [BracketedString]
bss) = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((BracketedString -> Int) -> [BracketedString] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map BracketedString -> Int
lengthBracketedString [BracketedString]
bss)

untokn :: Maybe String -> [BracketedTokn] -> (Maybe String,[BracketedString])
untokn :: Maybe [Char]
-> [BracketedTokn] -> (Maybe [Char], [BracketedString])
untokn Maybe [Char]
nw [BracketedTokn]
bss =
  let (Maybe [Char]
nw',[Maybe [BracketedString]]
bss') = (Maybe [Char]
 -> BracketedTokn -> (Maybe [Char], Maybe [BracketedString]))
-> Maybe [Char]
-> [BracketedTokn]
-> (Maybe [Char], [Maybe [BracketedString]])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumR Maybe [Char]
-> BracketedTokn -> (Maybe [Char], Maybe [BracketedString])
untokn Maybe [Char]
nw [BracketedTokn]
bss
  in case [Maybe [BracketedString]] -> Maybe [[BracketedString]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Maybe [BracketedString]]
bss' of
       Just [[BracketedString]]
bss -> (Maybe [Char]
nw,[[BracketedString]] -> [BracketedString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[BracketedString]]
bss)
       Maybe [[BracketedString]]
Nothing  -> (Maybe [Char]
nw,[])
  where
    untokn :: Maybe [Char]
-> BracketedTokn -> (Maybe [Char], Maybe [BracketedString])
untokn Maybe [Char]
nw (Bracket_ CId
cat Int
fid Int
fid' Int
index CId
fun [Expr]
es [BracketedTokn]
bss) =
      let (Maybe [Char]
nw',[Maybe [BracketedString]]
bss') = (Maybe [Char]
 -> BracketedTokn -> (Maybe [Char], Maybe [BracketedString]))
-> Maybe [Char]
-> [BracketedTokn]
-> (Maybe [Char], [Maybe [BracketedString]])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumR Maybe [Char]
-> BracketedTokn -> (Maybe [Char], Maybe [BracketedString])
untokn Maybe [Char]
nw [BracketedTokn]
bss
      in case [Maybe [BracketedString]] -> Maybe [[BracketedString]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Maybe [BracketedString]]
bss' of
           Just [[BracketedString]]
bss -> (Maybe [Char]
nw',[BracketedString] -> Maybe [BracketedString]
forall a. a -> Maybe a
Just [CId
-> Int
-> Int
-> Int
-> CId
-> [Expr]
-> [BracketedString]
-> BracketedString
Bracket CId
cat Int
fid Int
fid' Int
index CId
fun [Expr]
es ([[BracketedString]] -> [BracketedString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[BracketedString]]
bss)])
           Maybe [[BracketedString]]
Nothing  -> (Maybe [Char]
forall a. Maybe a
Nothing, Maybe [BracketedString]
forall a. Maybe a
Nothing)
    untokn Maybe [Char]
nw (LeafKS [Char]
t)
      | [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
t              = (Maybe [Char]
nw,[BracketedString] -> Maybe [BracketedString]
forall a. a -> Maybe a
Just [])
      | Bool
otherwise           = ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
t,[BracketedString] -> Maybe [BracketedString]
forall a. a -> Maybe a
Just [[Char] -> BracketedString
Leaf [Char]
t])
    untokn Maybe [Char]
nw BracketedTokn
LeafNE        = (Maybe [Char]
forall a. Maybe a
Nothing, Maybe [BracketedString]
forall a. Maybe a
Nothing)
    untokn Maybe [Char]
nw (LeafKP [BracketedTokn]
d [([BracketedTokn], [[Char]])]
vs) = let (Maybe [Char]
nw',[Maybe [BracketedString]]
bss') = (Maybe [Char]
 -> BracketedTokn -> (Maybe [Char], Maybe [BracketedString]))
-> Maybe [Char]
-> [BracketedTokn]
-> (Maybe [Char], [Maybe [BracketedString]])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumR Maybe [Char]
-> BracketedTokn -> (Maybe [Char], Maybe [BracketedString])
untokn Maybe [Char]
nw ([BracketedTokn]
-> [([BracketedTokn], [[Char]])] -> Maybe [Char] -> [BracketedTokn]
forall (t :: * -> *) a p.
(Foldable t, Eq a) =>
p -> [(p, t [a])] -> Maybe [a] -> p
sel [BracketedTokn]
d [([BracketedTokn], [[Char]])]
vs Maybe [Char]
nw)
                              in case [Maybe [BracketedString]] -> Maybe [[BracketedString]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Maybe [BracketedString]]
bss' of
                                   Just [[BracketedString]]
bss -> (Maybe [Char]
nw',[BracketedString] -> Maybe [BracketedString]
forall a. a -> Maybe a
Just ([[BracketedString]] -> [BracketedString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[BracketedString]]
bss))
                                   Maybe [[BracketedString]]
Nothing  -> (Maybe [Char]
forall a. Maybe a
Nothing, Maybe [BracketedString]
forall a. Maybe a
Nothing)
                              where
                                sel :: p -> [(p, t [a])] -> Maybe [a] -> p
sel p
d [(p, t [a])]
vs Maybe [a]
Nothing  = p
d
                                sel p
d [(p, t [a])]
vs (Just [a]
w) =
                                  case [p
v | (p
v,t [a]
cs) <- [(p, t [a])]
vs, ([a] -> Bool) -> t [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\[a]
c -> [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [a]
c [a]
w) t [a]
cs] of
                                    p
v:[p]
_ -> p
v
                                    [p]
_   -> p
d

type CncType = (CId, FId)    -- concrete type is the abstract type (the category) + the forest id

mkLinTable :: Concr -> (CncType -> Bool) -> [CId] -> FunId -> [(CncType,FId,CId,[Expr],LinTable)] -> LinTable
mkLinTable :: Concr
-> (CncType -> Bool)
-> [CId]
-> Int
-> [(CncType, Int, CId, [Expr], LinTable)]
-> LinTable
mkLinTable Concr
cnc CncType -> Bool
filter [CId]
xs Int
funid [(CncType, Int, CId, [Expr], LinTable)]
args = ([CId]
xs,(Int, Int) -> [[BracketedTokn]] -> Array Int [BracketedTokn]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (UArray Int Int -> (Int, Int)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray Int Int
lins) [(CncType -> Bool)
-> [Symbol]
-> [(CncType, Int, CId, [Expr], LinTable)]
-> [BracketedTokn]
computeSeq CncType -> Bool
filter (Array Int Symbol -> [Symbol]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems (Concr -> Array Int (Array Int Symbol)
sequences Concr
cnc Array Int (Array Int Symbol) -> Int -> Array Int Symbol
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Int
seqid)) [(CncType, Int, CId, [Expr], LinTable)]
args | Int
seqid <- UArray Int Int -> [Int]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems UArray Int Int
lins])
  where
    (CncFun CId
_ UArray Int Int
lins) = Concr -> Array Int CncFun
cncfuns Concr
cnc Array Int CncFun -> Int -> CncFun
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Int
funid

computeSeq :: (CncType -> Bool) -> [Symbol] -> [(CncType,FId,CId,[Expr],LinTable)] -> [BracketedTokn]
computeSeq :: (CncType -> Bool)
-> [Symbol]
-> [(CncType, Int, CId, [Expr], LinTable)]
-> [BracketedTokn]
computeSeq CncType -> Bool
filter [Symbol]
seq [(CncType, Int, CId, [Expr], LinTable)]
args = (Symbol -> [BracketedTokn]) -> [Symbol] -> [BracketedTokn]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Symbol -> [BracketedTokn]
compute [Symbol]
seq
  where
    compute :: Symbol -> [BracketedTokn]
compute (SymCat Int
d Int
r)      = Int -> Int -> [BracketedTokn]
getArg Int
d Int
r
    compute (SymLit Int
d Int
r)      = Int -> Int -> [BracketedTokn]
getArg Int
d Int
r
    compute (SymVar Int
d Int
r)      = Int -> Int -> [BracketedTokn]
getVar Int
d Int
r
    compute (SymKS [Char]
t)         = [[Char] -> BracketedTokn
LeafKS [Char]
t]
    compute Symbol
SymNE             = [BracketedTokn
LeafNE]
    compute Symbol
SymBIND           = [[Char] -> BracketedTokn
LeafKS [Char]
"&+"]
    compute Symbol
SymSOFT_BIND      = []
    compute Symbol
SymSOFT_SPACE     = []
    compute Symbol
SymCAPIT          = [[Char] -> BracketedTokn
LeafKS [Char]
"&|"]
    compute Symbol
SymALL_CAPIT      = [[Char] -> BracketedTokn
LeafKS [Char]
"&|"]
    compute (SymKP [Symbol]
syms [([Symbol], [[Char]])]
alts) = [[BracketedTokn] -> [([BracketedTokn], [[Char]])] -> BracketedTokn
LeafKP ((Symbol -> [BracketedTokn]) -> [Symbol] -> [BracketedTokn]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Symbol -> [BracketedTokn]
compute [Symbol]
syms) [((Symbol -> [BracketedTokn]) -> [Symbol] -> [BracketedTokn]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Symbol -> [BracketedTokn]
compute [Symbol]
syms,[[Char]]
cs) | ([Symbol]
syms,[[Char]]
cs) <- [([Symbol], [[Char]])]
alts]]

    getArg :: Int -> Int -> [BracketedTokn]
getArg Int
d Int
r
      | Bool -> Bool
not ([BracketedTokn] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BracketedTokn]
arg_lin) Bool -> Bool -> Bool
&&
        CncType -> Bool
filter CncType
ct   = [CId
-> Int
-> Int
-> Int
-> CId
-> [Expr]
-> [BracketedTokn]
-> BracketedTokn
Bracket_ CId
cat Int
fid Int
fid' Int
r CId
fun [Expr]
es [BracketedTokn]
arg_lin]
      | Bool
otherwise   = [BracketedTokn]
arg_lin
      where
        arg_lin :: [BracketedTokn]
arg_lin                              = Array Int [BracketedTokn]
lin Array Int [BracketedTokn] -> Int -> [BracketedTokn]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Int
r
        (ct :: CncType
ct@(CId
cat,Int
fid),Int
fid',CId
fun,[Expr]
es,([CId]
_xs,Array Int [BracketedTokn]
lin)) = [(CncType, Int, CId, [Expr], LinTable)]
args [(CncType, Int, CId, [Expr], LinTable)]
-> Int -> (CncType, Int, CId, [Expr], LinTable)
forall a. [a] -> Int -> a
!! Int
d

    getVar :: Int -> Int -> [BracketedTokn]
getVar Int
d Int
r = [[Char] -> BracketedTokn
LeafKS (CId -> [Char]
showCId ([CId]
xs [CId] -> Int -> CId
forall a. [a] -> Int -> a
!! Int
r))]
      where
        (CncType
_ct,Int
_,CId
_fun,[Expr]
_es,([CId]
xs,Array Int [BracketedTokn]
_lin)) = [(CncType, Int, CId, [Expr], LinTable)]
args [(CncType, Int, CId, [Expr], LinTable)]
-> Int -> (CncType, Int, CId, [Expr], LinTable)
forall a. [a] -> Int -> a
!! Int
d

flattenBracketedString :: BracketedString -> [String]
flattenBracketedString :: BracketedString -> [[Char]]
flattenBracketedString (Leaf [Char]
w)                  = [[Char]
w]
flattenBracketedString (Bracket CId
_ Int
_ Int
_ Int
_ CId
_ [Expr]
_ [BracketedString]
bss) = (BracketedString -> [[Char]]) -> [BracketedString] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BracketedString -> [[Char]]
flattenBracketedString [BracketedString]
bss


-- The following is a version of Data.List.sortBy which together
-- with the sorting also eliminates duplicate values 
sortNubBy :: (a -> a -> Ordering) -> [a] -> [a]
sortNubBy a -> a -> Ordering
cmp = [[a]] -> [a]
mergeAll ([[a]] -> [a]) -> ([a] -> [[a]]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [[a]]
sequences
  where
    sequences :: [a] -> [[a]]
sequences (a
a:a
b:[a]
xs) =
      case a -> a -> Ordering
cmp a
a a
b of
        Ordering
GT -> a -> [a] -> [a] -> [[a]]
descending a
b [a
a]  [a]
xs
        Ordering
EQ -> [a] -> [[a]]
sequences (a
ba -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)
        Ordering
LT -> a -> ([a] -> [a]) -> [a] -> [[a]]
ascending  a
b (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) [a]
xs
    sequences [a]
xs = [[a]
xs]

    descending :: a -> [a] -> [a] -> [[a]]
descending a
a [a]
as []     = [a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
as]
    descending a
a [a]
as (a
b:[a]
bs) =
      case a -> a -> Ordering
cmp a
a a
b of
        Ordering
GT -> a -> [a] -> [a] -> [[a]]
descending a
b (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
as) [a]
bs
        Ordering
EQ -> a -> [a] -> [a] -> [[a]]
descending a
a [a]
as [a]
bs
        Ordering
LT -> (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
as) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a] -> [[a]]
sequences (a
ba -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
bs)

    ascending :: a -> ([a] -> [a]) -> [a] -> [[a]]
ascending a
a [a] -> [a]
as []     = let !x :: [a]
x = [a] -> [a]
as [a
a]
                            in [[a]
x]
    ascending a
a [a] -> [a]
as (a
b:[a]
bs) =
      case a -> a -> Ordering
cmp a
a a
b of
        Ordering
GT -> let !x :: [a]
x = [a] -> [a]
as [a
a]
              in [a]
x [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a] -> [[a]]
sequences (a
ba -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
bs)
        Ordering
EQ -> a -> ([a] -> [a]) -> [a] -> [[a]]
ascending a
a [a] -> [a]
as [a]
bs
        Ordering
LT -> a -> ([a] -> [a]) -> [a] -> [[a]]
ascending a
b (\[a]
ys -> [a] -> [a]
as (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys)) [a]
bs

    mergeAll :: [[a]] -> [a]
mergeAll [[a]
x] = [a]
x
    mergeAll [[a]]
xs  = [[a]] -> [a]
mergeAll ([[a]] -> [[a]]
mergePairs [[a]]
xs)

    mergePairs :: [[a]] -> [[a]]
mergePairs ([a]
a:[a]
b:[[a]]
xs) = let !x :: [a]
x = [a] -> [a] -> [a]
merge [a]
a [a]
b
                          in [a]
x [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]] -> [[a]]
mergePairs [[a]]
xs
    mergePairs [[a]]
xs       = [[a]]
xs

    merge :: [a] -> [a] -> [a]
merge as :: [a]
as@(a
a:[a]
as') bs :: [a]
bs@(a
b:[a]
bs') =
      case a -> a -> Ordering
cmp a
a a
b of
        Ordering
GT -> a
ba -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a] -> [a] -> [a]
merge [a]
as  [a]
bs'
        Ordering
EQ -> a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a] -> [a] -> [a]
merge [a]
as' [a]
bs'
        Ordering
LT -> a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a] -> [a] -> [a]
merge [a]
as' [a]
bs
    merge [] [a]
bs         = [a]
bs
    merge [a]
as []         = [a]
as


-- The following function does case-insensitive comparison of sequences.
-- This is used to allow case-insensitive parsing, while
-- the linearizer still has access to the original cases.
compareCaseInsensitve :: a i Symbol -> a i Symbol -> Ordering
compareCaseInsensitve a i Symbol
s1 a i Symbol
s2 =
    case [Symbol] -> [Symbol] -> (Ordering, Ordering)
compareSeq (a i Symbol -> [Symbol]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems a i Symbol
s1) (a i Symbol -> [Symbol]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems a i Symbol
s2) of
      (Ordering
EQ,Ordering
c) -> Ordering
c
      (Ordering
c, Ordering
_) -> Ordering
c
    where
      compareSeq :: [Symbol] -> [Symbol] -> (Ordering, Ordering)
compareSeq []     []     = Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup Ordering
EQ
      compareSeq []     [Symbol]
_      = Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup Ordering
LT
      compareSeq [Symbol]
_      []     = Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup Ordering
GT
      compareSeq (Symbol
x:[Symbol]
xs) (Symbol
y:[Symbol]
ys) =
        case Symbol -> Symbol -> (Ordering, Ordering)
compareSym Symbol
x Symbol
y of
          (Ordering
EQ,Ordering
EQ) -> [Symbol] -> [Symbol] -> (Ordering, Ordering)
compareSeq [Symbol]
xs [Symbol]
ys
          (Ordering
EQ,Ordering
c2) -> case [Symbol] -> [Symbol] -> (Ordering, Ordering)
compareSeq [Symbol]
xs [Symbol]
ys of
                       (Ordering
c1,Ordering
_) -> (Ordering
c1,Ordering
c2)
          (Ordering, Ordering)
x       -> (Ordering, Ordering)
x

      compareSym :: Symbol -> Symbol -> (Ordering, Ordering)
compareSym Symbol
s1 Symbol
s2 =
        case Symbol
s1 of
          SymCat Int
d1 Int
r1
            -> case Symbol
s2 of
                 SymCat Int
d2 Int
r2
                   -> case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
d1 Int
d2 of
                        Ordering
EQ -> Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup (Int
r1 Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Int
r2)
                        Ordering
x  -> Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup Ordering
x
                 Symbol
_ -> Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup Ordering
LT
          SymLit Int
d1 Int
r1
            -> case Symbol
s2 of
                 SymCat {} -> Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup Ordering
GT
                 SymLit Int
d2 Int
r2
                   -> case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
d1 Int
d2 of
                        Ordering
EQ -> Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup (Int
r1 Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Int
r2)
                        Ordering
x  -> Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup Ordering
x
                 Symbol
_ -> Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup Ordering
LT
          SymVar Int
d1 Int
r1
            -> if Int# -> Bool
forall a. Int# -> a
tagToEnum# (Symbol -> Int#
forall a. a -> Int#
getTag Symbol
s2 Int# -> Int# -> Int#
># Int#
2#)
                 then Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup Ordering
LT
                 else case Symbol
s2 of
                        SymVar Int
d2 Int
r2
                          -> case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
d1 Int
d2 of
                               Ordering
EQ -> Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup (Int
r1 Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Int
r2)
                               Ordering
x  -> Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup Ordering
x
                        Symbol
_ -> Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup Ordering
GT
          SymKS [Char]
t1
            -> if Int# -> Bool
forall a. Int# -> a
tagToEnum# (Symbol -> Int#
forall a. a -> Int#
getTag Symbol
s2 Int# -> Int# -> Int#
># Int#
3#)
                 then Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup Ordering
LT
                 else case Symbol
s2 of
                        SymKS [Char]
t2 -> [Char]
t1 [Char] -> [Char] -> (Ordering, Ordering)
`compareToken` [Char]
t2
                        Symbol
_          -> Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup Ordering
GT
          SymKP [Symbol]
a1 [([Symbol], [[Char]])]
b1
            -> if Int# -> Bool
forall a. Int# -> a
tagToEnum# (Symbol -> Int#
forall a. a -> Int#
getTag Symbol
s2 Int# -> Int# -> Int#
># Int#
4#)
                 then Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup Ordering
LT
                 else case Symbol
s2 of
                        SymKP [Symbol]
a2 [([Symbol], [[Char]])]
b2
                          -> case [Symbol] -> [Symbol] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [Symbol]
a1 [Symbol]
a2 of
                               Ordering
EQ -> Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup ([([Symbol], [[Char]])]
b1 [([Symbol], [[Char]])] -> [([Symbol], [[Char]])] -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` [([Symbol], [[Char]])]
b2)
                               Ordering
x  -> Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup Ordering
x
                        Symbol
_ -> Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup Ordering
GT
          Symbol
_ -> let t1 :: Int#
t1 = Symbol -> Int#
forall a. a -> Int#
getTag Symbol
s1
                   t2 :: Int#
t2 = Symbol -> Int#
forall a. a -> Int#
getTag Symbol
s2
               in if Int# -> Bool
forall a. Int# -> a
tagToEnum# (Int#
t1 Int# -> Int# -> Int#
<# Int#
t2) 
                    then Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup Ordering
LT
                    else if Int# -> Bool
forall a. Int# -> a
tagToEnum# (Int#
t1 Int# -> Int# -> Int#
==# Int#
t2)
                           then Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup Ordering
EQ
                           else Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup Ordering
GT
  
      compareToken :: [Char] -> [Char] -> (Ordering, Ordering)
compareToken []     []     = Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup Ordering
EQ
      compareToken []     [Char]
_      = Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup Ordering
LT
      compareToken [Char]
_      []     = Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup Ordering
GT
      compareToken (Char
x:[Char]
xs) (Char
y:[Char]
ys)
        | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
y    = [Char] -> [Char] -> (Ordering, Ordering)
compareToken [Char]
xs [Char]
ys
        | Bool
otherwise = case Char -> Char -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Char -> Char
toLower Char
x) (Char -> Char
toLower Char
y) of
                        Ordering
EQ -> case [Char] -> [Char] -> (Ordering, Ordering)
compareToken [Char]
xs [Char]
ys of
                                (Ordering
c,Ordering
_) -> (Ordering
c,Char -> Char -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Char
x Char
y)
                        Ordering
c  -> Ordering -> (Ordering, Ordering)
forall b. b -> (b, b)
dup Ordering
c

      dup :: b -> (b, b)
dup b
x = (b
x,b
x)