module HERMIT.External
(
External
, ExternalName
, ExternalHelp
, externName
, externDyn
, externHelp
, externTypeString
, externTypeArgResString
, Dictionary
, toDictionary
, toHelp
, external
, Extern(..)
, matchingExternals
, CmdTag(..)
, TagE
, Tag((.+),remTag,tagMatch)
, (.&)
, (.||)
, notT
, externTags
, dictionaryOfTags
, TagBox(..)
, IntBox(..)
, RewriteCoreBox(..)
, RewriteCoreTCBox(..)
, BiRewriteCoreBox(..)
, TranslateCoreStringBox(..)
, TranslateCoreTCStringBox(..)
, TranslateCoreCheckBox(..)
, TranslateCoreTCCheckBox(..)
, TranslateCorePathBox(..)
, TranslateCoreTCPathBox(..)
, NameBox(..)
, CoreString(..)
, CoreBox(..)
, CrumbBox(..)
, PathBox(..)
, StringBox(..)
, NameListBox(..)
, StringListBox(..)
, IntListBox(..)
, RewriteCoreListBox(..)
) where
import Data.Map hiding (map)
import Data.Dynamic
import Data.List
import Data.Typeable.Internal (TypeRep(..), funTc)
import qualified Language.Haskell.TH as TH
import HERMIT.Core
import HERMIT.Context (LocalPathH)
import HERMIT.Kure
type ExternalName = String
type ExternalHelp = [String]
data CmdTag = Shell
| Eval
| KURE
| Loop
| Deep
| Shallow
| Navigation
| Query
| Predicate
| Introduce
| Commute
| PreCondition
| Debug
| VersionControl
| Context
| Unsafe
| TODO
| Experiment
| Deprecated
deriving (Eq, Show, Read, Bounded, Enum)
dictionaryOfTags :: [(CmdTag,String)]
dictionaryOfTags = notes ++ [ (tag,"(unknown purpose)")
| tag <- [minBound..maxBound]
, tag `notElem` map fst notes
]
where notes =
[ (Shell, "Shell-specific command.")
, (Eval, "The arrow of evaluation (reduces a term).")
, (KURE, "Direct reflection of a combinator from the KURE DSL.")
, (Loop, "Command may operate multiple times.")
, (Deep, "Command may make a deep change, can be O(n).")
, (Shallow, "Command operates on local nodes only, O(1).")
, (Navigation, "Navigate via focus, or directional command.")
, (Query, "A question we ask.")
, (Predicate, "Something that passes or fails.")
, (Introduce, "Introduce something, like a new name.")
, (Commute, "Commute is when you swap nested terms.")
, (PreCondition, "Operation has a (perhaps undocumented) precondition.")
, (Debug, "A command specifically to help debugging.")
, (VersionControl,"Version control for Core syntax.")
, (Context, "A command that uses its context, such as inlining.")
, (Unsafe, "Commands that are not type safe (may cause Core Lint to fail), or may otherwise change the semantics of the program.")
, (TODO, "An incomplete or potentially buggy command.")
, (Experiment, "Things we are trying out, use at your own risk.")
, (Deprecated, "A command that will be removed in a future release; it has probably been renamed or subsumed by another command.")
]
infixl 3 .+
infixr 4 .||
infixr 5 .&
data TagE :: * where
Tag :: Tag a => a -> TagE
NotTag :: TagE -> TagE
AndTag :: TagE -> TagE -> TagE
OrTag :: TagE -> TagE -> TagE
class Tag a where
toTagE :: a -> TagE
(.+) :: External -> a -> External
remTag :: a -> External -> External
tagMatch :: a -> External -> Bool
instance Tag TagE where
toTagE = id
e .+ (Tag t) = e .+ t
e .+ (NotTag t) = remTag t e
e .+ (AndTag t1 t2) = e .+ t1 .+ t2
e .+ (OrTag t1 t2) = e .+ t1 .+ t2
remTag (Tag t) e = remTag t e
remTag (NotTag t) e = e .+ t
remTag (AndTag t1 t2) e = remTag t1 (remTag t2 e)
remTag (OrTag t1 t2) e = remTag t1 (remTag t2 e)
tagMatch (Tag t) e = tagMatch t e
tagMatch (NotTag t) e = not (tagMatch t e)
tagMatch (AndTag t1 t2) e = tagMatch t1 e && tagMatch t2 e
tagMatch (OrTag t1 t2) e = tagMatch t1 e || tagMatch t2 e
instance Tag CmdTag where
toTagE = Tag
ex@(External {externTags = ts}) .+ t = ex {externTags = t:ts}
remTag t ex@(External {externTags = ts}) = ex { externTags = [ t' | t' <- ts, t' /= t ] }
tagMatch t (External {externTags = ts}) = t `elem` ts
(.&) :: (Tag a, Tag b) => a -> b -> TagE
t1 .& t2 = AndTag (toTagE t1) (toTagE t2)
(.||) :: (Tag a, Tag b) => a -> b -> TagE
t1 .|| t2 = OrTag (toTagE t1) (toTagE t2)
notT :: Tag a => a -> TagE
notT = NotTag . toTagE
data External = External
{ externName :: ExternalName
, externDyn :: Dynamic
, externHelp :: ExternalHelp
, externTags :: [CmdTag]
}
external :: Extern a => ExternalName -> a -> ExternalHelp -> External
external nm fn help = External
{ externName = nm
, externDyn = toDyn (box fn)
, externHelp = map (" " ++) help
, externTags = []
}
matchingExternals :: (Extern tr, Tag t) => t -> [External] -> [(External, tr)]
matchingExternals tag exts = [ (e,tr) | e <- exts, tagMatch tag e
, Just tr <- [fmap unbox $ fromDynamic $ externDyn e] ]
type Dictionary = Map ExternalName [Dynamic]
toDictionary :: [External] -> Dictionary
toDictionary
= fromListWith (++) . map toD
where
toD :: External -> (ExternalName,[Dynamic])
toD e = (externName e,[externDyn e])
toHelp :: [External] -> Map ExternalName ExternalHelp
toHelp = fromListWith (++) . map toH
where
toH :: External -> (ExternalName,ExternalHelp)
toH e = (externName e, spaceout (externName e ++ " :: " ++ externTypeString e)
(show (externTags e)) : externHelp e)
spaceout xs ys = xs ++ replicate (width (length xs + length ys)) ' ' ++ ys
width = 78
externTypeString :: External -> String
externTypeString = deBoxify . show . dynTypeRep . externDyn
deBoxify :: String -> String
deBoxify xs | "Box" `isPrefixOf` xs = deBoxify (drop 3 xs)
deBoxify (x:xs) = x : deBoxify xs
deBoxify [] = []
externTypeArgResString :: External -> ([String], String)
externTypeArgResString e = (map (deBoxify . show) aTys, deBoxify (show rTy))
where (aTys, rTy) = splitExternFunType e
splitExternFunType :: External -> ([TypeRep], TypeRep)
splitExternFunType = splitFunTyArgs . dynTypeRep . externDyn
splitFunTyArgs :: TypeRep -> ([TypeRep], TypeRep)
splitFunTyArgs tr = case splitFunTyMaybe tr of
Nothing -> ([], tr)
Just (a, r) -> let (as, r') = splitFunTyArgs r
in (a:as, r')
splitFunTyMaybe :: TypeRep -> Maybe (TypeRep, TypeRep)
splitFunTyMaybe (TypeRep _ tc [a,r]) | tc == funTc = Just (a,r)
splitFunTyMaybe _ = Nothing
class Typeable (Box a) => Extern a where
type Box a
box :: a -> Box a
unbox :: Box a -> a
instance (Extern a, Extern b) => Extern (a -> b) where
type Box (a -> b) = Box a -> Box b
box f = box . f . unbox
unbox f = unbox . f . box
data TagBox = TagBox TagE deriving Typeable
instance Extern TagE where
type Box TagE = TagBox
box = TagBox
unbox (TagBox t) = t
data IntBox = IntBox Int deriving Typeable
instance Extern Int where
type Box Int = IntBox
box = IntBox
unbox (IntBox i) = i
data RewriteCoreBox = RewriteCoreBox (RewriteH Core) deriving Typeable
instance Extern (RewriteH Core) where
type Box (RewriteH Core) = RewriteCoreBox
box = RewriteCoreBox
unbox (RewriteCoreBox r) = r
data RewriteCoreTCBox = RewriteCoreTCBox (RewriteH CoreTC) deriving Typeable
instance Extern (RewriteH CoreTC) where
type Box (RewriteH CoreTC) = RewriteCoreTCBox
box = RewriteCoreTCBox
unbox (RewriteCoreTCBox r) = r
data BiRewriteCoreBox = BiRewriteCoreBox (BiRewriteH Core) deriving Typeable
instance Extern (BiRewriteH Core) where
type Box (BiRewriteH Core) = BiRewriteCoreBox
box = BiRewriteCoreBox
unbox (BiRewriteCoreBox b) = b
data TranslateCoreTCStringBox = TranslateCoreTCStringBox (TranslateH CoreTC String) deriving Typeable
instance Extern (TranslateH CoreTC String) where
type Box (TranslateH CoreTC String) = TranslateCoreTCStringBox
box = TranslateCoreTCStringBox
unbox (TranslateCoreTCStringBox t) = t
data TranslateCoreStringBox = TranslateCoreStringBox (TranslateH Core String) deriving Typeable
instance Extern (TranslateH Core String) where
type Box (TranslateH Core String) = TranslateCoreStringBox
box = TranslateCoreStringBox
unbox (TranslateCoreStringBox t) = t
data TranslateCoreTCCheckBox = TranslateCoreTCCheckBox (TranslateH CoreTC ()) deriving Typeable
instance Extern (TranslateH CoreTC ()) where
type Box (TranslateH CoreTC ()) = TranslateCoreTCCheckBox
box = TranslateCoreTCCheckBox
unbox (TranslateCoreTCCheckBox t) = t
data TranslateCoreCheckBox = TranslateCoreCheckBox (TranslateH Core ()) deriving Typeable
instance Extern (TranslateH Core ()) where
type Box (TranslateH Core ()) = TranslateCoreCheckBox
box = TranslateCoreCheckBox
unbox (TranslateCoreCheckBox t) = t
data NameBox = NameBox (TH.Name) deriving Typeable
instance Extern TH.Name where
type Box TH.Name = NameBox
box = NameBox
unbox (NameBox n) = n
data CrumbBox = CrumbBox Crumb deriving Typeable
instance Extern Crumb where
type Box Crumb = CrumbBox
box = CrumbBox
unbox (CrumbBox cr) = cr
data PathBox = PathBox LocalPathH deriving Typeable
instance Extern LocalPathH where
type Box LocalPathH = PathBox
box = PathBox
unbox (PathBox p) = p
data TranslateCorePathBox = TranslateCorePathBox (TranslateH Core LocalPathH) deriving Typeable
instance Extern (TranslateH Core LocalPathH) where
type Box (TranslateH Core LocalPathH) = TranslateCorePathBox
box = TranslateCorePathBox
unbox (TranslateCorePathBox t) = t
data TranslateCoreTCPathBox = TranslateCoreTCPathBox (TranslateH CoreTC LocalPathH) deriving Typeable
instance Extern (TranslateH CoreTC LocalPathH) where
type Box (TranslateH CoreTC LocalPathH) = TranslateCoreTCPathBox
box = TranslateCoreTCPathBox
unbox (TranslateCoreTCPathBox t) = t
newtype CoreString = CoreString { unCoreString :: String }
data CoreBox = CoreBox CoreString deriving Typeable
instance Extern CoreString where
type Box CoreString = CoreBox
box = CoreBox
unbox (CoreBox s) = s
data StringBox = StringBox String deriving Typeable
instance Extern String where
type Box String = StringBox
box = StringBox
unbox (StringBox s) = s
data NameListBox = NameListBox [TH.Name] deriving Typeable
instance Extern [TH.Name] where
type Box [TH.Name] = NameListBox
box = NameListBox
unbox (NameListBox l) = l
data StringListBox = StringListBox [String] deriving Typeable
instance Extern [String] where
type Box [String] = StringListBox
box = StringListBox
unbox (StringListBox l) = l
data IntListBox = IntListBox [Int] deriving Typeable
instance Extern [Int] where
type Box [Int] = IntListBox
box = IntListBox
unbox (IntListBox l) = l
data RewriteCoreListBox = RewriteCoreListBox [RewriteH Core] deriving Typeable
instance Extern [RewriteH Core] where
type Box [RewriteH Core] = RewriteCoreListBox
box = RewriteCoreListBox
unbox (RewriteCoreListBox l) = l