{-# LANGUAGE MagicHash, BangPatterns, FlexibleContexts #-}
module PGF.Macros where
import Prelude hiding ((<>))
import PGF.CId
import PGF.Data
import Control.Monad
import qualified Data.Map as Map
import qualified Data.Array as Array
import Data.List
import Data.Array.IArray
import Text.PrettyPrint
import GHC.Prim
import GHC.Base(getTag)
import Data.Char
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
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
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
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)
}
}
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
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
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
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"
data BracketedString
= Leaf Token
| Bracket CId {-# UNPACK #-} !FId {-# UNPACK #-} !FId {-# UNPACK #-} !LIndex CId [Expr] [BracketedString]
data BracketedTokn
= Bracket_ CId {-# UNPACK #-} !FId {-# UNPACK #-} !FId {-# UNPACK #-} !LIndex CId [Expr] [BracketedTokn]
| 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])
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))
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)
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
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
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)