hermit 0.1.1.1 → 0.1.2.0
raw patch · 21 files changed
+464/−445 lines, 21 filesdep ~aesondep ~containersdep ~data-default
Dependency ranges changed: aeson, containers, data-default, ghc, haskeline, kure, mtl, stm, template-haskell, text
Files
- examples/contents.txt +9/−2
- examples/fib-tuple/Fib.hs +5/−12
- hermit.cabal +15/−17
- src/Language/HERMIT/Context.hs +3/−0
- src/Language/HERMIT/GHC.hs +6/−0
- src/Language/HERMIT/Monad.hs +31/−22
- src/Language/HERMIT/Plugin.hs +9/−7
- src/Language/HERMIT/PrettyPrinter.hs +3/−47
- src/Language/HERMIT/PrettyPrinter/AST.hs +47/−45
- src/Language/HERMIT/PrettyPrinter/Clean.hs +137/−135
- src/Language/HERMIT/PrettyPrinter/GHC.hs +29/−29
- src/Language/HERMIT/PrettyPrinter/JSON.hs +47/−45
- src/Language/HERMIT/Primitive/Common.hs +2/−1
- src/Language/HERMIT/Primitive/Fold.hs +14/−14
- src/Language/HERMIT/Primitive/GHC.hs +13/−10
- src/Language/HERMIT/Primitive/Inline.hs +6/−1
- src/Language/HERMIT/Primitive/Local.hs +10/−9
- src/Language/HERMIT/Primitive/Local/Let.hs +34/−6
- src/Language/HERMIT/Primitive/New.hs +38/−35
- src/Language/HERMIT/Primitive/Unfold.hs +6/−5
- src/Language/HERMIT/Shell/Command.hs +0/−3
examples/contents.txt view
@@ -19,9 +19,11 @@ * Convert to CPS to avoid repeated pattern matching. -* In progress - stuck because "fold" won't fire.+* Completed. +* Interesting rewrites: abstract, fold + Fibonacci (Tupling) =================== @@ -118,9 +120,14 @@ Mean ==== +* Problem (and pen-and-paper calculation) provided by Jason Reich.+ * A non-WW tupling example (maybe it can be cast as WW, I'm not sure). -* In progress (stuck because HERMIT crashes).+* Completed.++* Interesting rewrites: abstract, remember, fold, let-intro, let-float, let-tuple+ Nub
examples/fib-tuple/Fib.hs view
@@ -1,8 +1,3 @@-{-# LANGUAGE TemplateHaskell #-}--- for criterion-import Criterion.Main-import Control.DeepSeq.TH- -- so we can fix-intro import Data.Function (fix) @@ -25,6 +20,10 @@ fromInt i | i < 0 = error "fromInt negative" | otherwise = S (fromInt (i-1)) +toInt :: Nat -> Int+toInt Z = 0+toInt (S n) = succ (toInt n)+ -- original fib definition fib :: Nat -> Nat fib Z = Z@@ -43,11 +42,5 @@ unwrap :: (Nat -> Nat) -> Nat -> (Nat, Nat) unwrap h n = (h n, h (S n)) --- for criterion-deriveNFData ''Nat- main :: IO ()-main = defaultMain- [ bench "15" $ nf fib (fromInt 15)- , bench "30" $ nf fib (fromInt 30)- ]+main = print $ toInt $ fib (fromInt 30)
hermit.cabal view
@@ -1,9 +1,7 @@ Name: hermit-Version: 0.1.1.1+Version: 0.1.2.0 Synopsis: Haskell Equational Reasoning Model-to-Implementation Tunnel Description:- Note: HERMIT is currently compatible with GHC 7.4.* only.- . HERMIT uses Haskell to express semi-formal models, efficient implementations, and provide a bridging DSL to describe via stepwise refinement the connection between@@ -40,12 +38,12 @@ . @ $ hermit Reverse.hs Reverse.hss resume- [starting HERMIT v0.1.1.1 on Reverse.hs]+ [starting HERMIT v0.1.2.0 on Reverse.hs] % ghc Reverse.hs -fforce-recomp -O2 -dcore-lint -fsimple-list-literals -fplugin=HERMIT -fplugin-opt=HERMIT:main:Main: -fplugin-opt=HERMIT:main:Main:resume [1 of 2] Compiling HList ( HList.hs, HList.o ) Loading package ghc-prim ... linking ... done. ...- Loading package hermit-0.1.1.1 ... linking ... done.+ Loading package hermit-0.1.2.0 ... linking ... done. [2 of 2] Compiling Main ( Reverse.hs, Reverse.o ) Linking Reverse ... $ ./Reverse@@ -56,12 +54,12 @@ . @ $ hermit Reverse.hs- [starting HERMIT v0.1.1.1 on Reverse.hs]+ [starting HERMIT v0.1.2.0 on Reverse.hs] % ghc Reverse.hs -fforce-recomp -O2 -dcore-lint -fsimple-list-literals -fplugin=HERMIT -fplugin-opt=HERMIT:main:Main: [1 of 2] Compiling HList ( HList.hs, HList.o ) Loading package ghc-prim ... linking ... done. ...- Loading package hermit-0.1.1.1 ... linking ... done.+ Loading package hermit-0.1.2.0 ... linking ... done. [2 of 2] Compiling Main ( Reverse.hs, Reverse.o ) module main:Main where \ \ rev ∷ ∀ a . [] a -> [] a@@ -127,18 +125,18 @@ Library ghc-options: -Wall -fno-warn-orphans Build-Depends: base >= 4 && < 5,- aeson >= 0.6.0.0,+ aeson >= 0.6.0.2, ansi-terminal >= 0.5.5,- containers >= 0.4.2.1,- data-default >= 0.4,- ghc == 7.4.*,- haskeline >= 0.6.4.7,- kure >= 2.4.1,+ containers >= 0.5.0.0,+ data-default >= 0.5.0,+ ghc == 7.6.*,+ haskeline >= 0.7.0.3,+ kure >= 2.4.2, marked-pretty >= 0.1,- mtl >= 2.0.1.0,- stm >= 2.2.0.1,- template-haskell >= 2.7.0.0,- text >= 0.11.1.13+ mtl >= 2.1.2,+ stm >= 2.4,+ template-haskell >= 2.8.0.0,+ text >= 0.11.2.3 default-language: Haskell2010
src/Language/HERMIT/Context.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE InstanceSigs #-}+ module Language.HERMIT.Context ( -- * HERMIT Bindings@@ -58,6 +60,7 @@ -- | The HERMIT context stores an 'AbsolutePath' to the current node in the tree. instance PathContext Context where+ contextPath :: Context -> AbsolutePath contextPath = hermitPath -- | Create the initial HERMIT 'Context' by providing a 'ModGuts'.
src/Language/HERMIT/GHC.hs view
@@ -2,6 +2,7 @@ ( -- | Things that have been copied from GHC, or imported directly, for various reasons. ppIdInfo+ , var2String , thRdrNameGuesses , name2THName , id2THName@@ -31,6 +32,7 @@ -------------------------------------------------------------------------- -- idName :: Id -> Name+-- varName :: Var -> Name -- nameOccName :: Name -> OccName -- occNameString :: OccName -> String -- getOccName :: NamedThing a => a -> OccName@@ -39,6 +41,10 @@ -- TH.nameBase :: TH.Name -> String -- TH.mkName :: String -> TH.Name++-- | Convert a variable to a neat string for printing.+var2String :: Var -> String+var2String = occNameString . nameOccName . varName -- | Converts a GHC 'Name' to a Template Haskell 'TH.Name', going via a 'String'. name2THName :: Name -> TH.Name
src/Language/HERMIT/Monad.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TupleSections, GADTs, KindSignatures #-}+{-# LANGUAGE TupleSections, GADTs, KindSignatures, InstanceSigs #-} module Language.HERMIT.Monad (@@ -80,29 +80,29 @@ ---------------------------------------------------------------------------- instance Functor HermitM where--- fmap :: (a -> b) -> HermitM a -> HermitM b- fmap = liftM+ fmap :: (a -> b) -> HermitM a -> HermitM b+ fmap = liftM instance Applicative HermitM where--- pure :: a -> HermitM a- pure = return+ pure :: a -> HermitM a+ pure = return --- (<*>) :: HermitM (a -> b) -> HermitM a -> HermitM b- (<*>) = ap+ (<*>) :: HermitM (a -> b) -> HermitM a -> HermitM b+ (<*>) = ap instance Monad HermitM where--- return :: a -> HermitM a- return a = HermitM $ \ _ s -> return (return (s,a))+ return :: a -> HermitM a+ return a = HermitM $ \ _ s -> return (return (s,a)) --- (>>=) :: HermitM a -> (a -> HermitM b) -> HermitM b- (HermitM gcm) >>= f = HermitM $ \ env -> gcm env >=> runKureMonad (\ (s', a) -> runHermitM (f a) env s') (return . fail)+ (>>=) :: HermitM a -> (a -> HermitM b) -> HermitM b+ (HermitM gcm) >>= f = HermitM $ \ env -> gcm env >=> runKureMonad (\ (s', a) -> runHermitM (f a) env s') (return . fail) --- fail :: String -> HermitM a- fail msg = HermitM $ \ _ _ -> return (fail msg)+ fail :: String -> HermitM a+ fail msg = HermitM $ \ _ _ -> return (fail msg) instance MonadCatch HermitM where--- catchM :: HermitM a -> (String -> HermitM a) -> HermitM a- (HermitM gcm) `catchM` f = HermitM $ \ env s -> gcm env s >>= runKureMonad (return.return) (\ msg -> runHermitM (f msg) env s)+ catchM :: HermitM a -> (String -> HermitM a) -> HermitM a+ (HermitM gcm) `catchM` f = HermitM $ \ env s -> gcm env s >>= runKureMonad (return.return) (\ msg -> runHermitM (f msg) env s) ---------------------------------------------------------------------------- @@ -112,20 +112,27 @@ return (return (s,a)) instance MonadIO HermitM where- liftIO = liftCoreM . liftIO+ liftIO :: IO a -> HermitM a+ liftIO = liftCoreM . liftIO instance MonadUnique HermitM where- getUniqueSupplyM = liftCoreM getUniqueSupplyM+ getUniqueSupplyM :: HermitM UniqSupply+ getUniqueSupplyM = liftCoreM getUniqueSupplyM instance MonadThings HermitM where- lookupThing = liftCoreM . lookupThing+ lookupThing :: Name -> HermitM TyThing+ lookupThing = liftCoreM . lookupThing +instance HasDynFlags HermitM where+ getDynFlags :: HermitM DynFlags+ getDynFlags = liftCoreM getDynFlags+ ---------------------------------------------------------------------------- newName :: String -> HermitM Name newName name = do uq <- getUniqueM- return $ mkSystemVarName uq $ mkFastString $ name+ return $ mkSystemVarName uq $ mkFastString $ name -- | Make a unique identifier for a specified type based on a provided name. newVarH :: String -> Type -> HermitM Id@@ -146,9 +153,9 @@ let name = nameMod $ getOccString b ty = idType b in- case (isTyVar b) of- True -> newTypeVarH name ty- _ -> newVarH name ty+ if isTyVar b+ then newTypeVarH name ty+ else newVarH name ty ---------------------------------------------------------------------------- @@ -161,3 +168,5 @@ mkHermitMEnv debugger = HermitMEnv { hs_debugChan = debugger }++----------------------------------------------------------------------------
src/Language/HERMIT/Plugin.hs view
@@ -22,21 +22,23 @@ -- This is a bit of a hack; otherwise we lose what we've not seen liftIO $ hSetBuffering stdout NoBuffering + dynFlags <- getDynFlags+ let- myPass = CoreDoPluginPass "HERMIT" $ modFilter hp opts+ myPass = CoreDoPluginPass "HERMIT" $ modFilter dynFlags hp opts -- at front, for now allPasses = myPass : todos return allPasses -- | Determine whether to act on this module, choose plugin pass.-modFilter :: HermitPass -> HermitPass-modFilter hp opts guts | null modOpts && not (null opts) = return guts -- don't process this module+modFilter :: DynFlags -> HermitPass -> HermitPass+modFilter dynFlags hp opts guts | null modOpts && not (null opts) = return guts -- don't process this module | otherwise = hp modOpts guts- where modOpts = filterOpts opts guts+ where modOpts = filterOpts dynFlags opts guts -- | Filter options to those pertaining to this module, stripping module prefix.-filterOpts :: [CommandLineOption] -> ModGuts -> [CommandLineOption]-filterOpts opts guts = [ drop len nm | nm <- opts, modName `isPrefixOf` nm ]- where modName = showSDoc (ppr $ mg_module guts)+filterOpts :: DynFlags -> [CommandLineOption] -> ModGuts -> [CommandLineOption]+filterOpts dynFlags opts guts = [ drop len nm | nm <- opts, modName `isPrefixOf` nm ]+ where modName = showPpr dynFlags $ mg_module guts len = length modName + 1 -- for the colon
src/Language/HERMIT/PrettyPrinter.hs view
@@ -240,7 +240,9 @@ where ppH :: (Outputable a) => PrettyH a- ppH = arr (PP.text . showSDoc . ppr)+ ppH = contextfreeT $ \e -> do+ dynFlags <- getDynFlags+ return $ PP.text $ showSDoc dynFlags $ ppr e ppModule :: PrettyH ModGuts ppModule = mg_module ^>> ppH@@ -249,52 +251,6 @@ ppDef = (\ (Def v e) -> (v,e)) ^>> ppH -- arr (PP.text . ppr . mg_module)---- Later, this will have depth, and other pretty print options.-class Show2 a where- show2 :: a -> String--instance Show2 Core where- show2 (ModGutsCore m) = show2 m- show2 (ProgramCore p) = show2 p- show2 (BindCore bd) = show2 bd- show2 (ExprCore e) = show2 e- show2 (AltCore a) = show2 a- show2 (DefCore a) = show2 a--instance Show2 ModGuts where- show2 modGuts =- "[ModGuts for " ++ showSDoc (ppr (mg_module modGuts)) ++ "]\n" ++- show (length (mg_binds modGuts)) ++ " binding group(s)\n" ++- show (length (mg_rules modGuts)) ++ " rule(s)\n" ++- showSDoc (ppr (mg_rules modGuts))---instance Show2 CoreProgram where- show2 codeProg =- "[Code Program]\n" ++- showSDoc (ppr codeProg)--instance Show2 CoreExpr where- show2 expr =- "[Expr]\n" ++- showSDoc (ppr expr)--instance Show2 CoreAlt where- show2 alt =- "[alt]\n" ++- showSDoc (ppr alt)---instance Show2 CoreBind where- show2 bind =- "[Bind]\n" ++- showSDoc (ppr bind)--instance Show2 CoreDef where- show2 (Def v e) =- "[Def]\n" ++- showSDoc (ppr v) ++ " = " ++ showSDoc (ppr e) --- Moving the renders back into the core hermit
src/Language/HERMIT/PrettyPrinter/AST.hs view
@@ -22,55 +22,57 @@ hlist = listify (<+>) corePrettyH :: PrettyOptions -> PrettyH Core-corePrettyH opts =- promoteT (ppCoreExpr :: PrettyH GHC.CoreExpr)- <+ promoteT (ppProgram :: PrettyH GHC.CoreProgram)- <+ promoteT (ppCoreBind :: PrettyH GHC.CoreBind)- <+ promoteT (ppCoreDef :: PrettyH CoreDef)- <+ promoteT (ppModGuts :: PrettyH GHC.ModGuts)- <+ promoteT (ppCoreAlt :: PrettyH GHC.CoreAlt)- where- hideNotes = po_notes opts+corePrettyH opts = do+ dynFlags <- constT GHC.getDynFlags - -- Use for any GHC structure, the 'showSDoc' prefix is to remind us- -- that we are eliding infomation here.- ppSDoc :: (GHC.Outputable a) => a -> MDoc b- ppSDoc = toDoc . (if hideNotes then id else ("showSDoc: " ++)) . GHC.showSDoc . GHC.ppr- where toDoc s | any isSpace s = parens (text s)- | otherwise = text s+ let hideNotes = po_notes opts - ppModGuts :: PrettyH GHC.ModGuts- ppModGuts = arr (ppSDoc . GHC.mg_module)+ -- Use for any GHC structure, the 'showSDoc' prefix is to remind us+ -- that we are eliding infomation here.+ ppSDoc :: (GHC.Outputable a) => a -> MDoc b+ ppSDoc = toDoc . (if hideNotes then id else ("showSDoc: " ++)) . GHC.showSDoc dynFlags . GHC.ppr+ where toDoc s | any isSpace s = parens (text s)+ | otherwise = text s - -- DocH is not a monoid, so we can't use listT here- ppProgram :: PrettyH GHC.CoreProgram -- CoreProgram = [CoreBind]- ppProgram = translate $ \ c -> fmap vlist . sequenceA . map (apply ppCoreBind c)+ ppModGuts :: PrettyH GHC.ModGuts+ ppModGuts = arr (ppSDoc . GHC.mg_module) - ppCoreExpr :: PrettyH GHC.CoreExpr- ppCoreExpr = varT (\i -> text "Var" <+> varColor (ppSDoc i))- <+ litT (\i -> text "Lit" <+> ppSDoc i)- <+ appT ppCoreExpr ppCoreExpr (\ a b -> text "App" $$ nest 2 (cat [parens a, parens b]))- <+ lamT ppCoreExpr (\ v e -> text "Lam" <+> varColor (ppSDoc v) $$ nest 2 (parens e))- <+ letT ppCoreBind ppCoreExpr (\ b e -> text "Let" $$ nest 2 (cat [parens b, parens e]))- <+ caseT ppCoreExpr (const ppCoreAlt) (\s b ty alts ->- text "Case" $$ nest 2 (parens s)- $$ nest 2 (ppSDoc b)- $$ nest 2 (ppSDoc ty)- $$ nest 2 (vlist alts))- <+ castT ppCoreExpr (\e co -> text "Cast" $$ nest 2 ((parens e) <+> ppSDoc co))- <+ tickT ppCoreExpr (\i e -> text "Tick" $$ nest 2 (ppSDoc i <+> parens e))- <+ typeT (\ty -> text "Type" <+> nest 2 (ppSDoc ty))- <+ coercionT (\co -> text "Coercion" $$ nest 2 (ppSDoc co))+ -- DocH is not a monoid, so we can't use listT here+ ppProgram :: PrettyH GHC.CoreProgram -- CoreProgram = [CoreBind]+ ppProgram = translate $ \ c -> fmap vlist . sequenceA . map (apply ppCoreBind c) - ppCoreBind :: PrettyH GHC.CoreBind- ppCoreBind = nonRecT ppCoreExpr (\i e -> text "NonRec" <+> ppSDoc i $$ nest 2 (parens e))- <+ recT (const ppCoreDef) (\bnds -> text "Rec" $$ nest 2 (vlist bnds))+ ppCoreExpr :: PrettyH GHC.CoreExpr+ ppCoreExpr = varT (\i -> text "Var" <+> varColor (ppSDoc i))+ <+ litT (\i -> text "Lit" <+> ppSDoc i)+ <+ appT ppCoreExpr ppCoreExpr (\ a b -> text "App" $$ nest 2 (cat [parens a, parens b]))+ <+ lamT ppCoreExpr (\ v e -> text "Lam" <+> varColor (ppSDoc v) $$ nest 2 (parens e))+ <+ letT ppCoreBind ppCoreExpr (\ b e -> text "Let" $$ nest 2 (cat [parens b, parens e]))+ <+ caseT ppCoreExpr (const ppCoreAlt) (\s b ty alts ->+ text "Case" $$ nest 2 (parens s)+ $$ nest 2 (ppSDoc b)+ $$ nest 2 (ppSDoc ty)+ $$ nest 2 (vlist alts))+ <+ castT ppCoreExpr (\e co -> text "Cast" $$ nest 2 ((parens e) <+> ppSDoc co))+ <+ tickT ppCoreExpr (\i e -> text "Tick" $$ nest 2 (ppSDoc i <+> parens e))+ <+ typeT (\ty -> text "Type" <+> nest 2 (ppSDoc ty))+ <+ coercionT (\co -> text "Coercion" $$ nest 2 (ppSDoc co)) - ppCoreAlt :: PrettyH GHC.CoreAlt- ppCoreAlt = altT ppCoreExpr $ \ con ids e -> text "Alt" <+> ppSDoc con- <+> (hlist $ map ppSDoc ids)- $$ nest 2 (parens e)+ ppCoreBind :: PrettyH GHC.CoreBind+ ppCoreBind = nonRecT ppCoreExpr (\i e -> text "NonRec" <+> ppSDoc i $$ nest 2 (parens e))+ <+ recT (const ppCoreDef) (\bnds -> text "Rec" $$ nest 2 (vlist bnds)) - -- GHC uses a tuple, which we print here. The CoreDef type is our doing.- ppCoreDef :: PrettyH CoreDef- ppCoreDef = defT ppCoreExpr $ \ i e -> parens $ varColor (ppSDoc i) <> text "," <> e+ ppCoreAlt :: PrettyH GHC.CoreAlt+ ppCoreAlt = altT ppCoreExpr $ \ con ids e -> text "Alt" <+> ppSDoc con+ <+> (hlist $ map ppSDoc ids)+ $$ nest 2 (parens e)++ -- GHC uses a tuple, which we print here. The CoreDef type is our doing.+ ppCoreDef :: PrettyH CoreDef+ ppCoreDef = defT ppCoreExpr $ \ i e -> parens $ varColor (ppSDoc i) <> text "," <> e++ promoteT (ppCoreExpr :: PrettyH GHC.CoreExpr)+ <+ promoteT (ppProgram :: PrettyH GHC.CoreProgram)+ <+ promoteT (ppCoreBind :: PrettyH GHC.CoreBind)+ <+ promoteT (ppCoreDef :: PrettyH CoreDef)+ <+ promoteT (ppModGuts :: PrettyH GHC.ModGuts)+ <+ promoteT (ppCoreAlt :: PrettyH GHC.CoreAlt)
src/Language/HERMIT/PrettyPrinter/Clean.hs view
@@ -66,161 +66,163 @@ typeBindSymbol = markColor TypeColor (specialFont $ char $ renderSpecial TypeBindSymbol) corePrettyH :: PrettyOptions -> PrettyH Core-corePrettyH opts =- promoteT (ppCoreExpr :: PrettyH GHC.CoreExpr)- <+ promoteT (ppProgram :: PrettyH GHC.CoreProgram)- <+ promoteT (ppCoreBind :: PrettyH GHC.CoreBind)- <+ promoteT (ppCoreDef :: PrettyH CoreDef)- <+ promoteT (ppModGuts :: PrettyH GHC.ModGuts)- <+ promoteT (ppCoreAlt :: PrettyH GHC.CoreAlt)- where- hideNotes = True+corePrettyH opts = do+ dynFlags <- constT GHC.getDynFlags - ppVar :: GHC.Var -> DocH- ppVar = ppName . GHC.varName+ let hideNotes = True - ppName :: GHC.Name -> DocH- ppName nm- | isInfix name = ppParens $ varColor $ text name- | otherwise = varColor $ text name- where name = GHC.occNameString $ GHC.nameOccName $ nm- isInfix = all (\ n -> n `elem` "!@#$%^&*-._+=:?/\\<>'")+ ppVar :: GHC.Var -> DocH+ ppVar = ppName . GHC.varName + ppName :: GHC.Name -> DocH+ ppName nm+ | isInfix name = ppParens $ varColor $ text name+ | otherwise = varColor $ text name+ where name = GHC.occNameString $ GHC.nameOccName $ nm+ isInfix = all (\ n -> n `elem` "!@#$%^&*-._+=:?/\\<>'") - -- binders are vars that is bound by lambda or case, etc.- ppBinder :: GHC.Var -> Maybe DocH- ppBinder var = case po_exprTypes opts of- Abstract | GHC.isTyVar var -> Just $ typeBindSymbol- Omit | GHC.isTyVar var -> Nothing- _ -> Just $ ppVar var - ppIdBinder :: GHC.Id -> DocH- ppIdBinder var = ppVar var+ -- binders are vars that is bound by lambda or case, etc.+ ppBinder :: GHC.Var -> Maybe DocH+ ppBinder var = case po_exprTypes opts of+ Abstract | GHC.isTyVar var -> Just $ typeBindSymbol+ Omit | GHC.isTyVar var -> Nothing+ _ -> Just $ ppVar var - -- Use for any GHC structure, the 'showSDoc' prefix is to remind us- -- that we are eliding infomation here.- ppSDoc :: (GHC.Outputable a) => a -> MDoc b- ppSDoc = toDoc . (if hideNotes then id else ("showSDoc: " ++)) . GHC.showSDoc . GHC.ppr- where toDoc s | any isSpace s = parens (text s)- | otherwise = text s+ ppIdBinder :: GHC.Id -> DocH+ ppIdBinder var = ppVar var - ppModGuts :: PrettyH GHC.ModGuts- ppModGuts = arr $ \ m -> hang (keyword "module" <+> ppSDoc (GHC.mg_module m) <+> keyword "where") 2- (vcat [ (ppIdBinder v <+> specialSymbol TypeOfSymbol <+> ppCoreType (GHC.idType v))- | bnd <- GHC.mg_binds m- , v <- case bnd of- GHC.NonRec f _ -> [f]- GHC.Rec bnds -> map fst bnds- ])+ -- Use for any GHC structure, the 'showSDoc' prefix is to remind us+ -- that we are eliding infomation here.+ ppSDoc :: (GHC.Outputable a) => a -> MDoc b+ ppSDoc = toDoc . (if hideNotes then id else ("showSDoc: " ++)) . GHC.showSDoc dynFlags . GHC.ppr+ where toDoc s | any isSpace s = parens (text s)+ | otherwise = text s - -- DocH is not a monoid, so we can't use listT here- ppProgram :: PrettyH GHC.CoreProgram -- CoreProgram = [CoreBind]- ppProgram = translate $ \ c -> fmap vcat . sequenceA . map (apply ppCoreBind c)+ ppModGuts :: PrettyH GHC.ModGuts+ ppModGuts = arr $ \ m -> hang (keyword "module" <+> ppSDoc (GHC.mg_module m) <+> keyword "where") 2+ (vcat [ (ppIdBinder v <+> specialSymbol TypeOfSymbol <+> ppCoreType (GHC.idType v))+ | bnd <- GHC.mg_binds m+ , v <- case bnd of+ GHC.NonRec f _ -> [f]+ GHC.Rec bnds -> map fst bnds+ ]) - ppCoreExpr :: PrettyH GHC.CoreExpr- ppCoreExpr = ppCoreExprR >>^ normalExpr+ -- DocH is not a monoid, so we can't use listT here+ ppProgram :: PrettyH GHC.CoreProgram -- CoreProgram = [CoreBind]+ ppProgram = translate $ \ c -> fmap vcat . sequenceA . map (apply ppCoreBind c) - appendArg xs (RetEmpty) = xs- appendArg xs e = xs ++ [e]+ ppCoreExpr :: PrettyH GHC.CoreExpr+ ppCoreExpr = ppCoreExprR >>^ normalExpr - appendBind Nothing xs = xs- appendBind (Just v) xs = v : xs+ appendArg xs (RetEmpty) = xs+ appendArg xs e = xs ++ [e] - ppCoreExprR :: TranslateH GHC.CoreExpr RetExpr- ppCoreExprR = do- ret <- ppCoreExprPR- absPath <- absPathT- return $ ret (rootPath absPath)+ appendBind Nothing xs = xs+ appendBind (Just v) xs = v : xs - ppCoreExprPR :: TranslateH GHC.CoreExpr (Path -> RetExpr)- ppCoreExprPR = lamT ppCoreExprR (\ v e _ -> case e of- RetLam vs e0 -> RetLam (appendBind (ppBinder v) vs) e0- _ -> RetLam (appendBind (ppBinder v) []) (normalExpr e))+ ppCoreExprR :: TranslateH GHC.CoreExpr RetExpr+ ppCoreExprR = do+ ret <- ppCoreExprPR+ absPath <- absPathT+ return $ ret (rootPath absPath) - <+ letT ppCoreBind ppCoreExprR- (\ bd e _ -> case e of- RetLet vs e0 -> RetLet (bd : vs) e0- _ -> RetLet [bd] (normalExpr e))- -- HACKs-{-- <+ (acceptR (\ e -> case e of- GHC.App (GHC.Var v) (GHC.Type t) | po_exprTypes opts == Abstract -> True- _ -> False) >>>- (appT ppCoreExprR ppCoreExprR (\ (RetAtom e1) (RetAtom e2) ->- RetAtom (e1 <+> e2))))--}- <+ (acceptR (\ e -> case e of- GHC.App (GHC.Type _) (GHC.Lam {}) | po_exprTypes opts == Omit -> True- GHC.App (GHC.App (GHC.Var _) (GHC.Type _)) (GHC.Lam {}) | po_exprTypes opts == Omit -> True- _ -> False) "TODO: add decent error message here" >>>- (appT ppCoreExprR ppCoreExprR (\ (RetAtom e1) (RetLam vs e0) _ ->- RetExpr $ hang (e1 <+>- symbol '(' <>- specialSymbol LambdaSymbol <+>- hsep vs <+>- specialSymbol RightArrowSymbol) 2 (e0 <> symbol ')')))+ ppCoreExprPR :: TranslateH GHC.CoreExpr (Path -> RetExpr)+ ppCoreExprPR = lamT ppCoreExprR (\ v e _ -> case e of+ RetLam vs e0 -> RetLam (appendBind (ppBinder v) vs) e0+ _ -> RetLam (appendBind (ppBinder v) []) (normalExpr e)) + <+ letT ppCoreBind ppCoreExprR+ (\ bd e _ -> case e of+ RetLet vs e0 -> RetLet (bd : vs) e0+ _ -> RetLet [bd] (normalExpr e))+ -- HACKs+ {-+ <+ (acceptR (\ e -> case e of+ GHC.App (GHC.Var v) (GHC.Type t) | po_exprTypes opts == Abstract -> True+ _ -> False) >>>+ (appT ppCoreExprR ppCoreExprR (\ (RetAtom e1) (RetAtom e2) ->+ RetAtom (e1 <+> e2))))+ -}+ <+ (acceptR (\ e -> case e of+ GHC.App (GHC.Type _) (GHC.Lam {}) | po_exprTypes opts == Omit -> True+ GHC.App (GHC.App (GHC.Var _) (GHC.Type _)) (GHC.Lam {}) | po_exprTypes opts == Omit -> True+ _ -> False) "TODO: add decent error message here" >>>+ (appT ppCoreExprR ppCoreExprR (\ (RetAtom e1) (RetLam vs e0) _ ->+ RetExpr $ hang (e1 <+>+ symbol '(' <>+ specialSymbol LambdaSymbol <+>+ hsep vs <+>+ specialSymbol RightArrowSymbol) 2 (e0 <> symbol ')'))) - ) - <+ appT ppCoreExprR ppCoreExprR- (\ e1 e2 _ -> case e1 of- RetApp f xs -> RetApp f (appendArg xs e2)- _ -> case e2 of -- if our only args are types, and they are omitted, don't paren- RetEmpty -> e1- args -> RetApp (atomExpr e1) (appendArg [] args))- <+ varT (\ i p -> RetAtom (attrP p $ ppVar i))- <+ litT (\ i p -> RetAtom (attrP p $ ppSDoc i))- <+ typeT (\ t p -> case po_exprTypes opts of- Show -> RetAtom (attrP p $ ppCoreType t)- Abstract -> RetAtom (attrP p $ typeSymbol)- Omit -> RetEmpty)- <+ (ppCoreExpr0 >>^ \ e p -> RetExpr (attrP p e))+ ) - ppCoreType :: GHC.Type -> DocH- ppCoreType = normalExpr . go- where go (TyVarTy v) = RetAtom $ ppVar v- go (AppTy t1 t2) = RetExpr $ ppCoreType t1 <+> ppCoreType t2- go (TyConApp tyCon tys)- | GHC.isFunTyCon tyCon, [ty1,ty2] <- tys = go (FunTy ty1 ty2)- | GHC.isTupleTyCon tyCon = case map ppCoreType tys of- [] -> RetAtom $ text "()"- ds -> RetExpr $ text "(" <> (foldr1 (\d r -> d <> text "," <+> r) ds) <> text ")"- | otherwise = RetAtom $ ppName (GHC.getName tyCon) <+> sep (map ppCoreType tys) -- has spaces, but we never want parens- go (FunTy ty1 ty2) = RetExpr $ atomExpr (go ty1) <+> text "->" <+> ppCoreType ty2- go (ForAllTy v ty) = RetExpr $ specialSymbol ForallSymbol <+> ppVar v <+> symbol '.' <+> ppCoreType ty+ <+ appT ppCoreExprR ppCoreExprR+ (\ e1 e2 _ -> case e1 of+ RetApp f xs -> RetApp f (appendArg xs e2)+ _ -> case e2 of -- if our only args are types, and they are omitted, don't paren+ RetEmpty -> e1+ args -> RetApp (atomExpr e1) (appendArg [] args))+ <+ varT (\ i p -> RetAtom (attrP p $ ppVar i))+ <+ litT (\ i p -> RetAtom (attrP p $ ppSDoc i))+ <+ typeT (\ t p -> case po_exprTypes opts of+ Show -> RetAtom (attrP p $ ppCoreType t)+ Abstract -> RetAtom (attrP p $ typeSymbol)+ Omit -> RetEmpty)+ <+ (ppCoreExpr0 >>^ \ e p -> RetExpr (attrP p e)) - ppCoreExpr0 :: PrettyH GHC.CoreExpr- ppCoreExpr0 = caseT ppCoreExpr (const ppCoreAlt) (\ s b _ty alts ->- (keywordColor (text "case") <+> s <+> keywordColor (text "of") <+> ppIdBinder b) $$- nest 2 (vcat alts))- <+ castT ppCoreExpr (\e co -> text "Cast" $$ nest 2 ((parens e) <+> ppSDoc co))- <+ tickT ppCoreExpr (\i e -> text "Tick" $$ nest 2 (ppSDoc i <+> parens e))--- <+ typeT (\ty -> text "Type" <+> nest 2 (ppSDoc ty))- <+ coercionT (\co -> text "Coercion" $$ nest 2 (ppSDoc co))+ ppCoreType :: GHC.Type -> DocH+ ppCoreType = normalExpr . go+ where go (TyVarTy v) = RetAtom $ ppVar v+ go (AppTy t1 t2) = RetExpr $ ppCoreType t1 <+> ppCoreType t2+ go (TyConApp tyCon tys)+ | GHC.isFunTyCon tyCon, [ty1,ty2] <- tys = go (FunTy ty1 ty2)+ | GHC.isTupleTyCon tyCon = case map ppCoreType tys of+ [] -> RetAtom $ text "()"+ ds -> RetExpr $ text "(" <> (foldr1 (\d r -> d <> text "," <+> r) ds) <> text ")"+ | otherwise = RetAtom $ ppName (GHC.getName tyCon) <+> sep (map ppCoreType tys) -- has spaces, but we never want parens+ go (FunTy ty1 ty2) = RetExpr $ atomExpr (go ty1) <+> text "->" <+> ppCoreType ty2+ go (ForAllTy v ty) = RetExpr $ specialSymbol ForallSymbol <+> ppVar v <+> symbol '.' <+> ppCoreType ty - ppCoreBind :: PrettyH GHC.CoreBind- ppCoreBind = nonRecT ppCoreExprR ppDefFun- <+ recT (const ppCoreDef) (\ bnds -> keywordColor (text "rec") <+> vcat bnds)+ ppCoreExpr0 :: PrettyH GHC.CoreExpr+ ppCoreExpr0 = caseT ppCoreExpr (const ppCoreAlt) (\ s b _ty alts ->+ (keywordColor (text "case") <+> s <+> keywordColor (text "of") <+> ppIdBinder b) $$+ nest 2 (vcat alts))+ <+ castT ppCoreExpr (\e co -> text "Cast" $$ nest 2 ((parens e) <+> ppSDoc co))+ <+ tickT ppCoreExpr (\i e -> text "Tick" $$ nest 2 (ppSDoc i <+> parens e))+ -- <+ typeT (\ty -> text "Type" <+> nest 2 (ppSDoc ty))+ <+ coercionT (\co -> text "Coercion" $$ nest 2 (ppSDoc co)) - ppCoreAlt :: PrettyH GHC.CoreAlt- ppCoreAlt = altT ppCoreExpr $ \ con ids e -> case con of- GHC.DataAlt dcon -> hang (ppName (GHC.dataConName dcon) <+> ppIds ids) 2 e- GHC.LitAlt lit -> hang (ppSDoc lit <+> ppIds ids) 2 e- GHC.DEFAULT -> symbol '_' <+> ppIds ids <+> e- where- ppIds ids | null ids = specialSymbol RightArrowSymbol- | otherwise = hsep (map ppIdBinder ids) <+> specialSymbol RightArrowSymbol+ ppCoreBind :: PrettyH GHC.CoreBind+ ppCoreBind = nonRecT ppCoreExprR ppDefFun+ <+ recT (const ppCoreDef) (\ bnds -> keywordColor (text "rec") <+> vcat bnds) - -- GHC uses a tuple, which we print here. The CoreDef type is our doing.- ppCoreDef :: PrettyH CoreDef- ppCoreDef = defT ppCoreExprR ppDefFun+ ppCoreAlt :: PrettyH GHC.CoreAlt+ ppCoreAlt = altT ppCoreExpr $ \ con ids e -> case con of+ GHC.DataAlt dcon -> hang (ppName (GHC.dataConName dcon) <+> ppIds ids) 2 e+ GHC.LitAlt lit -> hang (ppSDoc lit <+> ppIds ids) 2 e+ GHC.DEFAULT -> symbol '_' <+> ppIds ids <+> e+ where+ ppIds ids | null ids = specialSymbol RightArrowSymbol+ | otherwise = hsep (map ppIdBinder ids) <+> specialSymbol RightArrowSymbol - ppDefFun :: GHC.Id -> RetExpr -> DocH- ppDefFun i e = case e of- RetLam vs e0 -> hang (pre <+> specialSymbol LambdaSymbol <+> hsep vs <+> specialSymbol RightArrowSymbol) 2 e0- _ -> hang pre 2 (normalExpr e)- where- pre = case ppBinder i of- Nothing -> empty- Just p -> p <+> symbol '='+ -- GHC uses a tuple, which we print here. The CoreDef type is our doing.+ ppCoreDef :: PrettyH CoreDef+ ppCoreDef = defT ppCoreExprR ppDefFun++ ppDefFun :: GHC.Id -> RetExpr -> DocH+ ppDefFun i e = case e of+ RetLam vs e0 -> hang (pre <+> specialSymbol LambdaSymbol <+> hsep vs <+> specialSymbol RightArrowSymbol) 2 e0+ _ -> hang pre 2 (normalExpr e)+ where+ pre = case ppBinder i of+ Nothing -> empty+ Just p -> p <+> symbol '='++ promoteT (ppCoreExpr :: PrettyH GHC.CoreExpr)+ <+ promoteT (ppProgram :: PrettyH GHC.CoreProgram)+ <+ promoteT (ppCoreBind :: PrettyH GHC.CoreBind)+ <+ promoteT (ppCoreDef :: PrettyH CoreDef)+ <+ promoteT (ppModGuts :: PrettyH GHC.ModGuts)+ <+ promoteT (ppCoreAlt :: PrettyH GHC.CoreAlt)
src/Language/HERMIT/PrettyPrinter/GHC.hs view
@@ -21,39 +21,39 @@ hlist = listify (<+>) corePrettyH :: PrettyOptions -> PrettyH Core-corePrettyH opts =- promoteT (ppCoreExpr :: PrettyH GHC.CoreExpr)- <+ promoteT (ppProgram :: PrettyH GHC.CoreProgram)- <+ promoteT (ppCoreBind :: PrettyH GHC.CoreBind)- <+ promoteT (ppCoreDef :: PrettyH CoreDef)- <+ promoteT (ppModGuts :: PrettyH GHC.ModGuts)- <+ promoteT (ppCoreAlt :: PrettyH GHC.CoreAlt)- where- hideNotes = po_notes opts+corePrettyH opts = do+ dynFlags <- constT GHC.getDynFlags - -- Use for any GHC structure, the 'showSDoc' prefix is to remind us- -- that we are eliding infomation here.- ppSDoc :: (GHC.Outputable a) => a -> MDoc b- ppSDoc = toDoc . (if hideNotes then id else ("showSDoc: " ++)) . GHC.showSDoc . GHC.ppr- where toDoc s | any isSpace s = parens (text s)- | otherwise = text s+ let hideNotes = po_notes opts - ppModGuts :: PrettyH GHC.ModGuts- ppModGuts = arr (ppSDoc . GHC.mg_binds)+ -- Use for any GHC structure, the 'showSDoc' prefix is to remind us+ -- that we are eliding infomation here.+ ppSDoc :: (GHC.Outputable a) => a -> MDoc b+ ppSDoc = toDoc . (if hideNotes then id else ("showSDoc: " ++)) . GHC.showSDoc dynFlags . GHC.ppr+ where toDoc s | any isSpace s = parens (text s)+ | otherwise = text s - -- DocH is not a monoid, so we can't use listT here- ppProgram :: PrettyH GHC.CoreProgram- ppProgram = arr ppSDoc+ ppModGuts :: PrettyH GHC.ModGuts+ ppModGuts = arr (ppSDoc . GHC.mg_binds) - ppCoreExpr :: PrettyH GHC.CoreExpr- ppCoreExpr = arr ppSDoc+ ppProgram :: PrettyH GHC.CoreProgram+ ppProgram = arr ppSDoc - ppCoreBind :: PrettyH GHC.CoreBind- ppCoreBind = arr ppSDoc+ ppCoreExpr :: PrettyH GHC.CoreExpr+ ppCoreExpr = arr ppSDoc - ppCoreAlt :: PrettyH GHC.CoreAlt- ppCoreAlt = arr ppSDoc+ ppCoreBind :: PrettyH GHC.CoreBind+ ppCoreBind = arr ppSDoc - -- GHC uses a tuple, which we print here. The CoreDef type is our doing.- ppCoreDef :: PrettyH CoreDef- ppCoreDef = defT ppCoreExpr $ \ i e -> ppSDoc i <> text "=" <> e+ ppCoreAlt :: PrettyH GHC.CoreAlt+ ppCoreAlt = arr ppSDoc++ ppCoreDef :: PrettyH CoreDef+ ppCoreDef = defT ppCoreExpr $ \ i e -> ppSDoc i <> text "=" <> e++ promoteT (ppCoreExpr :: PrettyH GHC.CoreExpr)+ <+ promoteT (ppProgram :: PrettyH GHC.CoreProgram)+ <+ promoteT (ppCoreBind :: PrettyH GHC.CoreBind)+ <+ promoteT (ppCoreDef :: PrettyH CoreDef)+ <+ promoteT (ppModGuts :: PrettyH GHC.ModGuts)+ <+ promoteT (ppCoreAlt :: PrettyH GHC.CoreAlt)
src/Language/HERMIT/PrettyPrinter/JSON.hs view
@@ -13,55 +13,57 @@ import Language.HERMIT.PrettyPrinter corePrettyH :: PrettyOptions -> TranslateH Core Value-corePrettyH _opts =- promoteT ppCoreExpr- <+ promoteT ppProgram- <+ promoteT ppCoreBind- <+ promoteT ppCoreDef- <+ promoteT ppModGuts- <+ promoteT ppCoreAlt- where- mkCon :: String -> Pair- mkCon con = "con" .= con+corePrettyH _opts = do+ dynFlags <- constT GHC.getDynFlags - -- Use for any GHC structure, the 'showSDoc' prefix is to remind us- -- that we are eliding infomation here.- ppSDoc :: (GHC.Outputable a) => a -> Value- ppSDoc = String . T.pack . GHC.showSDoc . GHC.ppr+ let mkCon :: String -> Pair+ mkCon con = "con" .= con - ppModGuts :: TranslateH GHC.ModGuts Value- ppModGuts = arr (ppSDoc . GHC.mg_module)+ -- Use for any GHC structure, the 'showSDoc' prefix is to remind us+ -- that we are eliding infomation here.+ ppSDoc :: (GHC.Outputable a) => a -> Value+ ppSDoc = String . T.pack . GHC.showPpr dynFlags - -- DocH is not a monoid, so we can't use listT here- ppProgram :: TranslateH GHC.CoreProgram Value -- CoreProgram = [CoreBind]- ppProgram = translate $ \ c -> fmap toJSON . mapM (apply ppCoreBind c)+ ppModGuts :: TranslateH GHC.ModGuts Value+ ppModGuts = arr (ppSDoc . GHC.mg_module) - ppCoreExpr :: TranslateH GHC.CoreExpr Value- ppCoreExpr = varT (\i -> object [mkCon "Var", "value" .= ppSDoc i])- <+ litT (\i -> object [mkCon "Lit", "value" .= ppSDoc i])- <+ appT ppCoreExpr ppCoreExpr (\ a b -> object [mkCon "App", "lhs" .= a, "rhs" .= b])- <+ lamT ppCoreExpr (\ v e -> object [mkCon "Lam", "var" .= ppSDoc v, "body" .= e])- <+ letT ppCoreBind ppCoreExpr (\ b e -> object [mkCon "Let", "binds" .= b, "exp" .= e])- <+ caseT ppCoreExpr (const ppCoreAlt) (\s b ty alts ->- object [ mkCon "Case"- , "s" .= s- , "caseBndr" .= ppSDoc b- , "type" .= ppSDoc ty- , "alts" .= alts ])- <+ castT ppCoreExpr (\e co -> object [mkCon "Cast", "exp" .= e, "cast" .= ppSDoc co])- <+ tickT ppCoreExpr (\i e -> object [mkCon "Tick", "tick" .= ppSDoc i, "exp" .= e])- <+ typeT (\ty -> object [mkCon "Type", "type" .= ppSDoc ty])- <+ coercionT (\co -> object [mkCon "Coercion", "coercion" .= ppSDoc co])+ -- DocH is not a monoid, so we can't use listT here+ ppProgram :: TranslateH GHC.CoreProgram Value -- CoreProgram = [CoreBind]+ ppProgram = translate $ \ c -> fmap toJSON . mapM (apply ppCoreBind c) - ppCoreBind :: TranslateH GHC.CoreBind Value- ppCoreBind = nonRecT ppCoreExpr (\i e -> object [mkCon "NonRec", "var" .= ppSDoc i, "exp" .= e])- <+ recT (const ppCoreDef) (\bnds -> object [mkCon "Rec", "binds" .= bnds])+ ppCoreExpr :: TranslateH GHC.CoreExpr Value+ ppCoreExpr = varT (\i -> object [mkCon "Var", "value" .= ppSDoc i])+ <+ litT (\i -> object [mkCon "Lit", "value" .= ppSDoc i])+ <+ appT ppCoreExpr ppCoreExpr (\ a b -> object [mkCon "App", "lhs" .= a, "rhs" .= b])+ <+ lamT ppCoreExpr (\ v e -> object [mkCon "Lam", "var" .= ppSDoc v, "body" .= e])+ <+ letT ppCoreBind ppCoreExpr (\ b e -> object [mkCon "Let", "binds" .= b, "exp" .= e])+ <+ caseT ppCoreExpr (const ppCoreAlt) (\s b ty alts ->+ object [ mkCon "Case"+ , "s" .= s+ , "caseBndr" .= ppSDoc b+ , "type" .= ppSDoc ty+ , "alts" .= alts ])+ <+ castT ppCoreExpr (\e co -> object [mkCon "Cast", "exp" .= e, "cast" .= ppSDoc co])+ <+ tickT ppCoreExpr (\i e -> object [mkCon "Tick", "tick" .= ppSDoc i, "exp" .= e])+ <+ typeT (\ty -> object [mkCon "Type", "type" .= ppSDoc ty])+ <+ coercionT (\co -> object [mkCon "Coercion", "coercion" .= ppSDoc co]) - ppCoreAlt :: TranslateH GHC.CoreAlt Value- ppCoreAlt = altT ppCoreExpr $ \ con ids e -> object [ mkCon "Alt"- , "altcon" .= ppSDoc con- , "ids" .= map ppSDoc ids- , "exp" .= e ]+ ppCoreBind :: TranslateH GHC.CoreBind Value+ ppCoreBind = nonRecT ppCoreExpr (\i e -> object [mkCon "NonRec", "var" .= ppSDoc i, "exp" .= e])+ <+ recT (const ppCoreDef) (\bnds -> object [mkCon "Rec", "binds" .= bnds]) - ppCoreDef :: TranslateH CoreDef Value- ppCoreDef = defT ppCoreExpr $ \ i e -> object [mkCon "CoreDef", "var" .= ppSDoc i, "exp" .= e]+ ppCoreAlt :: TranslateH GHC.CoreAlt Value+ ppCoreAlt = altT ppCoreExpr $ \ con ids e -> object [ mkCon "Alt"+ , "altcon" .= ppSDoc con+ , "ids" .= map ppSDoc ids+ , "exp" .= e ]++ ppCoreDef :: TranslateH CoreDef Value+ ppCoreDef = defT ppCoreExpr $ \ i e -> object [mkCon "CoreDef", "var" .= ppSDoc i, "exp" .= e]++ promoteT ppCoreExpr+ <+ promoteT ppProgram+ <+ promoteT ppCoreBind+ <+ promoteT ppCoreDef+ <+ promoteT ppModGuts+ <+ promoteT ppCoreAlt
src/Language/HERMIT/Primitive/Common.hs view
@@ -61,7 +61,8 @@ -- This implementation fails for any expression that is not a Let. -- This specific argument matching is required where it is used in Local/Let.hs and Local/Case.hs letVarsT :: TranslateH CoreExpr [Var]-letVarsT = do Let bs _ <- idR+letVarsT = setFailMsg "Not a Let expression." $+ do Let bs _ <- idR return (bindings bs) -- | List of the list of Ids bound by each case alternative
src/Language/HERMIT/Primitive/Fold.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE ScopedTypeVariables, TypeFamilies, FlexibleContexts, TupleSections #-} module Language.HERMIT.Primitive.Fold ( externals , foldR@@ -10,6 +9,7 @@ import Control.Applicative import Control.Monad +import Data.List (intercalate) import qualified Data.Map as Map import Language.HERMIT.Monad@@ -50,18 +50,20 @@ stashFoldR :: String -> RewriteH CoreExpr stashFoldR label = prefixFailMsg "Fold failed: " $- contextfreeT $ \ e -> do- Def i rhs <- lookupDef label- maybe (fail "no match.")- return- (fold i rhs e)+ translate $ \ c e -> do+ Def i rhs <- lookupDef label+ guardMsg (inScope c i) $ var2String i ++ " is not in scope.\n(A common cause of this error is trying to fold a recursive call while being in the body of a non-recursive definition. This can be resolved by calling \"nonrec-to-rec\" on the non-recursive binding group.)"+ maybe (fail "no match.")+ return+ (fold i rhs e) foldR :: TH.Name -> RewriteH CoreExpr foldR nm = prefixFailMsg "Fold failed: " $ translate $ \ c e -> do- i <- case filter (\i -> nm `cmpTHName2Id` i) $ Map.keys (hermitBindings c) of+ i <- case filter (cmpTHName2Id nm) $ Map.keys (hermitBindings c) of+ [] -> fail "cannot find name." [i] -> return i- _ -> fail "cannot find name."+ is -> fail $ "multiple names match: " ++ intercalate ", " (map var2String is) either fail (\(rhs,_d) -> maybe (fail "no match.") return@@ -104,7 +106,6 @@ -> CoreExpr -- ^ pattern we are matching on -> CoreExpr -- ^ expression we are checking -> Maybe [(Var,CoreExpr)] -- ^ mapping of vars to expressions, or failure--- foldMatch vs as e e' | trace ("foldMatch: " ++ showPpr vs ++ " Alphas: " ++ showPpr as ++ "e:\n" ++ showPpr e ++ "\ne':\n" ++ showPpr e') False = undefined foldMatch vs as (Var i) e | i `elem` vs = return [(i,e)] | otherwise = case e of Var i' | maybe False (==i) (lookup i' as) -> return [(i,e)]@@ -129,9 +130,8 @@ y <- foldMatch vs' as' e e' return (concat x ++ y) foldMatch vs as (Tick t e) (Tick t' e') | t == t' = foldMatch vs as e e'--- TODO: showPpr hack in the rest of these! foldMatch vs as (Case s b ty alts) (Case s' b' ty' alts')- | (showPpr ty == showPpr ty') && (length alts == length alts') = do+ | (eqType ty ty') && (length alts == length alts') = do let as' = addAlpha b' b as x <- foldMatch vs as' s s' let vs' = filter (/=b) vs@@ -140,7 +140,7 @@ altMatch _ _ = Nothing y <- zipWithM altMatch alts alts' return (x ++ concat y)-foldMatch vs as (Cast e c) (Cast e' c') | showPpr c == showPpr c' = foldMatch vs as e e'-foldMatch _ _ (Type t) (Type t') | showPpr t == showPpr t' = return []-foldMatch _ _ (Coercion c) (Coercion c') | showPpr c == showPpr c' = return []+foldMatch vs as (Cast e c) (Cast e' c') | coreEqCoercion c c' = foldMatch vs as e e'+foldMatch _ _ (Type t) (Type t') | eqType t t' = return []+foldMatch _ _ (Coercion c) (Coercion c') | coreEqCoercion c c' = return [] foldMatch _ _ _ _ = Nothing
src/Language/HERMIT/Primitive/GHC.hs view
@@ -2,7 +2,6 @@ module Language.HERMIT.Primitive.GHC where import GhcPlugins hiding (empty)-import qualified Language.HERMIT.GHC as GHC import qualified OccurAnal import Control.Arrow import Control.Monad@@ -17,7 +16,7 @@ import Language.HERMIT.Monad import Language.HERMIT.External import Language.HERMIT.Context--- import Language.HERMIT.GHC+import qualified Language.HERMIT.GHC as GHC import qualified Language.Haskell.TH as TH -- import Debug.Trace@@ -157,15 +156,18 @@ -- | Output a list of all free variables in an expression. freeIdsQuery :: TranslateH CoreExpr String-freeIdsQuery = freeIdsT >>^ (("Free identifiers are: " ++) . showVars)+freeIdsQuery = do+ dynFlags <- constT getDynFlags+ frees <- freeIdsT+ return $ "Free identifiers are: " ++ showVars dynFlags frees -- | Show a human-readable version of a 'Var'.-showVar :: Var -> String-showVar = show . showSDoc . ppr+showVar :: DynFlags -> Var -> String+showVar dynFlags = show . showPpr dynFlags -- | Show a human-readable version of a list of 'Var's.-showVars :: [Var] -> String-showVars = show . map (showSDoc . ppr)+showVars :: DynFlags -> [Var] -> String+showVars dynFlags = show . map (showPpr dynFlags) -- map GHC.var2String freeIdsT :: TranslateH CoreExpr [Id] freeIdsT = arr coreExprFreeIds@@ -173,11 +175,11 @@ freeVarsT :: TranslateH CoreExpr [Var] freeVarsT = arr coreExprFreeVars --- note: exprFreeVars get *all* free variables, including types+-- note: coreExprFreeVars get *all* free variables, including types coreExprFreeVars :: CoreExpr -> [Var] coreExprFreeVars = uniqSetToList . exprFreeVars --- note: exprFreeIds is only value-level free variables+-- note: coreExprFreeIds is only value-level free variables coreExprFreeIds :: CoreExpr -> [Id] coreExprFreeIds = uniqSetToList . exprFreeIds @@ -260,8 +262,9 @@ rules_help :: TranslateH Core String rules_help = do rulesEnv <- getHermitRules+ dynFlags <- constT getDynFlags return $ (show (map fst rulesEnv) ++ "\n") ++- showSDoc (pprRulesForUser $ concatMap snd rulesEnv)+ showSDoc dynFlags (pprRulesForUser $ concatMap snd rulesEnv) makeRule :: String -> Id -> CoreExpr -> CoreRule makeRule rule_name nm = mkRule True -- auto-generated
src/Language/HERMIT/Primitive/Inline.hs view
@@ -30,7 +30,12 @@ ] inlineName :: TH.Name -> RewriteH CoreExpr-inlineName nm = (varT (cmpTHName2Id nm) >>= guardM) >> inline+inlineName nm = let name = TH.nameBase nm in+ prefixFailMsg ("inline '" ++ name ++ " failed: ") $+ withPatFailMsg (wrongExprForm "Var v") $+ do Var v <- idR+ guardMsg (cmpTHName2Id nm v) $ name ++ " does not match " ++ var2String v ++ "."+ inline inline :: RewriteH CoreExpr inline = configurableInline False False
src/Language/HERMIT/Primitive/Local.hs view
@@ -6,6 +6,7 @@ import Language.HERMIT.Kure import Language.HERMIT.Monad import Language.HERMIT.External+import Language.HERMIT.GHC import Language.HERMIT.Primitive.GHC -- import Language.HERMIT.Primitive.Debug@@ -100,15 +101,15 @@ etaReduce :: RewriteH CoreExpr etaReduce = prefixFailMsg "Eta reduction failed: " $ withPatFailMsg (wrongExprForm "Lam v1 (App f (Var v2))") $- (do Lam v1 (App f (Var v2)) <- idR- guardMsg (v1 == v2) "the expression has the right form, but the variables are not equal."- guardMsg (v1 `notElem` coreExprFreeIds f) $ showSDoc (ppr v1) ++ " is free in the function being applied."- return f) <+- (do Lam v1 (App f (Type ty)) <- idR- Just v2 <- return (getTyVar_maybe ty)- guardMsg (v1 == v2) "type variables are not equal."- guardMsg (v1 `notElem` coreExprFreeVars f) $ showSDoc (ppr v1) ++ " is free in the function being applied."- return f)+ (do Lam v1 (App f (Var v2)) <- idR+ guardMsg (v1 == v2) "the expression has the right form, but the variables are not equal."+ guardMsg (v1 `notElem` coreExprFreeIds f) $ var2String v1 ++ " is free in the function being applied."+ return f) <++ (do Lam v1 (App f (Type ty)) <- idR+ Just v2 <- return (getTyVar_maybe ty)+ guardMsg (v1 == v2) "type variables are not equal."+ guardMsg (v1 `notElem` coreExprFreeVars f) $ var2String v1 ++ " is free in the function being applied."+ return f) etaExpand :: TH.Name -> RewriteH CoreExpr etaExpand nm = prefixFailMsg "Eta expansion failed: " $
src/Language/HERMIT/Primitive/Local/Let.hs view
@@ -14,12 +14,15 @@ import GhcPlugins +import Control.Category((>>>))+ import Data.List import Data.Monoid import Language.HERMIT.Kure import Language.HERMIT.Monad import Language.HERMIT.External+import Language.HERMIT.GHC import Language.HERMIT.Primitive.Common import Language.HERMIT.Primitive.GHC hiding (externals)@@ -40,19 +43,26 @@ [ "(let v = ev in e) x ==> let v = ev in e x" ] .+ Commute .+ Shallow .+ Bash , external "let-float-arg" (promoteExprR letFloatArg :: RewriteH Core) [ "f (let v = ev in e) ==> let v = ev in f e" ] .+ Commute .+ Shallow .+ Bash- , external "let-float-let" (promoteProgramR letFloatLetTop <+ promoteExprR letFloatLet :: RewriteH Core)+ , external "let-float-lam" (promoteExprR letFloatLam :: RewriteH Core)+ [ "(\\ v1 -> let v2 = e1 in e2) ==> let v2 = e1 in (\\ v1 -> e2)",+ "Fails if v1 occurs in e1.",+ "If v1 = v2 then v1 will be alpha-renamed."+ ] .+ Commute .+ Shallow .+ Bash+ , external "let-float-let" (promoteExprR letFloatLet :: RewriteH Core) [ "let v = (let w = ew in ev) in e ==> let w = ew in let v = ev in e" ] .+ Commute .+ Shallow .+ Bash+ , external "let-float-top" (promoteProgramR letFloatLetTop :: RewriteH Core)+ [ "v = (let w = ew in ev) : bds ==> w = ew : v = ev : bds" ] .+ Commute .+ Shallow .+ Bash , external "let-float" (promoteProgramR letFloatLetTop <+ promoteExprR letFloatExpr :: RewriteH Core) [ "Float a Let whatever the context." ] .+ Commute .+ Shallow .+ Bash , external "let-to-case" (promoteExprR letToCase :: RewriteH Core) [ "let v = ev in e ==> case ev of v -> e" ] .+ Commute .+ Shallow .+ PreCondition -- , external "let-to-case-unbox" (promoteR $ not_defined "let-to-case-unbox" :: RewriteH Core) -- [ "let v = ev in e ==> case ev of C v1..vn -> let v = C v1..vn in e" ] .+ Unimplemented+ , external "nonrec-to-rec" (promoteBindR nonrecToRec :: RewriteH Core)+ [ "convert a nonrec binding into a recursive binding group with a single binding"+ , "NonRec v ev ==> Rec [(v,ev)]" ] ] --- not_defined :: String -> RewriteH CoreExpr--- not_defined nm = fail $ nm ++ " not implemented!"- -- | e => (let v = e in v), name of v is provided letIntro :: TH.Name -> RewriteH CoreExpr letIntro nm = prefixFailMsg "Let introduction failed: " $@@ -73,17 +83,29 @@ let letAction = if null vs then idR else alphaLet appT idR letAction $ \ f (Let bnds e) -> Let bnds $ App f e --- let v = (let w = ew in ev) in e ==> let w = ew in let v = ev in e+-- | let v = (let w = ew in ev) in e ==> let w = ew in let v = ev in e letFloatLet :: RewriteH CoreExpr letFloatLet = prefixFailMsg "Let floating from Let failed: " $ do vs <- letNonRecT letVarsT freeVarsT (\ _ -> intersect) let bdsAction = if null vs then idR else nonRecR alphaLet letT bdsAction idR $ \ (NonRec v (Let bds ev)) e -> Let bds $ Let (NonRec v ev) e +-- | (\ v1 -> let v2 = e1 in e2) ==> let v2 = e1 in (\ v1 -> e2)+-- Fails if v1 occurs in e1.+-- If v1 = v2 then v1 will be alpha-renamed.+letFloatLam :: RewriteH CoreExpr+letFloatLam = prefixFailMsg "Let floating from Lam failed: " $+ withPatFailMsg (wrongExprForm "Lam v1 (Let (NonRec v2 e1) e2)") $+ do Lam v1 (Let (NonRec v2 e1) e2) <- idR+ guardMsg (v1 `notElem` coreExprFreeVars e1) $ var2String v1 ++ " occurs in the definition of " ++ var2String v2 ++ "."+ if v1 == v2+ then alphaLam Nothing >>> letFloatLam+ else return (Let (NonRec v2 e1) (Lam v1 e2))+ -- | Float a Let through an expression, whatever the context. letFloatExpr :: RewriteH CoreExpr letFloatExpr = setFailMsg "Unsuitable expression for Let floating." $- letFloatApp <+ letFloatArg <+ letFloatLet+ letFloatApp <+ letFloatArg <+ letFloatLet <+ letFloatLam -- | NonRec v (Let (NonRec w ew) ev) : bds ==> NonRec w ew : NonRec v ev : bds letFloatLetTop :: RewriteH CoreProgram@@ -94,7 +116,13 @@ -- | let v = ev in e ==> case ev of v -> e letToCase :: RewriteH CoreExpr letToCase = prefixFailMsg "Converting Let to Case failed: " $+ withPatFailMsg (wrongExprForm "Let (NonRec v e1) e2") $ do Let (NonRec v ev) _ <- idR nameModifier <- freshNameGenT Nothing caseBndr <- constT (cloneIdH nameModifier v) letT mempty (renameIdR v caseBndr) $ \ () e' -> Case ev caseBndr (varType v) [(DEFAULT, [], e')]++nonrecToRec :: RewriteH CoreBind+nonrecToRec = do+ NonRec v ev <- idR+ return $ Rec [(v,ev)]
src/Language/HERMIT/Primitive/New.hs view
@@ -4,12 +4,7 @@ module Language.HERMIT.Primitive.New where import GhcPlugins as GHC hiding (varName)-import TcSplice (lookupThName_maybe)--- GHC 7.6 only! import TcRnMonad (initTcForLookup) ---import Convert (thRdrNameGuesses)--- import OccName(varName)- import Control.Applicative import Control.Arrow import Control.Monad@@ -46,7 +41,7 @@ , external "fix-intro" (promoteDefR fixIntro :: RewriteH Core) [ "rewrite a recursive binding into a non-recursive binding using fix" ] , external "fix-spec" (promoteExprR fixSpecialization :: RewriteH Core)- [ "specialize a fix with a given argument"] .+ Shallow .+ TODO+ [ "specialize a fix with a given argument"] .+ Shallow , external "cleanup-unfold" (promoteExprR cleanupUnfold :: RewriteH Core) [ "clean up immeduate nested fully-applied lambdas, from the bottom up"] , external "unfold" (promoteExprR . unfold :: TH.Name -> RewriteH Core)@@ -64,11 +59,14 @@ [ "innermost (unfold '. <+ beta-reduce-plus <+ safe-let-subst <+ case-reduce <+ dead-code-elimination)" ] , external "let-tuple" (promoteExprR . letTupleR :: TH.Name -> RewriteH Core) [ "let x = e1 in (let y = e2 in e) ==> let t = (e1,e2) in (let x = fst t in (let y = snd t in e))" ]- ] ++- [ external "any-call" (withUnfold :: RewriteH Core -> RewriteH Core)+ , external "any-call" (withUnfold :: RewriteH Core -> RewriteH Core) [ "any-call (.. unfold command ..) applies an unfold commands to all applications" , "preference is given to applications with more arguments" ] .+ Deep+ , external "abstract" (promoteExprR . abstract :: TH.Name -> RewriteH Core)+ [ "Abstract over a variable using a lambda.",+ "e ==> (\\ x -> e) x"+ ] .+ Shallow .+ Introduce .+ Context ] @@ -109,6 +107,8 @@ (bnds, body) = collectLets e + guardMsg (length bnds > 1) "cannot tuple: need at least two nonrec lets"+ -- until we no longer need letPairR if length bnds == 2 then apply (letPairR nm) c e@@ -142,29 +142,32 @@ -- A few Queries. info :: TranslateH Core String-info = translate $ \ c core ->+info = translate $ \ c core -> do+ dynFlags <- getDynFlags let pa = "Path: " ++ show (contextPath c) node = "Node: " ++ coreNode core con = "Constructor: " ++ coreConstructor core bds = "Bindings in Scope: " ++ (show $ map unqualifiedIdName $ listBindings c) expExtra = case core of- ExprCore e -> ["Type: " ++ showExprType e] ++- ["Free Variables: " ++ showVars (coreExprFreeVars e)] +++ ExprCore e -> ["Type: " ++ showExprType dynFlags e] +++ ["Free Variables: " ++ showVars dynFlags (coreExprFreeVars e)] ++ case e of- Var v -> ["Identifier Info: " ++ showIdInfo v]+ Var v -> ["Identifier Info: " ++ showIdInfo dynFlags v] _ -> [] _ -> []- in- return (intercalate "\n" $ [pa,node,con,bds] ++ expExtra) + return (intercalate "\n" $ [pa,node,con,bds] ++ expExtra)+ exprTypeT :: TranslateH CoreExpr String-exprTypeT = arr showExprType+exprTypeT = contextfreeT $ \ e -> do+ dynFlags <- getDynFlags+ return $ showExprType dynFlags e -showExprType :: CoreExpr -> String-showExprType = showSDoc . ppr . exprType+showExprType :: DynFlags -> CoreExpr -> String+showExprType dynFlags = showPpr dynFlags . exprType -showIdInfo :: Id -> String-showIdInfo v = showSDoc $ ppIdInfo v $ idInfo v+showIdInfo :: DynFlags -> Id -> String+showIdInfo dynFlags v = showSDoc dynFlags $ ppIdInfo v $ idInfo v coreNode :: Core -> String coreNode (ModGutsCore _) = "Module"@@ -202,27 +205,16 @@ f True = "Rewrite would succeed." f False = "Rewrite would fail." -{- this will work in 7.6!-findId' :: String -> m Id-findId' = thNameToGhcId . mkName--thNameToGhcId nm = do- hsc_env <- getHscEnv- mnm <- liftIO $ initTcForLookup hsc_env $ lookupThName_maybe nm- maybe (fail "cannot find " ++ show nm) lookupId mnm--}--findId :: (MonadUnique m, MonadIO m, MonadThings m) => Context -> String -> m Id+findId :: (MonadUnique m, MonadIO m, MonadThings m, HasDynFlags m) => Context -> String -> m Id findId c = findIdMG (hermitModGuts c) -findIdMG :: (MonadUnique m, MonadIO m, MonadThings m) => ModGuts -> String -> m Id+findIdMG :: (MonadUnique m, MonadIO m, MonadThings m, HasDynFlags m) => ModGuts -> String -> m Id findIdMG modguts nm = case filter isValName $ findNameFromTH (mg_rdr_env modguts) $ TH.mkName nm of [] -> fail $ "cannot find " ++ nm [n] -> lookupId n- ns -> fail $ "too many " ++ nm ++ " found:\n" ++ intercalate ", " (map showPpr ns)-- -- liftIO $ print ("VAR", GHC.showSDoc . GHC.ppr $ namedFn)+ ns -> do dynFlags <- getDynFlags+ fail $ "too many " ++ nm ++ " found:\n" ++ intercalate ", " (map (showPpr dynFlags) ns) -- | f = e ==> f = fix (\ f -> e) fixIntro :: RewriteH CoreDef@@ -331,9 +323,20 @@ (Var v,args) -> do guardMsg (nm `cmpTHName2Id` v) $ "could not find name " ++ show nm guardMsg (not $ null args) $ "no argument for " ++ show nm- guardMsg (all isTypeArg (init args)) $ "initial arguments are not type arguments for " ++ show nm+ guardMsg (all isTypeArg $ init args) $ "initial arguments are not type arguments for " ++ show nm case last args of Case {} -> caseFloatArg Let {} -> letFloatArg _ -> fail "argument is not a Case or Let." _ -> fail "no function to match."++-- | Abstract over a variable using a lambda.+-- e ==> (\ x. e) x+abstract :: TH.Name -> RewriteH CoreExpr+abstract nm = prefixFailMsg "abstraction failed: " $+ do (c,e) <- exposeT+ let name = TH.nameBase nm+ case filter (cmpTHName2Id nm) (listBindings c) of+ [] -> fail $ name ++ " is not in scope."+ [v] -> return (App (Lam v e) (Var v)) -- There might be issues if "v" is a type variable, I'm not sure.+ _ : _ : _ -> fail $ "multiple variables named " ++ name ++ " in scope."
src/Language/HERMIT/Primitive/Unfold.hs view
@@ -18,6 +18,7 @@ import Language.HERMIT.Monad import Language.HERMIT.External import Language.HERMIT.Context+import Language.HERMIT.GHC import Prelude hiding (exp) @@ -60,11 +61,11 @@ withPatFailMsg (wrongExprForm "Var v") $ do (c, Var v) <- exposeT constT $ do Def i rhs <- lookupDef label- if idName i == idName v -- Is there a reason we're not just using equality on Id?+ if idName i == idName v -- TODO: Is there a reason we're not just using equality on Id? then ifM (all (inScope c) <$> apply freeVarsT c rhs) (return rhs) (fail "some free variables in stashed definition are no longer in scope.")- else fail $ "stashed definition applies to " ++ showPpr i ++ " not " ++ showPpr v+ else fail $ "stashed definition applies to " ++ var2String i ++ " not " ++ var2String v getUnfolding :: Monad m => Bool -- ^ Get the scrutinee instead of the patten match (for case binders).@@ -74,9 +75,9 @@ case lookupHermitBinding i c of Nothing -> case unfoldingInfo (idInfo i) of CoreUnfolding { uf_tmpl = uft } -> if caseBinderOnly then fail "not a case binder" else return (uft, 0)- _ -> fail $ "cannot find " ++ show i ++ " in Env or IdInfo."- Just (LAM {}) -> fail $ show i ++ " is lambda-bound"- Just (BIND depth _ e') -> if caseBinderOnly then fail "not a case binder" else return (e', depth)+ _ -> fail $ "cannot find unfolding in Env or IdInfo."+ Just (LAM {}) -> fail $ "variable is lambda-bound."+ Just (BIND depth _ e') -> if caseBinderOnly then fail "not a case binder." else return (e', depth) Just (CASE depth s coreAlt) -> return $ if scrutinee then (s, depth) else let tys = tyConAppArgs (idType i)
src/Language/HERMIT/Shell/Command.hs view
@@ -36,9 +36,6 @@ -- import Language.HERMIT.Primitive.GHC --import Prelude hiding (catch)- import System.Console.ANSI import System.IO