mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-10 05:29:30 -06:00
79 lines
1.7 KiB
Haskell
79 lines
1.7 KiB
Haskell
module Trees where
|
|
|
|
data Exp =
|
|
EApp Exp Exp
|
|
| EAbs Ident Exp
|
|
| EAtom Atom
|
|
deriving (Eq,Ord,Show)
|
|
|
|
newtype CFTree = CFTree (CFFun,[CFTree]) deriving (Eq, Show)
|
|
|
|
type CFCat = Ident
|
|
|
|
newtype Ident = Ident String deriving (Eq, Ord, Show)
|
|
|
|
-- to build trees: the Atom contains a GF function, Cn | Meta | Vr | Literal
|
|
newtype CFFun = CFFun (Atom, Profile) deriving (Eq,Ord,Show)
|
|
|
|
type Profile = [([[Int]],[Int])]
|
|
|
|
data Atom =
|
|
AC Ident
|
|
| AV Ident
|
|
| AM
|
|
| AS String
|
|
| AI Integer
|
|
deriving (Eq,Ord,Show)
|
|
|
|
-- printing
|
|
|
|
class Prt a where
|
|
prt :: a -> String
|
|
|
|
instance Prt Exp where
|
|
prt e = case e of
|
|
EApp f a -> unwords [prt f, prt1 a]
|
|
EAbs x a -> "\\" ++ prt x ++ " -> " ++ prt a
|
|
EAtom a -> prt a
|
|
where
|
|
prt1 e = case e of
|
|
EAtom _ -> prt e
|
|
_ -> "(" ++ prt e ++ ")"
|
|
|
|
instance Prt Atom where
|
|
prt a = case a of
|
|
AC x -> prt x
|
|
AV x -> prt x
|
|
AM -> "?"
|
|
AS s -> show s ----
|
|
AI i -> show i
|
|
|
|
instance Prt Ident where
|
|
prt (Ident x) = x
|
|
|
|
-- printing trees
|
|
|
|
prCFTree :: CFTree -> String
|
|
prCFTree (CFTree (fun, trees)) = prCFFun fun ++ prs trees where
|
|
prs [] = ""
|
|
prs ts = " " ++ unwords (map ps ts)
|
|
ps t@(CFTree (_,[])) = prCFTree t
|
|
ps t = "(" ++ prCFTree t ++ ")"
|
|
|
|
prCFFun :: CFFun -> String
|
|
prCFFun = prCFFun' True ---- False -- print profiles for debug
|
|
|
|
prCFFun' :: Bool -> CFFun -> String
|
|
prCFFun' profs (CFFun (t, p)) = prt t ++ pp p where
|
|
pp p = if (not profs || normal p) then "" else "_" ++ concat (map show p)
|
|
normal p = and [x==y && null b | ((b,x),y) <- zip p (map (:[]) [0..])]
|
|
|
|
prCFCat :: CFCat -> String
|
|
prCFCat c = prt c
|
|
|
|
mkFunTree :: String -> Profile -> [CFTree] -> CFTree
|
|
mkFunTree f p ts = CFTree (CFFun (AC (Ident f),p), ts)
|
|
|
|
mkAtTree :: Atom -> CFTree
|
|
mkAtTree a = CFTree (CFFun (a,[]), [])
|