diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Neil Mitchell 2006-2007.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Neil Mitchell nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/Yhc/Core.hs b/Yhc/Core.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core.hs
@@ -0,0 +1,32 @@
+
+module Yhc.Core(module X) where
+
+import Yhc.Core.CaseElimination as X
+import Yhc.Core.Clean as X
+import Yhc.Core.Equal as X
+import Yhc.Core.Haskell as X
+import Yhc.Core.Html as X
+import Yhc.Core.Inline as X
+import Yhc.Core.Invariant as X
+import Yhc.Core.Overlay as X
+import Yhc.Core.Prim as X
+import Yhc.Core.Reachable as X
+import Yhc.Core.RecursiveLet as X
+import Yhc.Core.Saturated as X
+import Yhc.Core.Serialise as X
+import Yhc.Core.Show as X
+import Yhc.Core.ShowRaw as X
+import Yhc.Core.Simplify as X
+import Yhc.Core.Strictness as X
+import Yhc.Core.Type as X
+import Yhc.Core.Uniplate as X
+import Yhc.Core.UniqueName as X
+
+
+-- things which are in the process of being moved around
+
+-- use Uniplate
+import Yhc.Core.Play as X
+
+-- moving to FreeVar3
+import Yhc.Core.FreeVar as X
diff --git a/Yhc/Core/Binary.hs b/Yhc/Core/Binary.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/Binary.hs
@@ -0,0 +1,190 @@
+module Yhc.Core.Binary where
+import Yhc.Core.Type
+import Yhc.Core.Internal.Binary
+import Control.Monad
+
+instance Binary Core
+ where put_ bh x = case x of
+ Core x1 x2 x3 x4 -> do if useTag then putByte bh 0 else return ()
+ put_ bh x1
+ put_ bh x2
+ put_ bh x3
+ put_ bh x4
+ where useTag = (>) 1 1
+ get bh = do h <- if useTag then getByte bh else return 0
+ case h of
+ 0 -> do x1 <- get bh
+ x2 <- get bh
+ x3 <- get bh
+ x4 <- get bh
+ return (Core x1 x2 x3 x4)
+ _ -> fail "invalid binary data found"
+ where useTag = (>) 1 1
+
+instance Binary CoreData
+ where put_ bh x = case x of
+ CoreData x1 x2 x3 -> do if useTag then putByte bh 0 else return ()
+ put_ bh x1
+ put_ bh x2
+ put_ bh x3
+ where useTag = (>) 1 1
+ get bh = do h <- if useTag then getByte bh else return 0
+ case h of
+ 0 -> do x1 <- get bh
+ x2 <- get bh
+ x3 <- get bh
+ return (CoreData x1 x2 x3)
+ _ -> fail "invalid binary data found"
+ where useTag = (>) 1 1
+
+instance Binary CoreCtor
+ where put_ bh x = case x of
+ CoreCtor x1 x2 -> do if useTag then putByte bh 0 else return ()
+ put_ bh x1
+ put_ bh x2
+ where useTag = (>) 1 1
+ get bh = do h <- if useTag then getByte bh else return 0
+ case h of
+ 0 -> do x1 <- get bh
+ x2 <- get bh
+ return (CoreCtor x1 x2)
+ _ -> fail "invalid binary data found"
+ where useTag = (>) 1 1
+
+instance Binary CoreFunc
+ where put_ bh x = case x of
+ CoreFunc x1 x2 x3 -> do if useTag then putByte bh 0 else return ()
+ put_ bh x1
+ put_ bh x2
+ put_ bh x3
+ CorePrim x1 x2 x3 x4 x5 x6 -> do if useTag
+ then putByte bh 1
+ else return ()
+ put_ bh x1
+ put_ bh x2
+ put_ bh x3
+ put_ bh x4
+ put_ bh x5
+ put_ bh x6
+ where useTag = (>) 2 1
+ get bh = do h <- if useTag then getByte bh else return 0
+ case h of
+ 0 -> do x1 <- get bh
+ x2 <- get bh
+ x3 <- get bh
+ return (CoreFunc x1 x2 x3)
+ 1 -> do x1 <- get bh
+ x2 <- get bh
+ x3 <- get bh
+ x4 <- get bh
+ x5 <- get bh
+ x6 <- get bh
+ return (CorePrim x1 x2 x3 x4 x5 x6)
+ _ -> fail "invalid binary data found"
+ where useTag = (>) 2 1
+
+instance Binary CoreExpr
+ where put_ bh x = case x of
+ CoreCon x1 -> do if useTag then putByte bh 0 else return ()
+ put_ bh x1
+ CoreVar x1 -> do if useTag then putByte bh 1 else return ()
+ put_ bh x1
+ CoreFun x1 -> do if useTag then putByte bh 2 else return ()
+ put_ bh x1
+ CoreApp x1 x2 -> do if useTag then putByte bh 3 else return ()
+ put_ bh x1
+ put_ bh x2
+ CoreLam x1 x2 -> do if useTag then putByte bh 4 else return ()
+ put_ bh x1
+ put_ bh x2
+ CoreCase x1 x2 -> do if useTag then putByte bh 5 else return ()
+ put_ bh x1
+ put_ bh x2
+ CoreLet x1 x2 -> do if useTag then putByte bh 6 else return ()
+ put_ bh x1
+ put_ bh x2
+ CorePos x1 x2 -> do if useTag then putByte bh 7 else return ()
+ put_ bh x1
+ put_ bh x2
+ CoreLit x1 -> do if useTag then putByte bh 8 else return ()
+ put_ bh x1
+ where useTag = (>) 9 1
+ get bh = do h <- if useTag then getByte bh else return 0
+ case h of
+ 0 -> do x1 <- get bh
+ return (CoreCon x1)
+ 1 -> do x1 <- get bh
+ return (CoreVar x1)
+ 2 -> do x1 <- get bh
+ return (CoreFun x1)
+ 3 -> do x1 <- get bh
+ x2 <- get bh
+ return (CoreApp x1 x2)
+ 4 -> do x1 <- get bh
+ x2 <- get bh
+ return (CoreLam x1 x2)
+ 5 -> do x1 <- get bh
+ x2 <- get bh
+ return (CoreCase x1 x2)
+ 6 -> do x1 <- get bh
+ x2 <- get bh
+ return (CoreLet x1 x2)
+ 7 -> do x1 <- get bh
+ x2 <- get bh
+ return (CorePos x1 x2)
+ 8 -> do x1 <- get bh
+ return (CoreLit x1)
+ _ -> fail "invalid binary data found"
+ where useTag = (>) 9 1
+
+instance Binary CoreLit
+ where put_ bh x = case x of
+ CoreInt x1 -> do if useTag then putByte bh 0 else return ()
+ put_ bh x1
+ CoreInteger x1 -> do if useTag then putByte bh 1 else return ()
+ put_ bh x1
+ CoreChr x1 -> do if useTag then putByte bh 2 else return ()
+ put_ bh x1
+ CoreStr x1 -> do if useTag then putByte bh 3 else return ()
+ put_ bh x1
+ CoreFloat x1 -> do if useTag then putByte bh 4 else return ()
+ put_ bh x1
+ CoreDouble x1 -> do if useTag then putByte bh 5 else return ()
+ put_ bh x1
+ where useTag = (>) 6 1
+ get bh = do h <- if useTag then getByte bh else return 0
+ case h of
+ 0 -> do x1 <- get bh
+ return (CoreInt x1)
+ 1 -> do x1 <- get bh
+ return (CoreInteger x1)
+ 2 -> do x1 <- get bh
+ return (CoreChr x1)
+ 3 -> do x1 <- get bh
+ return (CoreStr x1)
+ 4 -> do x1 <- get bh
+ return (CoreFloat x1)
+ 5 -> do x1 <- get bh
+ return (CoreDouble x1)
+ _ -> fail "invalid binary data found"
+ where useTag = (>) 6 1
+
+instance Binary CorePat
+ where put_ bh x = case x of
+ PatCon x1 x2 -> do if useTag then putByte bh 0 else return ()
+ put_ bh x1
+ put_ bh x2
+ PatLit x1 -> do if useTag then putByte bh 1 else return ()
+ put_ bh x1
+ PatDefault -> if useTag then putByte bh 2 else return ()
+ where useTag = (>) 3 1
+ get bh = do h <- if useTag then getByte bh else return 0
+ case h of
+ 0 -> do x1 <- get bh
+ x2 <- get bh
+ return (PatCon x1 x2)
+ 1 -> do x1 <- get bh
+ return (PatLit x1)
+ 2 -> return PatDefault
+ _ -> fail "invalid binary data found"
+ where useTag = (>) 3 1
diff --git a/Yhc/Core/CaseElimination.hs b/Yhc/Core/CaseElimination.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/CaseElimination.hs
@@ -0,0 +1,26 @@
+
+module Yhc.Core.CaseElimination(coreCaseElim) where
+
+import Yhc.Core.Type
+import Yhc.Core.Uniplate
+
+import Data.List((\\))
+
+
+-- | Eliminate useless default statements
+-- where the other options cover everything
+coreCaseElim :: Core -> Core
+coreCaseElim core = transformExpr f core
+ where
+ coreSets = map (map coreCtorName . coreDataCtors) (coreDatas core)
+
+
+ f (CoreCase on alts)
+ | not (null cons) && not (null cors) && null (cors1 \\ cons)
+ = CoreCase on (filter (not . isPatDefault . fst) alts)
+ where
+ cors = filter (cons1 `elem`) coreSets
+ cons = [x | (PatCon x _, _) <- alts]
+ (cors1,cons1) = (head cors, head cons)
+
+ f x = x
diff --git a/Yhc/Core/Clean.hs b/Yhc/Core/Clean.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/Clean.hs
@@ -0,0 +1,87 @@
+
+module Yhc.Core.Clean(
+ coreClean
+ ) where
+
+import Yhc.Core.Type
+
+import Data.Char
+import Data.List
+
+
+-- | Take a 'Core' program, and output Clean.
+-- Currently one definition per line, although this is not guaranteed (pretty printing would be nice!)
+-- Does not include a /module/ definition, or imports.
+coreClean :: Core -> String
+coreClean core = unlines (concatMap dataClean (coreDatas core) ++ map funcClean (coreFuncs core))
+
+
+-- :: Bool = True | False
+dataClean :: CoreData -> [String]
+dataClean (CoreData name typs ctors)
+ | name `elem` ["[]","Bool","Prelude.[]","Prelude.Bool"] = []
+ | otherwise = [":: " ++ unwords (mangleData name:typs) ++ " = " ++
+ concat (intersperse " | " $ map ctorClean ctors)]
+
+ctorClean :: CoreCtor -> String
+ctorClean (CoreCtor name typs) = unwords (mangleCon name : map (mangleTyp . fst) typs)
+
+
+funcClean (CoreFunc name args body) =
+ unwords (mangleFun name : map mangleVar args) ++ " = " ++
+ exprClean body
+
+
+exprClean x =
+ case x of
+ CorePos _ x -> exprClean x
+ CoreCon x -> mangleCon x
+ CoreVar x -> mangleVar x
+ CoreFun x -> mangleFun x
+ CoreApp x xs -> "(" ++ unwords (map exprClean (x:xs)) ++ ")"
+ CoreLam x xs -> "(\\" ++ unwords (map mangleVar x) ++ " -> " ++ exprClean xs ++ ")"
+
+ CoreCase on alts -> "(case " ++ exprClean on ++ " of {" ++ concatMap f alts ++ "})"
+ where f (lhs,rhs) = exprClean (patToExpr lhs) ++ " -> " ++ exprClean rhs ++ " ; "
+
+ CoreLet bind x -> "(let " ++ concatMap f bind ++ " in " ++ exprClean x ++ ")"
+ where f (lhs,rhs) = mangleVar lhs ++ " = " ++ exprClean rhs ++ " ; "
+
+ CoreLit x -> litClean x
+
+
+litClean x =
+ case x of
+ CoreInt x -> "(" ++ show x ++ ")"
+ CoreInteger x -> "(" ++ show x ++ ")"
+ CoreChr x -> show x
+ CoreStr x -> show x
+ CoreFloat x -> "(" ++ show x ++ ")"
+ CoreDouble x -> "(" ++ show x ++ ")"
+
+
+mangleFun = ('f':) . mangle
+mangleVar = ('v':) . mangle
+mangleData = ('D':) . mangle
+
+
+-- important to reuse : and [], else String's don't work
+mangleCon x | x == ":" || x == "Prelude.:" = "(:)"
+ | x == "[]" || x == "Prelude.[]" = "[]"
+ | x == "True" || x == "Prelude.True" = "True"
+ | x == "False" || x == "Prelude.False" = "False"
+ | otherwise = ('C':) . mangle $ x
+
+
+mangle :: String -> String
+mangle x = concatMap f x
+ where
+ f x | isAlphaNum x = [x]
+ | otherwise = '_' : show (ord x)
+
+
+mangleTyp x = "(" ++ unwords (map f $ words x) ++ ")"
+ where
+ f x | x == "Prelude.Char" = "Int"
+ f xs@(x:_) | isUpper x = mangleData xs
+ f x = x
diff --git a/Yhc/Core/Equal.hs b/Yhc/Core/Equal.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/Equal.hs
@@ -0,0 +1,61 @@
+{-|
+ Equal checks if two CoreExpr's are equal ignoring any children
+ expressions. Usually 'Eq' is what is wanted, but for some stuff
+ this is more appropriate.
+-}
+module Yhc.Core.Equal(
+ eqCoreExpr1,
+ coreExpr1, CoreExpr1
+ ) where
+
+import Yhc.Core.Type
+import Data.List
+
+
+{-|
+ Should be equivalent to:
+
+ > eqCoreExpr1 x y = length xs == length ys && _x vs == _y vs
+ > where
+ > vs = replicate (length xs) (CoreVar "")
+ > (xs,_x) = uniplate x
+ > (ys,_y) = uniplate y
+-}
+
+eqCoreExpr1 = (?)
+
+CoreCon a ? CoreCon b = a == b
+CoreVar a ? CoreVar b = a == b
+CoreFun a ? CoreFun b = a == b
+CoreApp _ a ? CoreApp _ b = length a == length b
+CoreLam a _ ? CoreLam b _ = a == b
+CoreCase _ a ? CoreCase _ b = map fst a == map fst b
+CoreLet a _ ? CoreLet b _ = map fst a == map fst b
+CorePos a _ ? CorePos b _ = a == b
+CoreLit a ? CoreLit b = a == b
+_ ? _ = False
+
+
+
+data CoreExpr1 = CoreCon1 CoreCtorName
+ | CoreVar1 CoreVarName
+ | CoreFun1 CoreFuncName
+ | CoreApp1 Int
+ | CoreLam1 [CoreVarName]
+ | CoreCase1 [CorePat]
+ | CoreLet1 [CoreVarName]
+ | CorePos1 String
+ | CoreLit1 CoreLit
+ deriving (Ord,Eq,Show)
+
+
+coreExpr1 :: CoreExpr -> CoreExpr1
+coreExpr1 (CoreCon x) = CoreCon1 x
+coreExpr1 (CoreVar x) = CoreVar1 x
+coreExpr1 (CoreFun x) = CoreFun1 x
+coreExpr1 (CoreApp x y) = CoreApp1 (length y)
+coreExpr1 (CoreLam x y) = CoreLam1 x
+coreExpr1 (CoreCase x y) = CoreCase1 (map fst y)
+coreExpr1 (CoreLet x y) = CoreLet1 (map fst x)
+coreExpr1 (CorePos x y) = CorePos1 x
+coreExpr1 (CoreLit x) = CoreLit1 x
diff --git a/Yhc/Core/FreeVar.hs b/Yhc/Core/FreeVar.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/FreeVar.hs
@@ -0,0 +1,111 @@
+
+{-|
+ In: \x -> y x
+
+ x is bound
+
+ y is free
+-}
+module Yhc.Core.FreeVar(
+ collectAllVars, collectBoundVars, collectFreeVars,
+ countFreeVar, replaceFreeVars,
+ variableSupply,
+ uniqueBoundVars, uniqueBoundVarsWith, uniqueBoundVarsWithout,
+ uniqueBoundVarsCore, uniqueBoundVarsFunc
+ ) where
+
+import Yhc.Core.FreeVar3(collectAllVars, collectBoundVars, collectFreeVars, countFreeVar, replaceFreeVars)
+import Yhc.Core.Type
+import Yhc.Core.Play
+import Yhc.Core.Internal.General
+
+import Data.List
+import Data.Maybe
+
+
+-- sorted nub
+snub :: Ord a => [a] -> [a]
+snub = map head . group . sort
+
+
+-- | Given a prefix, generate a stream of variables
+-- Each will be unique in the series
+variableSupply :: Char -> [String]
+variableSupply c = [c:show i | i <- [1..]]
+
+
+-- | Just 'uniqueFreeVarsWith', but with a default set of variables
+uniqueBoundVars :: CoreExpr -> CoreExpr
+uniqueBoundVars = uniqueBoundVarsWith (variableSupply 'v')
+
+
+-- | Just 'uniqueFreeVarsWith', but with a certain set excluded
+uniqueBoundVarsWithout :: [String] -> CoreExpr -> CoreExpr
+uniqueBoundVarsWithout xs = uniqueBoundVarsWith (variableSupply 'v' \\ xs)
+
+
+-- | Replace all variables which are locally defined with new names
+-- from the given list. Raises an error if not enough free variables
+-- are supplied
+--
+-- If any in the new list clashes with a name in 'collectFreeVars' this
+-- will return a program with different semantics!
+--
+-- Property: collectFreeVars (uniqueFreeVarsWith newvars x) `subset` newvars
+--
+uniqueBoundVarsWith :: [String] -> CoreExpr -> CoreExpr
+uniqueBoundVarsWith new = snd . f [] new
+ where
+ f :: [(String,String)] -> [String] -> CoreExpr -> ([String], CoreExpr)
+ f ren new x =
+ case x of
+ CoreVar x -> (new, CoreVar $ fromMaybe x (lookup x ren))
+
+ CoreCase on alts -> (new3, CoreCase on2 alts2)
+ where
+ (new2,on2) = f ren new on
+ (new3,alts2) = mapAccumL g new alts
+
+ g new (lhs_,rhs) = (new3,(exprToPat lhs2,rhs2))
+ where
+ lhs = patToExpr lhs_
+
+ vars = [x | CoreVar x <- allCore lhs]
+ (vars2,new2) = splitAt (length vars) new
+ ren2 = zip vars vars2 ++ ren
+
+ (_,lhs2) = f ren2 [] lhs
+ (new3,rhs2) = f ren2 new2 rhs
+
+ CoreLet bind x -> (new4, CoreLet (zip lhs2 rhs2) x2)
+ where
+ (lhs,rhs) = unzip bind
+ (lhs2,new2) = splitAt (length bind) new
+ ren2 = zip lhs lhs2 ++ ren
+
+ (new3,rhs2) = mapAccumL (f ren2) new2 rhs
+ (new4,x2) = f ren2 new3 x
+
+ CoreLam bind x -> (new3, CoreLam bind2 x2)
+ where
+ (bind2,new2) = splitAt (length bind) new
+ (new3,x2) = f (zip bind bind2 ++ ren) new2 x
+
+ _ -> (new2, setChildrenCore x child2)
+ where
+ (new2, child2) = mapAccumL (f ren) new (getChildrenCore x)
+
+
+-- | Make a whole Core program have unique free variables.
+-- Between functions, they may share variables
+uniqueBoundVarsCore :: Core -> Core
+uniqueBoundVarsCore = applyFuncCore uniqueBoundVarsFunc
+
+
+-- | Make a whole function have unique free variables
+uniqueBoundVarsFunc :: CoreFunc -> CoreFunc
+uniqueBoundVarsFunc x@(CorePrim{}) = x
+uniqueBoundVarsFunc (CoreFunc name args body)
+ = CoreFunc name args2 (replaceFreeVars (zip args (map CoreVar args2)) (uniqueBoundVarsWith free body))
+ where
+ (args2,free) = splitAt (length args) (variableSupply 'v' \\ (args ++ collectAllVars body))
diff --git a/Yhc/Core/FreeVar2.hs b/Yhc/Core/FreeVar2.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/FreeVar2.hs
@@ -0,0 +1,136 @@
+
+{-|
+ In: \x -> y x
+
+ x is bound
+
+ y is free
+-}
+module Yhc.Core.FreeVar2(
+ FreeVar, runFreeVars, freeVars,
+ putVars, getVars, getVar, deleteVars,
+ collectAllVars, collectBoundVars, collectFreeVars,
+ countFreeVar, replaceFreeVars,
+ uniqueBoundVarsCore, uniqueBoundVarsFunc, uniqueBoundVars
+ ) where
+
+
+import Yhc.Core.FreeVar3(collectAllVars, collectBoundVars, collectFreeVars, countFreeVar, replaceFreeVars)
+import Control.Monad.State
+
+import Yhc.Core.Type
+import Yhc.Core.Uniplate
+import Yhc.Core.Internal.General
+
+import Data.List
+import Data.Maybe
+
+
+
+newtype FreeVar a = FreeVar {fromFreeVar :: State [String] a}
+
+instance Monad FreeVar where
+ return a = FreeVar (return a)
+ (FreeVar x) >>= f = FreeVar (x >>= fromFreeVar . f)
+
+
+putVars :: [String] -> FreeVar ()
+putVars xs = FreeVar (put xs)
+
+
+getVars :: FreeVar [String]
+getVars = FreeVar get
+
+getVar :: FreeVar String
+getVar = do (x:xs) <- getVars
+ putVars xs
+ return x
+
+
+deleteVars :: [String] -> FreeVar ()
+deleteVars xs = FreeVar (modify (\\ xs))
+
+
+runFreeVars :: FreeVar a -> a
+runFreeVars (FreeVar x) = evalState x (freeVars 'v')
+
+
+freeVars :: Char -> [String]
+freeVars c = [c:show i | i <- [1..]]
+
+
+
+-- | Replace all variables which are locally defined with new names
+-- from the given list. Raises an error if not enough free variables
+-- are supplied
+--
+-- If any in the new list clashes with a name in 'collectFreeVars' this
+-- will return a program with different semantics!
+--
+-- Property: collectFreeVars (uniqueFreeVarsWith newvars x) `subset` newvars
+--
+uniqueBoundVars :: CoreExpr -> FreeVar CoreExpr
+uniqueBoundVars = f []
+ where
+ f :: [(String,String)] -> CoreExpr -> FreeVar CoreExpr
+ f ren x =
+ case x of
+ CoreVar x -> return $ CoreVar $ fromMaybe x (lookup x ren)
+
+ CoreCase on alts -> do
+ on2 <- f ren on
+ alts2 <- mapM g alts
+ return $ CoreCase on2 alts2
+ where
+ g (lhs,rhs) = do
+ lhs <- return $ patToExpr lhs
+ let vars = [x | CoreVar x <- universeExpr lhs]
+ vars2 <- getVarsN (length vars)
+ let ren2 = zip vars vars2 ++ ren
+
+ lhs2 <- f ren2 lhs
+ rhs2 <- f ren2 rhs
+ return (exprToPat lhs2, rhs2)
+
+ CoreLet bind x -> do
+ let (lhs,rhs) = unzip bind
+ lhs2 <- getVarsN (length lhs)
+ let ren2 = zip lhs lhs2 ++ ren
+
+ rhs2 <- mapM (f ren2) rhs
+ x2 <- f ren2 x
+ return $ CoreLet (zip lhs2 rhs2) x2
+
+ CoreLam bind x -> do
+ bind2 <- getVarsN (length bind)
+ let ren2 = zip bind bind2 ++ ren
+ x2 <- f ren2 x
+ return $ CoreLam bind2 x2
+
+ _ -> descendExprM (f ren) x
+
+
+ getVarsN :: Int -> FreeVar [String]
+ getVarsN n = do
+ ys <- getVars
+ let (used,keep) = splitAt n ys
+ putVars keep
+ return used
+
+
+-- | Make a whole Core program have unique free variables.
+uniqueBoundVarsCore :: Core -> FreeVar Core
+uniqueBoundVarsCore core = do
+ funcs2 <- mapM uniqueBoundVarsFunc $ coreFuncs core
+ return $ core{coreFuncs = funcs2}
+
+
+-- | Make a whole function have unique free variables
+uniqueBoundVarsFunc :: CoreFunc -> FreeVar CoreFunc
+uniqueBoundVarsFunc x@(CorePrim{}) = return x
+uniqueBoundVarsFunc (CoreFunc name args body) = do
+ vars <- getVars
+ let (args2,rest) = splitAt (length args) vars
+ putVars rest
+ body2 <- uniqueBoundVars (replaceFreeVars (zip args (map CoreVar args2)) body)
+ return $ CoreFunc name args2 body2
diff --git a/Yhc/Core/FreeVar3.hs b/Yhc/Core/FreeVar3.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/FreeVar3.hs
@@ -0,0 +1,235 @@
+
+{-|
+ In: \x -> y x
+
+ x is bound
+
+ y is free
+-}
+module Yhc.Core.FreeVar3(
+ collectAllVars, collectBoundVars, collectFreeVars, countFreeVar,
+ uniplateBoundVars,
+ replaceFreeVars, replaceFreeVarsUnique,
+ freeVars, getVar, getVars, duplicateExpr, checkFreeVar,
+ uniqueBoundVarsCore, uniqueBoundVarsFunc, uniqueBoundVars
+ ) where
+
+import Yhc.Core.Type
+import Yhc.Core.Uniplate
+import Yhc.Core.UniqueId
+import Yhc.Core.Internal.General
+
+import Data.Char
+import Data.List
+import Data.Maybe
+import Control.Monad.State
+import Control.Monad.Identity
+
+
+-- * Collection and Classification
+
+-- | Which variables are mentioned in an expression
+collectAllVars :: CoreExpr -> [CoreVarName]
+collectAllVars = ordNub . concatMap f . universeExpr
+ where
+ f (CoreVar x) = [x]
+ f (CoreLet bind x) = map fst bind
+ f (CoreLam bind x) = bind
+ f (CoreCase on alts) = concatMap (patVariables . fst) alts
+ f x = []
+
+
+-- | Which variables are introduced at any point,
+-- i.e. LHS of a case alternative, or by a let
+collectBoundVars :: CoreExpr -> [CoreVarName]
+collectBoundVars = ordNub . concatMap f . universeExpr
+ where
+ f (CoreCase on alts) = concatMap (patVariables . fst) alts
+ f (CoreLet bind x) = map fst bind
+ f (CoreLam bind x) = bind
+ f x = []
+
+
+-- | Which variables are in the used in an expression
+-- before being defined. No variable will occur more than once
+collectFreeVars :: CoreExpr -> [CoreVarName]
+collectFreeVars = f
+ where
+ -- f must ensure uniqueness at each stage
+ f (CoreVar x) = [x]
+ f (CoreCase on alt) = ordNub $ f on ++ concatMap g alt
+ f (CoreLet bind x) = ordNub (f x ++ concatMap (f . snd) bind) \\ map fst bind
+ f (CoreLam bind x) = f x \\ bind
+ f x = ordNub $ concatMap f (children x)
+
+ g (lhs,rhs) = f rhs \\ patVariables lhs
+
+
+-- | Count the number of uses of a free variable.
+-- If a variable is used in different branches of a case, it is only
+-- considered to be the maximum of these two branches.
+countFreeVar :: CoreVarName -> CoreExpr -> Int
+countFreeVar s (CoreVar x) = if x == s then 1 else 0
+
+countFreeVar s (CoreCase on alts) = countFreeVar s on + maximum (map g alts)
+ where
+ g (lhs,rhs) | s `elem` patVariables lhs = 0
+ | otherwise = countFreeVar s rhs
+
+countFreeVar s (CoreLet bind x) | s `elem` map fst bind = 0
+countFreeVar s (CoreLam bind x) | s `elem` bind = 0
+countFreeVar s x = sum $ map (countFreeVar s) (children x)
+
+
+-- * Uniplate style FreeVar stuff
+-- Should really be used throughout, but free variable stuff
+-- takes forever to get right, and don't want to break it now
+
+-- | Get the variables that are defined to one-level depth
+-- and a function to replace them
+uniplateBoundVars :: CoreExpr -> ([CoreVarName], [CoreVarName] -> CoreExpr)
+uniplateBoundVars (CoreLet bind x) = (lhs, \lhs -> CoreLet (zip lhs rhs) x)
+ where (lhs,rhs) = unzip bind
+uniplateBoundVars (CoreLam bind x) = (bind, \bind -> CoreLam bind x)
+uniplateBoundVars (CoreCase on alts) = (children, \rep -> CoreCase on $ f rep alts)
+ where
+ children = concatMap (patVariables . fst) alts
+
+ f rep ((PatCon x xs, y):alts) = (PatCon x r, y) : f rs alts
+ where (r,rs) = splitAt (length xs) rep
+ f rep (x:xs) = x : f rep xs
+ f [] [] = []
+
+uniplateBoundVars x = ([], const x)
+
+
+-- * Operations
+
+
+-- | Replace all free occurances of variables with a new expression
+replaceFreeVars :: [(CoreVarName, CoreExpr)] -> CoreExpr -> CoreExpr
+replaceFreeVars ren = runIdentity . replaceFreeVarsWith return ren
+
+
+replaceFreeVarsUnique :: UniqueIdM m => [(CoreVarName, CoreExpr)] -> CoreExpr -> m CoreExpr
+replaceFreeVarsUnique ren = replaceFreeVarsWith duplicateExpr ren
+
+
+
+replaceFreeVarsWith :: Monad m => (CoreExpr -> m CoreExpr) -> [(CoreVarName, CoreExpr)] -> CoreExpr -> m CoreExpr
+replaceFreeVarsWith dupe ren x =
+ case x of
+ CoreVar x -> maybe (return $ CoreVar x) dupe (lookup x ren)
+
+ CoreLet bind x -> descendM (replaceFreeVarsWith dupe ren2) (CoreLet bind x)
+ where ren2 = remove (map fst bind)
+
+ CoreLam bind x -> liftM (CoreLam bind) $ replaceFreeVarsWith dupe (remove bind) x
+
+ CoreCase on alts -> do
+ on <- replaceFreeVarsWith dupe ren on
+ alts <- mapM f alts
+ return $ CoreCase on alts
+ where
+ f (lhs,rhs) = liftM ((,) lhs) $ replaceFreeVarsWith dupe (remove (patVariables lhs)) rhs
+
+ x -> descendM (replaceFreeVarsWith dupe ren) x
+ where
+ remove xs = filter ((`notElem` xs) . fst) ren
+
+
+
+-- | Check that the free variables in the second expression
+-- are also in the first one. It usually indicates an error to
+-- introduce new free variables in transformation.
+--
+-- Return True for safe, False for probably buggy.
+checkFreeVar :: CoreExpr -> CoreExpr -> Bool
+checkFreeVar orig new = null $ collectFreeVars new \\ collectFreeVars orig
+
+
+-- * Unique Monad Support
+
+
+freeVars :: Char -> [String]
+freeVars c = [c:show i | i <- [1..]]
+
+
+getVar :: UniqueIdM m => m CoreVarName
+getVar = liftM (('v':) . show) nextId
+
+
+getVars :: UniqueIdM m => Int -> m [CoreVarName]
+getVars n = replicateM n getVar
+
+
+duplicateExpr :: UniqueIdM m => CoreExpr -> m CoreExpr
+duplicateExpr = uniqueBoundVarsExpr
+
+-- | Replace all variables which are locally defined with new names
+-- from the monad.
+uniqueBoundVarsExpr :: UniqueIdM m => CoreExpr -> m CoreExpr
+uniqueBoundVarsExpr = uniqueBoundVarsExprWith []
+
+
+-- | Local version, which allows a substitution set to be passed through
+uniqueBoundVarsExprWith :: UniqueIdM m => [(String,String)] -> CoreExpr -> m CoreExpr
+uniqueBoundVarsExprWith ren x = let f = uniqueBoundVarsExprWith in
+ case x of
+ CoreVar x -> return $ CoreVar $ fromMaybe x (lookup x ren)
+
+ CoreCase on alts -> do
+ on2 <- f ren on
+ alts2 <- mapM g alts
+ return $ CoreCase on2 alts2
+ where
+ g (PatCon c vars, rhs) = do
+ vars2 <- getVars (length vars)
+ let ren2 = zip vars vars2 ++ ren
+ rhs2 <- f ren2 rhs
+ return (PatCon c vars2, rhs2)
+ g (lhs,rhs) = do
+ rhs2 <- f ren rhs
+ return (lhs,rhs2)
+
+ CoreLet bind x -> do
+ let (lhs,rhs) = unzip bind
+ lhs2 <- getVars (length lhs)
+ let ren2 = zip lhs lhs2 ++ ren
+ rhs2 <- mapM (f ren2) rhs
+ x2 <- f ren2 x
+ return $ CoreLet (zip lhs2 rhs2) x2
+
+ CoreLam bind x -> do
+ bind2 <- getVars (length bind)
+ let ren2 = zip bind bind2 ++ ren
+ x2 <- f ren2 x
+ return $ CoreLam bind2 x2
+
+ _ -> descendExprM (f ren) x
+
+
+-- | Take care: If v123 is a free variable, then make sure getVar starts above that
+uniqueBoundVars :: UniqueIdM m => CoreExpr -> m CoreExpr
+uniqueBoundVars x = do
+ let seen = [read i | 'v':i <- collectFreeVars x, all isDigit i, not $ null i]
+ limit = maximum (0:seen) + 1
+ i <- getIdM
+ putIdM (max i limit)
+ uniqueBoundVarsExpr x
+
+
+-- | Make a whole function have unique free variables
+uniqueBoundVarsFunc :: UniqueIdM m => CoreFunc -> m CoreFunc
+uniqueBoundVarsFunc x | isCorePrim x = return x
+uniqueBoundVarsFunc (CoreFunc name args body) = do
+ args2 <- getVars (length args)
+ body2 <- uniqueBoundVarsExprWith (zip args args2) body
+ return $ CoreFunc name args2 body2
+
+
+-- | Make a whole Core program have unique free variables.
+uniqueBoundVarsCore :: UniqueIdM m => Core -> m Core
+uniqueBoundVarsCore core = do
+ funcs2 <- mapM uniqueBoundVarsFunc $ coreFuncs core
+ return $ core{coreFuncs = funcs2}
diff --git a/Yhc/Core/Haskell.hs b/Yhc/Core/Haskell.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/Haskell.hs
@@ -0,0 +1,157 @@
+
+module Yhc.Core.Haskell(
+ coreHaskell, coreHaskellDirect
+ ) where
+
+import Yhc.Core.Type
+import Yhc.Core.Prim
+import Yhc.Core.Reachable
+
+import Data.Char
+import Data.List
+import Data.Maybe
+
+
+-- | Take a 'Core' program, and output Haskell.
+-- Fix up as much as possible
+coreHaskell :: Core -> String
+coreHaskell = coreHaskellDirect . coreReachable ["main"]
+
+
+prefix = ["import System.IO"
+ ,"import System.Environment"
+ ,"import Data.Char"
+ ,"import System.IO.Unsafe"
+ ,"prim_FROM_STRING = map ord"
+ ,"prim_FROM_CHAR = ord"
+ ,"prim_TO_STRING = map chr"
+ ,"prim_TO_CHAR = chr"
+ ,"prim_GET_ARGS = getArgs >>= return . map prim_FROM_STRING"
+ ,"main = seq (fmain ()) (return () :: IO ())"
+ ,"unwrapIO :: IO a -> world -> Either () a"
+ ,"unwrapIO x _ = unsafePerformIO (x >>= return . Right)"
+ ,""
+ ]
+
+-- | Take a 'Core' program, and output Haskell.
+-- Currently one definition per line, although this is not guaranteed (pretty printing would be nice!)
+-- Does not include a /module/ definition, or imports.
+coreHaskellDirect :: Core -> String
+coreHaskellDirect core = unlines (prefix ++ concatMap dataHaskell (coreDatas core) ++ map funcHaskell (coreFuncs core))
+
+
+dataHaskell :: CoreData -> [String]
+dataHaskell (CoreData name typs ctors)
+ | name `elem` ["[]","Bool","Prelude.[]","Prelude.Bool","Prelude.(,)","(,)","Prelude.Either","Either"] = []
+ | otherwise = ["data " ++ unwords (mangleData name:typs) ++ " = " ++
+ concat (intersperse " | " $ map ctorHaskell ctors)]
+
+ctorHaskell :: CoreCtor -> String
+ctorHaskell (CoreCtor name typs) = unwords (mangleCon name : map (mangleTyp . fst) typs)
+
+
+funcHaskell (CoreFunc name args body) =
+ unwords (mangleFun name : map mangleVar args) ++ " = " ++
+ exprHaskell body
+
+
+exprHaskell x =
+ case x of
+ CorePos _ x -> exprHaskell x
+ CoreCon x -> mangleCon x
+ CoreVar x -> mangleVar x
+ CoreFun x -> mangleFun x
+ CoreApp x xs -> "(" ++ unwords (map exprHaskell (x:xs)) ++ ")"
+ CoreLam x xs -> "(\\" ++ unwords (map mangleVar x) ++ " -> " ++ exprHaskell xs ++ ")"
+
+ CoreCase on alts -> "(case " ++ cast (exprHaskell on) ++ " of {" ++ concatMap f alts ++ "})"
+ where
+ alhs = fst $ head alts
+ cast s = if isPatLit alhs then "(" ++ s ++ " :: " ++ typeConstHaskell (fromPatLit alhs) ++ ")" else s
+
+ f (lhs_,rhs) = (if isCoreLit lhs then valueConstHaskell (fromCoreLit lhs) else exprHaskell lhs) ++
+ " -> " ++ exprHaskell rhs ++ " ; "
+ where lhs = patToExpr lhs_
+
+
+ CoreLet bind x -> "(let " ++ concatMap f bind ++ " in " ++ exprHaskell x ++ ")"
+ where f (lhs,rhs) = mangleVar lhs ++ " = " ++ exprHaskell rhs ++ " ; "
+
+ CoreLit (CoreStr x) -> "(prim_FROM_STRING " ++ show x ++ ")"
+
+ CoreLit x -> "(" ++ valueConstHaskell x ++ " :: " ++ typeConstHaskell x ++ ")"
+
+
+typeConstHaskell x =
+ case x of
+ CoreInt _ -> "Int"
+ CoreInteger _ -> "Integer"
+ CoreChr _ -> "Int"
+ CoreFloat _ -> "Float"
+ CoreDouble _ -> "Double"
+
+
+valueConstHaskell x =
+ case x of
+ CoreInt x -> show x
+ CoreInteger x -> show x
+ CoreChr x -> show $ ord x
+ CoreFloat x -> show x
+ CoreDouble x -> show x
+
+
+primHaskell x ys = applyCast res (typs !! length ys)
+ where
+ res = "(" ++ unwords (op : zipWith applyCast (map exprHaskell ys) typs) ++ ")"
+ typs = primType prim ++ repeat PrimTypeUnknown
+ prim = corePrim x
+ sop = show $ primOp prim
+ op = if primOp prim == PrimDiv && head (primType prim) `elem` [PrimInt,PrimInteger] then "div"
+ else if primOp prim == PrimHaskell then
+ (if primName prim == "System.Environment.getArgs" then "prim_GET_ARGS" else primName prim)
+ else if primOp prim == PrimCast then casts (primType prim)
+ else if isAlpha $ head sop then sop
+ else "(" ++ sop ++ ")"
+
+ casts [_,PrimInteger] = "toInteger"
+ casts [PrimInteger,_] = "fromInteger"
+ casts x = error $ "Do not know cast for, " ++ show x
+
+ applyCast val t
+ | t `elem` [PrimInt,PrimInteger,PrimFloat,PrimDouble] = "(" ++ val ++ " :: " ++ show t ++ ")"
+ | t == PrimChar = "(prim_TO_CHAR " ++ val ++ ")"
+ | t == PrimString = "(prim_TO_STRING " ++ val ++ ")"
+ | otherwise = case t of
+ PrimTypeHaskell s | "IO " `isPrefixOf` s -> "(unwrapIO " ++ val ++ ")"
+ _ -> val
+
+
+mangleFun = ('f':) . mangle
+mangleVar = ('v':) . mangle
+mangleData = ('D':) . mangle
+
+
+-- important to reuse : and [], else String's don't work
+mangleCon x | x == ":" || x == "Prelude.:" = "(:)"
+ | x == "[]" || x == "Prelude.[]" = "[]"
+ | x == "True" || x == "Prelude.True" = "True"
+ | x == "False" || x == "Prelude.False" = "False"
+ | x == "Left" || x == "Prelude.Left" = "Left"
+ | x == "Right" || x == "Prelude.Right" = "Right"
+ | x == "(,)" || x == "Prelude.(,)" = "(,)"
+ | otherwise = ('C':) . mangle $ x
+
+
+mangle :: String -> String
+mangle x = concatMap f x
+ where
+ f x | isAlphaNum x = [x]
+ | otherwise = '_' : show (ord x)
+
+
+mangleTyp = coreDataTypeJoin . map f . coreDataTypeSplit
+ where
+ f x | isJust res = fromJust res
+ where res = lookup x coreHaskellTypes
+ f xs@(x:_) | isUpper x = mangleData xs
+ f x = x
diff --git a/Yhc/Core/Html.hs b/Yhc/Core/Html.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/Html.hs
@@ -0,0 +1,204 @@
+
+module Yhc.Core.Html(coreHtml) where
+
+import Yhc.Core.Type
+import Yhc.Core.Show(isCoreOperator)
+import Yhc.Core.Internal.HughesPJ
+
+import Data.List
+import Data.Maybe
+import Data.Char
+
+
+prefix modu =
+ "" ++
+ "" ++
+ "" ++
+ "" ++
+ "" ++ modu ++ " - Yhc.Core" ++
+ "" ++
+ "\n"
+
+suffix = "\n"
+
+
+script =
+ "var done = '';\n" ++
+ "\n" ++
+ "function none()\n" ++
+ "{\n" ++
+ " if (done == '') return;\n" ++
+ " done = '';\n" ++
+ " document.styleSheets[0].deleteRule(0);\n" ++
+ " document.styleSheets[0].deleteRule(0);\n" ++
+ "}\n" ++
+ "\n" ++
+ "function use(node)\n" ++
+ "{\n" ++
+ " if (done == node)\n" ++
+ " {\n" ++
+ " none();\n" ++
+ " return false;\n" ++
+ " }\n" ++
+ "\n" ++
+ " var n = document.getElementById(node);\n" ++
+ " var offsetBottom = n.offsetTop + n.offsetHeight;\n" ++
+ " var scrollBottom = document.body.scrollTop + window.innerHeight;\n" ++
+ "\n" ++
+ " def(node);\n" ++
+ "\n" ++
+ " return (n.offsetTop < document.body.scrollTop || offsetBottom > scrollBottom)\n" ++
+ "}\n" ++
+ "\n" ++
+ "function def(node)\n" ++
+ "{\n" ++
+ " if (done == node)\n" ++
+ " {\n" ++
+ " none();\n" ++
+ " return;\n" ++
+ " }\n" ++
+ "\n" ++
+ " none();\n" ++
+ " var rule1 = '#' + node + '{border-color: #ff4;}'\n" ++
+ " var rule2 = '.' + node + '{background-color: #ff4;}'\n" ++
+ "\n" ++
+ " document.styleSheets[0].insertRule(rule1,0);\n" ++
+ " document.styleSheets[0].insertRule(rule2,0);\n" ++
+ " done = node;\n" ++
+ "}\n" ++
+ "\n"
+
+
+
+coreHtml :: Core -> String
+coreHtml core = prefix (coreName core) ++ show (docCore core) ++ suffix
+
+
+
+listLines = vcat -- . intersperse (text "\n")
+blankLine = text ""
+
+
+wrap prepend doc append = zeroText prepend <> doc <> zeroText append
+tag s x = wrap ("") (text x) ""
+
+enc = concatMap f
+ where
+ f x | isAlphaNum x = [x]
+ | otherwise = show (ord x)
+
+key = tag "key"
+op = tag "op"
+str = tag "str"
+
+
+opchars = hcat . map f
+ where
+ f x | x `elem` "[]()," = op [x]
+ | otherwise = char x
+
+
+docCore :: Core -> Doc
+docCore core@(Core modName depends datas funcs) = listLines $
+ [key "module" <+> text modName <+> key "where", blankLine] ++
+ map ((key "import" <+>) . text) depends ++ [blankLine] ++
+ intersperse (blankLine <> blankLine) (map docData datas ++ map (docFunc core) funcs)
+
+
+docData :: CoreData -> Doc
+docData (CoreData name free []) = key "data" <+> hsep (map text (name:free))
+docData (CoreData name free (x:xs)) =
+ docData (CoreData name free []) <+> op "=" <+> text "\n" <+>
+ text " " <> docCtor x <+>
+ hsep (map (\x -> text "\n " <> op "|" <> text " " <> docCtor x) xs)
+
+
+docCtor :: CoreCtor -> Doc
+docCtor (CoreCtor name args) = text name <+> text (
+ ['{' | useRecords] ++
+ (concat $ intersperse sep $ map f args) ++
+ ['}' | useRecords])
+ where
+ useRecords = any (isJust . snd) args
+ sep = ([','|useRecords]++" ")
+
+ f (typ, Nothing) = typ
+ f (typ, Just x) = "_" ++ x ++ " :: " ++ typ
+
+
+
+inner :: Doc -> Doc
+inner = nest 4
+
+(<>>) :: Doc -> Doc -> Doc
+a <>> b = sep [a, inner b]
+
+
+
+docFunc :: Core -> CoreFunc -> Doc
+docFunc core x = wrap ("") res "
"
+ where
+ res = body initial
+
+ ename = enc name
+ name = coreFuncName x
+ body = if isCoreFunc x then (<>> docExpr core (coreFuncBody x)) else id
+ args = if isCoreFunc x then hsep (map text (coreFuncArgs x)) <+> op "="
+ else text $ "arity=" ++ show (corePrimArity x)
+ prefix = if isCoreFunc x then text name
+ else key "primitive" <+> text name
+
+ pre = ""
+ initial = wrap pre prefix "" <+> args
+
+
+-- True is bracket, False is don't
+docExpr :: Core -> CoreExpr -> Doc
+docExpr core x = f False x
+ where
+ -- True is do bracketing
+ -- False is don't
+
+ f b (CoreCon x) = f b (CoreVar x)
+ f b (CoreFun x) | not link = f b (CoreVar x)
+ | otherwise = wrap pre (f b (CoreVar x)) ""
+ where
+ pre = ""
+ link = isJust $ coreFuncMaybe core x
+ ename = enc x
+
+ f b (CoreVar x) = brack (isCoreOperator x) (opchars x)
+
+ f b (CoreLam xs x) = brack b $ char '\\' <> text (unwords xs) <+> text "->" <+> f False x
+
+ f b (CoreLit x) = g x
+
+ f b (CorePos x y) = f b y
+
+ f b (CoreApp x []) = f b x
+ f b (CoreApp x xs) = brack b $ call (f True x) (map (f True) xs)
+
+ f b (CoreCase on alts) = brack b (key "case" <+> f True on <+> key "of" $$ inner (vcat $ map g alts))
+ where
+ g (a,b) = (f False (patToExpr a) <+> op "->") <>> f False b
+
+ f b (CoreLet binds x) = brack b $ key "let" <+> vcat (map g binds) $$ key "in" <+> f False x
+ where
+ g (lhs,rhs) = text lhs <+> op "=" <>> f False rhs
+
+ call x xs = sep $ x : map (nest 2) xs
+ brack b x = if b then op "(" <> x <> op ")" else x
+
+ g (CoreInt x) = text $ show x
+ g (CoreChr x) = str $ show x
+ g (CoreStr x) = str $ show x
+ g (CoreInteger x) = text $ show x
+ g (CoreFloat x) = text $ show x
+ g (CoreDouble x) = text $ show x
diff --git a/Yhc/Core/Inline.hs b/Yhc/Core/Inline.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/Inline.hs
@@ -0,0 +1,218 @@
+
+{- |
+ Inlining module.
+
+ This module will let you perform some inlining on Yhc.Core code. The 'InlineMode' argument
+ lets you select what algorithm is used. All should be terminating, and none should
+ increase the number of function calls in a program.
+
+ For comparison, GHC's inlining mode is more powerful than 'InlineForward', but less
+ powerful than 'InlineFull'. (And just so people understand, powerful does not mean more
+ performance, it means more inlining - the two are not always the same!)
+
+ 'InlineNone'
+
+ No inlining. Equivalent to 'id' :)
+
+ 'InlineAlias'
+
+ A function is inlined if it is aliased to another function.
+
+ A function is aliased if all it does is call another function with the
+ same arguments in the same order. i.e.
+
+ > f x y z = g x y z
+
+ Note that a function is not aliased if any argument is duplicated, the
+ RHS is a primitive or a constructor, or the arguments are reordered.
+
+ This restriction means that inlining can even occur when f is used
+ higher order, g can be replaced.
+
+ This mode will never increase the code size.
+
+ 'InlineForward'
+
+ A function is inlined if it is a forwarder.
+
+ A function is a forwarder if all it does is call another function,
+ using only the given arguments, possibly reordered but not duplicated.
+ A forwarder can also be a single constant value, or a simple argument
+ value (a projection), or a constructor with no arguments. i.e.
+
+ > f x y z = 12
+ > f x y z = g z y
+ > f x y z = x
+
+ The function is only inlined if it is called saturated.
+
+ This mode will never increase the code size.
+
+ 'InlineCallOnce'
+
+ A function is inlined if it is a forwarder, or if there is only one
+ caller. Only inlined if called saturated. Will never increase the code
+ size.
+
+ 'InlineFull'
+
+ This does the most inlining it can, but never inlines the same function
+ more than once in a given expression - to ensure termination. Also doesn't
+ inline CAF's, since that would go wrong. Large functions, recursive functions,
+ duplicated arguments etc - all are inlined without question.
+
+ Duplicated arguments are moved into a let, to ensure they are not computed
+ additional times.
+
+ This mode is more than likely to increase the code size in most programs.
+-}
+
+module Yhc.Core.Inline(
+ coreInline, InlineMode(..),
+ coreInlineFunc, coreInlineFuncLambda
+ ) where
+
+import Yhc.Core.Type
+import Yhc.Core.Uniplate
+import Yhc.Core.FreeVar
+
+import qualified Data.Map as Map
+import Data.Maybe
+import Data.List
+
+
+data InlineMode = InlineNone -- ^ no inlining at all
+ | InlineAlias -- ^ f a b c = g a b c, calls to g become calls to f
+ | InlineForward -- ^ f a b c = g a b, g b a, a (g may be a constructor)
+ | InlineCallOnce -- ^ f is called only once
+ | InlineFull -- ^ If you can inline it, do so! Breaks on first recursive call
+
+
+coreInline :: InlineMode -> Core -> Core
+coreInline InlineNone core = core
+coreInline InlineAlias core = coreInlineAlias core
+coreInline InlineForward core = inlineNormal (analyseForward core) core
+coreInline InlineCallOnce core = inlineNormal (analyseForward core `Map.union` analyseCallOnce core) core
+coreInline InlineFull core = inlineNormal (analyseFull core) $ coreInlineAlias core
+
+
+coreInlineAlias core = inlineAlias (analyseAlias core) core
+
+---------------------------------------------------------------------
+-- INLINING OPERATIONS
+
+
+inlineAlias :: Map.Map CoreFuncName CoreFuncName -> Core -> Core
+inlineAlias rep core = transformExpr f core
+ where
+ f (CoreFun x) = CoreFun $ Map.findWithDefault x x rep
+ f x = x
+
+
+inlineNormal :: Map.Map CoreFuncName CoreFunc -> Core -> Core
+inlineNormal rep core = applyFuncCore f core
+ where
+ f (CoreFunc name args body) = CoreFunc name args $ transformExpr (g [name]) body
+ f x = x
+
+ g done x = fromMaybe x $ do
+ (CoreFun fn,args) <- return $ fromCoreApp x
+ func <- Map.lookup fn rep
+ True <- return $ fn `notElem` done
+ res <- coreInlineFunc func args
+ return $ transformExpr (g (fn:done)) res
+
+
+
+---------------------------------------------------------------------
+-- INLINING ANALYSIS
+
+
+analyseAlias :: Core -> Map.Map CoreFuncName CoreFuncName
+analyseAlias core = transForward
+ where
+ -- where there is a single forwarder
+ basicForward :: Map.Map String String
+ basicForward = Map.fromList $ concatMap f (coreFuncs core)
+ where
+ f (CoreFunc name args (CoreApp (CoreFun x) xs)) | map CoreVar args == xs = [(name,x)]
+ f _ = []
+
+ -- what is the transitive closure of the basicForward
+ transForward :: Map.Map String String
+ transForward = Map.mapWithKey (\k v -> f [k] v) basicForward
+ where
+ f done name =
+ case Map.lookup name basicForward of
+ Just x | name `notElem` done -> f (name:done) x
+ _ -> name
+
+
+analyseForward :: Core -> Map.Map CoreFuncName CoreFunc
+analyseForward core = Map.fromList
+ [(name, func) | func@(CoreFunc name _ bod) <- coreFuncs core, canInline bod]
+ where
+ canInline (CorePos _ x) = canInline x
+ canInline (CoreApp x xs) = isGoodFun x && all isGoodArg xs && disjoint [i | CoreVar i <- xs]
+ canInline x = isCoreCon x || isCoreFun x || isGoodArg x
+
+ isGoodFun x = isCoreFun x || isCoreCon x
+
+ isGoodArg x = isCoreVar x || isSmallConst x
+
+ isSmallConst x = isCoreLit x && not (isCoreStr $ fromCoreLit x)
+
+
+analyseCallOnce :: Core -> Map.Map CoreFuncName CoreFunc
+analyseCallOnce core = Map.fromList
+ [(name,func) | func@(CoreFunc name (_:_) _) <- coreFuncs core, Just True == Map.lookup name once]
+ where
+ once :: Map.Map CoreFuncName Bool -- True is once, False is many
+ once = foldl f Map.empty [x | CoreFun x <- universeExpr core]
+ f mp x = Map.insertWith (\_ _ -> False) x True mp
+
+
+analyseFull :: Core -> Map.Map CoreFuncName CoreFunc
+analyseFull core = Map.fromList [(name,func) | func@(CoreFunc name (_:_) _) <- coreFuncs core]
+
+
+disjoint x = length (nub x) == length x
+
+
+---------------------------------------------------------------------
+-- INLINING ACTIONS
+
+-- | Inline a function, fails if it would produce a lambda
+-- See 'coreInlineFuncLambda' for a version without this property
+coreInlineFunc :: CoreFunc -> [CoreExpr] -> Maybe CoreExpr
+coreInlineFunc func@(CoreFunc name params2 body2) args
+ | nparams > nargs = Nothing
+ | otherwise = Just res
+ where
+ res = coreApp subst (drop nparams args)
+
+ (nargs, nparams) = (length args, length params2)
+ argvars = concatMap collectAllVars args
+ allvars = ['v':show i | i <- [1..]] \\ (params2 ++ argvars ++ collectAllVars body2)
+
+ (params,rest) = splitAt nparams allvars
+ body = uniqueBoundVarsWith rest $ replaceFreeVars (zip params2 (map CoreVar params)) body2
+ newvars = rest \\ collectAllVars body
+
+ (dupe,once) = partition (\(lhs,rhs) -> requiresLet rhs && countFreeVar lhs body > 1) (zip params args)
+ requiresLet x = not (isCoreVar x || isCoreFun x)
+ dupnew = zip newvars dupe
+
+ binds = [(new,a) | (new,(p,a)) <- dupnew]
+ reps = [(p,CoreVar new) | (new,(p,a)) <- dupnew] ++ once
+
+ subst = coreLet binds (replaceFreeVars reps body)
+
+
+-- | Inline a function, generating a lambda if necessary
+-- NOTE: Should this return a CoreLam now we have this in the AST
+coreInlineFuncLambda :: CoreFunc -> [CoreExpr] -> ([String], CoreExpr)
+coreInlineFuncLambda func@(CoreFunc name params body) args =
+ (extraArgs, fromJust $ coreInlineFunc func (args ++ map CoreVar extraArgs))
+ where
+ extraArgs = drop (length args) (coreFuncArgs func)
diff --git a/Yhc/Core/Internal/Binary.hs b/Yhc/Core/Internal/Binary.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/Internal/Binary.hs
@@ -0,0 +1,94 @@
+
+module Yhc.Core.Internal.Binary where
+
+import System.IO
+import Data.Char
+import Control.Monad
+
+
+class Binary a where
+ put_ :: Handle -> a -> IO ()
+ get :: Handle -> IO a
+
+
+writeBinary :: Binary a => FilePath -> a -> IO ()
+writeBinary file x = do
+ hndl <- openBinaryFile file WriteMode
+ put_ hndl x
+ hClose hndl
+
+readBinary :: Binary a => FilePath -> IO a
+readBinary file = do
+ hndl <- openBinaryFile file ReadMode
+ res <- get hndl
+ hClose hndl
+ return res
+
+
+putByte :: Handle -> Int -> IO ()
+putByte hndl x = hPutChar hndl (chr x)
+getByte :: Handle -> IO Int
+getByte hndl = liftM ord $ hGetChar hndl
+
+
+instance Binary a => Binary [a] where
+ put_ bh [] = putByte bh 0
+ put_ bh xs = do putByte bh (length a); mapM_ (put_ bh) a; put_ bh b
+ where (a,b) = splitAt 100 xs
+
+ get bh = do h <- getByte bh
+ case h of
+ 0 -> return []
+ _ -> do xs <- replicateM h (get bh)
+ ys <- get bh
+ return (xs ++ ys)
+
+instance Binary a => Binary (Maybe a) where
+ put_ bh Nothing = putByte bh 0
+ put_ bh (Just x) = putByte bh 1 >> put_ bh x
+
+ get bh = do h <- getByte bh
+ case h of
+ 0 -> return Nothing
+ 1 -> liftM Just $ get bh
+
+
+instance (Binary a, Binary b) => Binary (a,b) where
+ put_ h (a,b) = put_ h a >> put_ h b
+ get h = do a <- get h
+ b <- get h
+ return (a,b)
+
+instance (Binary a, Binary b, Binary c) => Binary (a,b, c) where
+ put_ h (a,b,c) = put_ h a >> put_ h b >> put_ h c
+ get h = do a <- get h
+ b <- get h
+ c <- get h
+ return (a,b,c)
+
+instance Binary Bool where
+ put_ hndl x = hPutChar hndl (if x then '1' else '0')
+ get hndl = hGetChar hndl >>= return . (== '1')
+
+
+instance Binary Char where
+ put_ = hPutChar
+ get = hGetChar
+
+
+-- TODO: horrible versions
+-- a quick hacky, replace and integrate with
+-- the Binary from Yhc.ByteCode
+
+showPut :: Show a => Handle -> a -> IO ()
+showPut h x = put_ h (show x)
+
+showGet :: Read a => Handle -> IO a
+showGet h = liftM read $ get h
+
+instance Binary Int where{put_ = showPut; get = showGet}
+instance Binary Integer where{put_ = showPut; get = showGet}
+instance Binary Float where{put_ = showPut; get = showGet}
+instance Binary Double where{put_ = showPut; get = showGet}
+
+
diff --git a/Yhc/Core/Internal/General.hs b/Yhc/Core/Internal/General.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/Internal/General.hs
@@ -0,0 +1,16 @@
+
+module Yhc.Core.Internal.General where
+
+import qualified Data.Set as Set
+
+
+ordNub :: Ord a => [a] -> [a]
+ordNub xs = f Set.empty xs
+ where
+ f set (x:xs) | x `Set.member` set = f set xs
+ | otherwise = x : f (Set.insert x set) xs
+ f set [] = []
+
+disjoint :: Eq a => [a] -> [a] -> Bool
+disjoint x y = not $ any (`elem` x) y
+
diff --git a/Yhc/Core/Internal/HughesPJ.hs b/Yhc/Core/Internal/HughesPJ.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/Internal/HughesPJ.hs
@@ -0,0 +1,996 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.PrettyPrint.HughesPJ
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators
+--
+-- Based on /The Design of a Pretty-printing Library/
+-- in Advanced Functional Programming,
+-- Johan Jeuring and Erik Meijer (eds), LNCS 925
+--
+--
+-- Heavily modified by Simon Peyton Jones, Dec 96
+--
+-----------------------------------------------------------------------------
+
+{-
+Version 3.0 28 May 1997
+ * Cured massive performance bug. If you write
+
+ foldl <> empty (map (text.show) [1..10000])
+
+ you get quadratic behaviour with V2.0. Why? For just the same
+ reason as you get quadratic behaviour with left-associated (++)
+ chains.
+
+ This is really bad news. One thing a pretty-printer abstraction
+ should certainly guarantee is insensivity to associativity. It
+ matters: suddenly GHC's compilation times went up by a factor of
+ 100 when I switched to the new pretty printer.
+
+ I fixed it with a bit of a hack (because I wanted to get GHC back
+ on the road). I added two new constructors to the Doc type, Above
+ and Beside:
+
+ <> = Beside
+ $$ = Above
+
+ Then, where I need to get to a "TextBeside" or "NilAbove" form I
+ "force" the Doc to squeeze out these suspended calls to Beside and
+ Above; but in so doing I re-associate. It's quite simple, but I'm
+ not satisfied that I've done the best possible job. I'll send you
+ the code if you are interested.
+
+ * Added new exports:
+ punctuate, hang
+ int, integer, float, double, rational,
+ lparen, rparen, lbrack, rbrack, lbrace, rbrace,
+
+ * fullRender's type signature has changed. Rather than producing a
+ string it now takes an extra couple of arguments that tells it how
+ to glue fragments of output together:
+
+ fullRender :: Mode
+ -> Int -- Line length
+ -> Float -- Ribbons per line
+ -> (TextDetails -> a -> a) -- What to do with text
+ -> a -- What to do at the end
+ -> Doc
+ -> a -- Result
+
+ The "fragments" are encapsulated in the TextDetails data type:
+
+ data TextDetails = Chr Char
+ | Str String
+ | PStr FAST_STRING
+
+ The Chr and Str constructors are obvious enough. The PStr
+ constructor has a packed string (FAST_STRING) inside it. It's
+ generated by using the new "ptext" export.
+
+ An advantage of this new setup is that you can get the renderer to
+ do output directly (by passing in a function of type (TextDetails
+ -> IO () -> IO ()), rather than producing a string that you then
+ print.
+
+
+Version 2.0 24 April 1997
+ * Made empty into a left unit for <> as well as a right unit;
+ it is also now true that
+ nest k empty = empty
+ which wasn't true before.
+
+ * Fixed an obscure bug in sep that occassionally gave very weird behaviour
+
+ * Added $+$
+
+ * Corrected and tidied up the laws and invariants
+
+======================================================================
+Relative to John's original paper, there are the following new features:
+
+1. There's an empty document, "empty". It's a left and right unit for
+ both <> and $$, and anywhere in the argument list for
+ sep, hcat, hsep, vcat, fcat etc.
+
+ It is Really Useful in practice.
+
+2. There is a paragraph-fill combinator, fsep, that's much like sep,
+ only it keeps fitting things on one line until it can't fit any more.
+
+3. Some random useful extra combinators are provided.
+ <+> puts its arguments beside each other with a space between them,
+ unless either argument is empty in which case it returns the other
+
+
+ hcat is a list version of <>
+ hsep is a list version of <+>
+ vcat is a list version of $$
+
+ sep (separate) is either like hsep or like vcat, depending on what fits
+
+ cat behaves like sep, but it uses <> for horizontal conposition
+ fcat behaves like fsep, but it uses <> for horizontal conposition
+
+ These new ones do the obvious things:
+ char, semi, comma, colon, space,
+ parens, brackets, braces,
+ quotes, doubleQuotes
+
+4. The "above" combinator, $$, now overlaps its two arguments if the
+ last line of the top argument stops before the first line of the
+ second begins.
+
+ For example: text "hi" $$ nest 5 (text "there")
+ lays out as
+ hi there
+ rather than
+ hi
+ there
+
+ There are two places this is really useful
+
+ a) When making labelled blocks, like this:
+ Left -> code for left
+ Right -> code for right
+ LongLongLongLabel ->
+ code for longlonglonglabel
+ The block is on the same line as the label if the label is
+ short, but on the next line otherwise.
+
+ b) When laying out lists like this:
+ [ first
+ , second
+ , third
+ ]
+ which some people like. But if the list fits on one line
+ you want [first, second, third]. You can't do this with
+ John's original combinators, but it's quite easy with the
+ new $$.
+
+ The combinator $+$ gives the original "never-overlap" behaviour.
+
+5. Several different renderers are provided:
+ * a standard one
+ * one that uses cut-marks to avoid deeply-nested documents
+ simply piling up in the right-hand margin
+ * one that ignores indentation (fewer chars output; good for machines)
+ * one that ignores indentation and newlines (ditto, only more so)
+
+6. Numerous implementation tidy-ups
+ Use of unboxed data types to speed up the implementation
+-}
+
+module Yhc.Core.Internal.HughesPJ (
+
+ -- * The document type
+ Doc, -- Abstract
+
+ -- * Constructing documents
+ -- ** Converting values into documents
+ char, text, ptext, zeroText,
+ int, integer, float, double, rational,
+
+ -- ** Simple derived documents
+ semi, comma, colon, space, equals,
+ lparen, rparen, lbrack, rbrack, lbrace, rbrace,
+
+ -- ** Wrapping documents in delimiters
+ parens, brackets, braces, quotes, doubleQuotes,
+
+ -- ** Combining documents
+ empty,
+ (<>), (<+>), hcat, hsep,
+ ($$), ($+$), vcat,
+ sep, cat,
+ fsep, fcat,
+ nest,
+ hang, punctuate,
+
+ -- * Predicates on documents
+ isEmpty,
+
+ -- * Rendering documents
+
+ -- ** Default rendering
+ render,
+
+ -- ** Rendering with a particular style
+ Style(..),
+ style,
+ renderStyle,
+
+ -- ** General rendering
+ fullRender,
+ Mode(..), TextDetails(..),
+
+ ) where
+
+
+import Prelude
+
+infixl 6 <>
+infixl 6 <+>
+infixl 5 $$, $+$
+
+-- ---------------------------------------------------------------------------
+-- The interface
+
+-- The primitive Doc values
+
+isEmpty :: Doc -> Bool; -- ^ Returns 'True' if the document is empty
+
+-- | The empty document, with no height and no width.
+-- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere
+-- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc.
+empty :: Doc
+
+semi :: Doc; -- ^ A ';' character
+comma :: Doc; -- ^ A ',' character
+colon :: Doc; -- ^ A ':' character
+space :: Doc; -- ^ A space character
+equals :: Doc; -- ^ A '=' character
+lparen :: Doc; -- ^ A '(' character
+rparen :: Doc; -- ^ A ')' character
+lbrack :: Doc; -- ^ A '[' character
+rbrack :: Doc; -- ^ A ']' character
+lbrace :: Doc; -- ^ A '{' character
+rbrace :: Doc; -- ^ A '}' character
+
+-- | A document of height and width 1, containing a literal character.
+char :: Char -> Doc
+
+-- | A document of height 1 containing a literal string.
+-- 'text' satisfies the following laws:
+--
+-- * @'text' s '<>' 'text' t = 'text' (s'++'t)@
+--
+-- * @'text' \"\" '<>' x = x@, if @x@ non-empty
+--
+-- The side condition on the last law is necessary because @'text' \"\"@
+-- has height 1, while 'empty' has no height.
+text :: String -> Doc
+
+-- | An obsolete function, now identical to 'text'.
+ptext :: String -> Doc
+
+-- | Some text, but without any width. Use for non-printing text
+-- such as a HTML or Latex tags
+zeroText :: String -> Doc
+
+int :: Int -> Doc; -- ^ @int n = text (show n)@
+integer :: Integer -> Doc; -- ^ @integer n = text (show n)@
+float :: Float -> Doc; -- ^ @float n = text (show n)@
+double :: Double -> Doc; -- ^ @double n = text (show n)@
+rational :: Rational -> Doc; -- ^ @rational n = text (show n)@
+
+parens :: Doc -> Doc; -- ^ Wrap document in @(...)@
+brackets :: Doc -> Doc; -- ^ Wrap document in @[...]@
+braces :: Doc -> Doc; -- ^ Wrap document in @{...}@
+quotes :: Doc -> Doc; -- ^ Wrap document in @\'...\'@
+doubleQuotes :: Doc -> Doc; -- ^ Wrap document in @\"...\"@
+
+-- Combining @Doc@ values
+
+-- | Beside.
+-- '<>' is associative, with identity 'empty'.
+(<>) :: Doc -> Doc -> Doc
+
+-- | Beside, separated by space, unless one of the arguments is 'empty'.
+-- '<+>' is associative, with identity 'empty'.
+(<+>) :: Doc -> Doc -> Doc
+
+-- | Above, except that if the last line of the first argument stops
+-- at least one position before the first line of the second begins,
+-- these two lines are overlapped. For example:
+--
+-- > text "hi" $$ nest 5 (text "there")
+--
+-- lays out as
+--
+-- > hi there
+--
+-- rather than
+--
+-- > hi
+-- > there
+--
+-- '$$' is associative, with identity 'empty', and also satisfies
+--
+-- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty.
+--
+($$) :: Doc -> Doc -> Doc
+
+-- | Above, with no overlapping.
+-- '$+$' is associative, with identity 'empty'.
+($+$) :: Doc -> Doc -> Doc
+
+hcat :: [Doc] -> Doc; -- ^List version of '<>'.
+hsep :: [Doc] -> Doc; -- ^List version of '<+>'.
+vcat :: [Doc] -> Doc; -- ^List version of '$$'.
+
+cat :: [Doc] -> Doc; -- ^ Either 'hcat' or 'vcat'.
+sep :: [Doc] -> Doc; -- ^ Either 'hsep' or 'vcat'.
+fcat :: [Doc] -> Doc; -- ^ \"Paragraph fill\" version of 'cat'.
+fsep :: [Doc] -> Doc; -- ^ \"Paragraph fill\" version of 'sep'.
+
+-- | Nest (or indent) a document by a given number of positions
+-- (which may also be negative). 'nest' satisfies the laws:
+--
+-- * @'nest' 0 x = x@
+--
+-- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@
+--
+-- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@
+--
+-- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@
+--
+-- * @'nest' k 'empty' = 'empty'@
+--
+-- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty
+--
+-- The side condition on the last law is needed because
+-- 'empty' is a left identity for '<>'.
+nest :: Int -> Doc -> Doc
+
+-- GHC-specific ones.
+
+-- | @hang d1 n d2 = sep [d1, nest n d2]@
+hang :: Doc -> Int -> Doc -> Doc
+
+-- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@
+punctuate :: Doc -> [Doc] -> [Doc]
+
+
+-- Displaying @Doc@ values.
+
+instance Show Doc where
+ showsPrec prec doc cont = showDoc doc cont
+
+-- | Renders the document as a string using the default 'style'.
+render :: Doc -> String
+
+-- | The general rendering interface.
+fullRender :: Mode -- ^Rendering mode
+ -> Int -- ^Line length
+ -> Float -- ^Ribbons per line
+ -> (TextDetails -> a -> a) -- ^What to do with text
+ -> a -- ^What to do at the end
+ -> Doc -- ^The document
+ -> a -- ^Result
+
+-- | Render the document as a string using a specified style.
+renderStyle :: Style -> Doc -> String
+
+-- | A rendering style.
+data Style
+ = Style { mode :: Mode -- ^ The rendering mode
+ , lineLength :: Int -- ^ Length of line, in chars
+ , ribbonsPerLine :: Float -- ^ Ratio of ribbon length to line length
+ }
+
+-- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@).
+style :: Style
+style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode }
+
+-- | Rendering mode.
+data Mode = PageMode -- ^Normal
+ | ZigZagMode -- ^With zig-zag cuts
+ | LeftMode -- ^No indentation, infinitely long lines
+ | OneLineMode -- ^All on one line
+
+-- ---------------------------------------------------------------------------
+-- The Doc calculus
+
+-- The Doc combinators satisfy the following laws:
+
+{-
+Laws for $$
+~~~~~~~~~~~
+ (x $$ y) $$ z = x $$ (y $$ z)
+ empty $$ x = x
+ x $$ empty = x
+
+ ...ditto $+$...
+
+Laws for <>
+~~~~~~~~~~~
+ (x <> y) <> z = x <> (y <> z)
+ empty <> x = empty
+ x <> empty = x
+
+ ...ditto <+>...
+
+Laws for text
+~~~~~~~~~~~~~
+ text s <> text t = text (s++t)
+ text "" <> x = x, if x non-empty
+
+Laws for nest
+~~~~~~~~~~~~~
+ nest 0 x = x
+ nest k (nest k' x) = nest (k+k') x
+ nest k (x <> y) = nest k z <> nest k y
+ nest k (x $$ y) = nest k x $$ nest k y
+ nest k empty = empty
+ x <> nest k y = x <> y, if x non-empty
+
+** Note the side condition on ! It is this that
+** makes it OK for empty to be a left unit for <>.
+
+Miscellaneous
+~~~~~~~~~~~~~
+ (text s <> x) $$ y = text s <> ((text "" <> x)) $$
+ nest (-length s) y)
+
+ (x $$ y) <> z = x $$ (y <> z)
+ if y non-empty
+
+
+Laws for list versions
+~~~~~~~~~~~~~~~~~~~~~~
+ sep (ps++[empty]++qs) = sep (ps ++ qs)
+ ...ditto hsep, hcat, vcat, fill...
+
+ nest k (sep ps) = sep (map (nest k) ps)
+ ...ditto hsep, hcat, vcat, fill...
+
+Laws for oneLiner
+~~~~~~~~~~~~~~~~~
+ oneLiner (nest k p) = nest k (oneLiner p)
+ oneLiner (x <> y) = oneLiner x <> oneLiner y
+
+You might think that the following verion of would
+be neater:
+
+<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$
+ nest (-length s) y)
+
+But it doesn't work, for if x=empty, we would have
+
+ text s $$ y = text s <> (empty $$ nest (-length s) y)
+ = text s <> nest (-length s) y
+-}
+
+-- ---------------------------------------------------------------------------
+-- Simple derived definitions
+
+semi = char ';'
+colon = char ':'
+comma = char ','
+space = char ' '
+equals = char '='
+lparen = char '('
+rparen = char ')'
+lbrack = char '['
+rbrack = char ']'
+lbrace = char '{'
+rbrace = char '}'
+
+int n = text (show n)
+integer n = text (show n)
+float n = text (show n)
+double n = text (show n)
+rational n = text (show n)
+-- SIGBJORN wrote instead:
+-- rational n = text (show (fromRationalX n))
+
+quotes p = char '\'' <> p <> char '\''
+doubleQuotes p = char '"' <> p <> char '"'
+parens p = char '(' <> p <> char ')'
+brackets p = char '[' <> p <> char ']'
+braces p = char '{' <> p <> char '}'
+
+
+hcat = foldr (<>) empty
+hsep = foldr (<+>) empty
+vcat = foldr ($$) empty
+
+hang d1 n d2 = sep [d1, nest n d2]
+
+punctuate p [] = []
+punctuate p (d:ds) = go d ds
+ where
+ go d [] = [d]
+ go d (e:es) = (d <> p) : go e es
+
+-- ---------------------------------------------------------------------------
+-- The Doc data type
+
+-- A Doc represents a *set* of layouts. A Doc with
+-- no occurrences of Union or NoDoc represents just one layout.
+
+-- | The abstract type of documents.
+-- The 'Show' instance is equivalent to using 'render'.
+data Doc
+ = Empty -- empty
+ | NilAbove Doc -- text "" $$ x
+ | TextBeside TextDetails !Int Doc -- text s <> x
+ | Nest !Int Doc -- nest k x
+ | Union Doc Doc -- ul `union` ur
+ | NoDoc -- The empty set of documents
+ | Beside Doc Bool Doc -- True <=> space between
+ | Above Doc Bool Doc -- True <=> never overlap
+
+type RDoc = Doc -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside
+
+
+reduceDoc :: Doc -> RDoc
+reduceDoc (Beside p g q) = beside p g (reduceDoc q)
+reduceDoc (Above p g q) = above p g (reduceDoc q)
+reduceDoc p = p
+
+
+data TextDetails = Chr Char
+ | Str String
+ | PStr String
+space_text = Chr ' '
+nl_text = Chr '\n'
+
+{-
+ Here are the invariants:
+
+ * The argument of NilAbove is never Empty. Therefore
+ a NilAbove occupies at least two lines.
+
+ * The arugment of @TextBeside@ is never @Nest@.
+
+
+ * The layouts of the two arguments of @Union@ both flatten to the same
+ string.
+
+ * The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
+
+ * The right argument of a union cannot be equivalent to the empty set
+ (@NoDoc@). If the left argument of a union is equivalent to the
+ empty set (@NoDoc@), then the @NoDoc@ appears in the first line.
+
+ * An empty document is always represented by @Empty@. It can't be
+ hidden inside a @Nest@, or a @Union@ of two @Empty@s.
+
+ * The first line of every layout in the left argument of @Union@ is
+ longer than the first line of any layout in the right argument.
+ (1) ensures that the left argument has a first line. In view of
+ (3), this invariant means that the right argument must have at
+ least two lines.
+-}
+
+ -- Arg of a NilAbove is always an RDoc
+nilAbove_ p = NilAbove p
+
+ -- Arg of a TextBeside is always an RDoc
+textBeside_ s sl p = TextBeside s sl p
+
+ -- Arg of Nest is always an RDoc
+nest_ k p = Nest k p
+
+ -- Args of union are always RDocs
+union_ p q = Union p q
+
+
+-- Notice the difference between
+-- * NoDoc (no documents)
+-- * Empty (one empty document; no height and no width)
+-- * text "" (a document containing the empty string;
+-- one line high, but has no width)
+
+
+-- ---------------------------------------------------------------------------
+-- @empty@, @text@, @nest@, @union@
+
+empty = Empty
+
+isEmpty Empty = True
+isEmpty _ = False
+
+char c = textBeside_ (Chr c) 1 Empty
+text s = case length s of {sl -> textBeside_ (Str s) sl Empty}
+ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty}
+zeroText s = textBeside_ (Str s) 0 Empty
+
+nest k p = mkNest k (reduceDoc p) -- Externally callable version
+
+-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
+mkNest k _ | k `seq` False = undefined
+mkNest k (Nest k1 p) = mkNest (k + k1) p
+mkNest k NoDoc = NoDoc
+mkNest k Empty = Empty
+mkNest 0 p = p -- Worth a try!
+mkNest k p = nest_ k p
+
+-- mkUnion checks for an empty document
+mkUnion Empty q = Empty
+mkUnion p q = p `union_` q
+
+-- ---------------------------------------------------------------------------
+-- Vertical composition @$$@
+
+above_ :: Doc -> Bool -> Doc -> Doc
+above_ p _ Empty = p
+above_ Empty _ q = q
+above_ p g q = Above p g q
+
+p $$ q = above_ p False q
+p $+$ q = above_ p True q
+
+above :: Doc -> Bool -> RDoc -> RDoc
+above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)
+above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q)
+above p g q = aboveNest p g 0 (reduceDoc q)
+
+aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc
+-- Specfication: aboveNest p g k q = p $g$ (nest k q)
+
+aboveNest _ _ k _ | k `seq` False = undefined
+aboveNest NoDoc g k q = NoDoc
+aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
+ aboveNest p2 g k q
+
+aboveNest Empty g k q = mkNest k q
+aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q)
+ -- p can't be Empty, so no need for mkNest
+
+aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
+aboveNest (TextBeside s sl p) g k q = k1 `seq` textBeside_ s sl rest
+ where
+ k1 = k - sl
+ rest = case p of
+ Empty -> nilAboveNest g k1 q
+ other -> aboveNest p g k1 q
+
+
+nilAboveNest :: Bool -> Int -> RDoc -> RDoc
+-- Specification: text s <> nilaboveNest g k q
+-- = text s <> (text "" $g$ nest k q)
+
+nilAboveNest _ k _ | k `seq` False = undefined
+nilAboveNest g k Empty = Empty -- Here's why the "text s <>" is in the spec!
+nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
+
+nilAboveNest g k q | (not g) && (k > 0) -- No newline if no overlap
+ = textBeside_ (Str (spaces k)) k q
+ | otherwise -- Put them really above
+ = nilAbove_ (mkNest k q)
+
+-- ---------------------------------------------------------------------------
+-- Horizontal composition @<>@
+
+beside_ :: Doc -> Bool -> Doc -> Doc
+beside_ p _ Empty = p
+beside_ Empty _ q = q
+beside_ p g q = Beside p g q
+
+p <> q = beside_ p False q
+p <+> q = beside_ p True q
+
+beside :: Doc -> Bool -> RDoc -> RDoc
+-- Specification: beside g p q = p q
+
+beside NoDoc g q = NoDoc
+beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q)
+beside Empty g q = q
+beside (Nest k p) g q = nest_ k (beside p g q) -- p non-empty
+beside p@(Beside p1 g1 q1) g2 q2
+ {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2
+ [ && (op1 == <> || op1 == <+>) ] -}
+ | g1 == g2 = beside p1 g1 (beside q1 g2 q2)
+ | otherwise = beside (reduceDoc p) g2 q2
+beside p@(Above _ _ _) g q = beside (reduceDoc p) g q
+beside (NilAbove p) g q = nilAbove_ (beside p g q)
+beside (TextBeside s sl p) g q = textBeside_ s sl rest
+ where
+ rest = case p of
+ Empty -> nilBeside g q
+ other -> beside p g q
+
+
+nilBeside :: Bool -> RDoc -> RDoc
+-- Specification: text "" <> nilBeside g p
+-- = text "" p
+
+nilBeside g Empty = Empty -- Hence the text "" in the spec
+nilBeside g (Nest _ p) = nilBeside g p
+nilBeside g p | g = textBeside_ space_text 1 p
+ | otherwise = p
+
+-- ---------------------------------------------------------------------------
+-- Separate, @sep@, Hughes version
+
+-- Specification: sep ps = oneLiner (hsep ps)
+-- `union`
+-- vcat ps
+
+sep = sepX True -- Separate with spaces
+cat = sepX False -- Don't
+
+sepX x [] = empty
+sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps
+
+
+-- Specification: sep1 g k ys = sep (x : map (nest k) ys)
+-- = oneLiner (x nest k (hsep ys))
+-- `union` x $$ nest k (vcat ys)
+
+sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc
+sep1 g _ k ys | k `seq` False = undefined
+sep1 g NoDoc k ys = NoDoc
+sep1 g (p `Union` q) k ys = sep1 g p k ys
+ `union_`
+ (aboveNest q False k (reduceDoc (vcat ys)))
+
+sep1 g Empty k ys = mkNest k (sepX g ys)
+sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys)
+
+sep1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
+sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)
+
+-- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
+-- Called when we have already found some text in the first item
+-- We have to eat up nests
+
+sepNB g (Nest _ p) k ys = sepNB g p k ys
+
+sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest))
+ `mkUnion`
+ nilAboveNest False k (reduceDoc (vcat ys))
+ where
+ rest | g = hsep ys
+ | otherwise = hcat ys
+
+sepNB g p k ys = sep1 g p k ys
+
+-- ---------------------------------------------------------------------------
+-- @fill@
+
+fsep = fill True
+fcat = fill False
+
+-- Specification:
+-- fill [] = empty
+-- fill [p] = p
+-- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
+-- (fill (oneLiner p2 : ps))
+-- `union`
+-- p1 $$ fill ps
+
+fill g [] = empty
+fill g (p:ps) = fill1 g (reduceDoc p) 0 ps
+
+
+fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
+fill1 g _ k ys | k `seq` False = undefined
+fill1 g NoDoc k ys = NoDoc
+fill1 g (p `Union` q) k ys = fill1 g p k ys
+ `union_`
+ (aboveNest q False k (fill g ys))
+
+fill1 g Empty k ys = mkNest k (fill g ys)
+fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys)
+
+fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))
+fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)
+
+fillNB g _ k ys | k `seq` False = undefined
+fillNB g (Nest _ p) k ys = fillNB g p k ys
+fillNB g Empty k [] = Empty
+fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
+ `mkUnion`
+ nilAboveNest False k (fill g (y:ys))
+ where
+ k1 | g = k - 1
+ | otherwise = k
+
+fillNB g p k ys = fill1 g p k ys
+
+
+-- ---------------------------------------------------------------------------
+-- Selecting the best layout
+
+best :: Mode
+ -> Int -- Line length
+ -> Int -- Ribbon length
+ -> RDoc
+ -> RDoc -- No unions in here!
+
+best OneLineMode w r p
+ = get p
+ where
+ get Empty = Empty
+ get NoDoc = NoDoc
+ get (NilAbove p) = nilAbove_ (get p)
+ get (TextBeside s sl p) = textBeside_ s sl (get p)
+ get (Nest k p) = get p -- Elide nest
+ get (p `Union` q) = first (get p) (get q)
+
+best mode w r p
+ = get w p
+ where
+ get :: Int -- (Remaining) width of line
+ -> Doc -> Doc
+ get w _ | w==0 && False = undefined
+ get w Empty = Empty
+ get w NoDoc = NoDoc
+ get w (NilAbove p) = nilAbove_ (get w p)
+ get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
+ get w (Nest k p) = nest_ k (get (w - k) p)
+ get w (p `Union` q) = nicest w r (get w p) (get w q)
+
+ get1 :: Int -- (Remaining) width of line
+ -> Int -- Amount of first line already eaten up
+ -> Doc -- This is an argument to TextBeside => eat Nests
+ -> Doc -- No unions in here!
+
+ get1 w _ _ | w==0 && False = undefined
+ get1 w sl Empty = Empty
+ get1 w sl NoDoc = NoDoc
+ get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p)
+ get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)
+ get1 w sl (Nest k p) = get1 w sl p
+ get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
+ (get1 w sl q)
+
+nicest w r p q = nicest1 w r 0 p q
+nicest1 w r sl p q | fits ((w `minn` r) - sl) p = p
+ | otherwise = q
+
+fits :: Int -- Space available
+ -> Doc
+ -> Bool -- True if *first line* of Doc fits in space available
+
+fits n p | n < 0 = False
+fits n NoDoc = False
+fits n Empty = True
+fits n (NilAbove _) = True
+fits n (TextBeside _ sl p) = fits (n - sl) p
+
+minn x y | x < y = x
+ | otherwise = y
+
+-- @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
+-- @first@ returns its first argument if it is non-empty, otherwise its second.
+
+first p q | nonEmptySet p = p
+ | otherwise = q
+
+nonEmptySet NoDoc = False
+nonEmptySet (p `Union` q) = True
+nonEmptySet Empty = True
+nonEmptySet (NilAbove p) = True -- NoDoc always in first line
+nonEmptySet (TextBeside _ _ p) = nonEmptySet p
+nonEmptySet (Nest _ p) = nonEmptySet p
+
+-- @oneLiner@ returns the one-line members of the given set of @Doc@s.
+
+oneLiner :: Doc -> Doc
+oneLiner NoDoc = NoDoc
+oneLiner Empty = Empty
+oneLiner (NilAbove p) = NoDoc
+oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
+oneLiner (Nest k p) = nest_ k (oneLiner p)
+oneLiner (p `Union` q) = oneLiner p
+
+
+-- ---------------------------------------------------------------------------
+-- Displaying the best layout
+
+renderStyle style doc
+ = fullRender (mode style)
+ (lineLength style)
+ (ribbonsPerLine style)
+ string_txt
+ ""
+ doc
+
+render doc = showDoc doc ""
+showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc
+
+string_txt (Chr c) s = c:s
+string_txt (Str s1) s2 = s1 ++ s2
+string_txt (PStr s1) s2 = s1 ++ s2
+
+
+fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc)
+fullRender LeftMode _ _ txt end doc = easy_display nl_text txt end (reduceDoc doc)
+
+fullRender mode line_length ribbons_per_line txt end doc
+ = display mode line_length ribbon_length txt end best_doc
+ where
+ best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc)
+
+ hacked_line_length, ribbon_length :: Int
+ ribbon_length = round (fromIntegral line_length / ribbons_per_line)
+ hacked_line_length = case mode of { ZigZagMode -> maxBound; other -> line_length }
+
+display mode page_width ribbon_width txt end doc
+ = case page_width - ribbon_width of { gap_width ->
+ case gap_width `quot` 2 of { shift ->
+ let
+ lay k _ | k `seq` False = undefined
+ lay k (Nest k1 p) = lay (k + k1) p
+ lay k Empty = end
+
+ lay k (NilAbove p) = nl_text `txt` lay k p
+
+ lay k (TextBeside s sl p)
+ = case mode of
+ ZigZagMode | k >= gap_width
+ -> nl_text `txt` (
+ Str (multi_ch shift '/') `txt` (
+ nl_text `txt` (
+ lay1 (k - shift) s sl p)))
+
+ | k < 0
+ -> nl_text `txt` (
+ Str (multi_ch shift '\\') `txt` (
+ nl_text `txt` (
+ lay1 (k + shift) s sl p )))
+
+ other -> lay1 k s sl p
+
+ lay1 k _ sl _ | k+sl `seq` False = undefined
+ lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k + sl) p)
+
+ lay2 k _ | k `seq` False = undefined
+ lay2 k (NilAbove p) = nl_text `txt` lay k p
+ lay2 k (TextBeside s sl p) = s `txt` (lay2 (k + sl) p)
+ lay2 k (Nest _ p) = lay2 k p
+ lay2 k Empty = end
+ in
+ lay 0 doc
+ }}
+
+cant_fail = error "easy_display: NoDoc"
+easy_display nl_text txt end doc
+ = lay doc cant_fail
+ where
+ lay NoDoc no_doc = no_doc
+ lay (Union p q) no_doc = {- lay p -} (lay q cant_fail) -- Second arg can't be NoDoc
+ lay (Nest k p) no_doc = lay p no_doc
+ lay Empty no_doc = end
+ lay (NilAbove p) no_doc = nl_text `txt` lay p cant_fail -- NoDoc always on first line
+ lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc
+
+-- OLD version: we shouldn't rely on tabs being 8 columns apart in the output.
+-- indent n | n >= 8 = '\t' : indent (n - 8)
+-- | otherwise = spaces n
+indent n = spaces n
+
+multi_ch 0 ch = ""
+multi_ch n ch = ch : multi_ch (n - 1) ch
+
+-- (spaces n) generates a list of n spaces
+--
+-- It should never be called with 'n' < 0, but that can happen for reasons I don't understand
+-- Here's a test case:
+-- ncat x y = nest 4 $ cat [ x, y ]
+-- d1 = foldl1 ncat $ take 50 $ repeat $ char 'a'
+-- d2 = parens $ sep [ d1, text "+" , d1 ]
+-- main = print d2
+-- I don't feel motivated enough to find the Real Bug, so meanwhile we just test for n<=0
+spaces n | n <= 0 = ""
+ | otherwise = ' ' : spaces (n - 1)
+
+{- Comments from Johannes Waldmann about what the problem might be:
+
+ In the example above, d2 and d1 are deeply nested, but `text "+"' is not,
+ so the layout function tries to "out-dent" it.
+
+ when I look at the Doc values that are generated, there are lots of
+ Nest constructors with negative arguments. see this sample output of
+ d1 (obtained with hugs, :s -u)
+
+ tBeside (TextDetails_Chr 'a') 1 Doc_Empty) (Doc_NilAbove (Doc_Nest
+ (-241) (Doc_TextBeside (TextDetails_Chr 'a') 1 Doc_Empty)))))
+ (Doc_NilAbove (Doc_Nest (-236) (Doc_TextBeside (TextDetails_Chr 'a') 1
+ (Doc_NilAbove (Doc_Nest (-5) (Doc_TextBeside (TextDetails_Chr 'a') 1
+ Doc_Empty)))))))) (Doc_NilAbove (Doc_Nest (-231) (Doc_TextBeside
+ (TextDetails_Chr 'a') 1 (Doc_NilAbove (Doc_Nest (-5) (Doc_TextBeside
+ (TextDetails_Chr 'a') 1 (Doc_NilAbove (Doc_Nest (-5) (Doc_TextBeside
+ (TextDetails_Chr 'a') 1 Doc_Empty))))))))))) (Doc_NilAbove (Doc_Nest
+-}
diff --git a/Yhc/Core/Internal/Play.hs b/Yhc/Core/Internal/Play.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/Internal/Play.hs
@@ -0,0 +1,24 @@
+
+module Yhc.Core.Internal.Play where
+
+import Control.Monad
+
+class Play a where
+ getChildren :: a -> [a]
+ setChildren :: a -> [a] -> a
+
+
+allChildren :: Play a => a -> [a]
+allChildren x = x : concatMap allChildren (getChildren x)
+
+-- bottom up mapping
+mapUnder :: Play a => (a -> a) -> a -> a
+mapUnder f x = f $ setChildren x $ map (mapUnder f) $ getChildren x
+
+mapUnderM :: (Monad m, Play a) => (a -> m a) -> a -> m a
+mapUnderM f x = f =<< (liftM (setChildren x) $ mapM (mapUnderM f) $ getChildren x)
+
+-- top down mapping
+mapOver :: Play a => (a -> a) -> a -> a
+mapOver f x = setChildren x2 $ map (mapOver f) $ getChildren x2
+ where x2 = f x
diff --git a/Yhc/Core/Invariant.hs b/Yhc/Core/Invariant.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/Invariant.hs
@@ -0,0 +1,176 @@
+
+module Yhc.Core.Invariant(
+ Invariant(..),
+ checkInvariant, ensureInvariant,
+ checkInvariants, ensureInvariants
+ ) where
+
+import Data.List
+import Data.Maybe
+
+import Yhc.Core.Type
+import Yhc.Core.Uniplate
+import Yhc.Core.UniqueName
+import Yhc.Core.FreeVar3
+
+import Yhc.Core.RecursiveLet
+import Yhc.Core.Invariant.LambdaLift
+
+
+-- | Note, not all combinations are yet implemented - they crash at runtime.
+-- If you want any invariant, just email the list.
+data Invariant
+ -- Local and reasonably syntactic
+ = NoCoreLet -- ^ The CoreLet constructor must not occur. Removal reduces sharing
+ | NoCorePos -- ^ The CorePos constructor must not occur.
+ | CoreAppFun -- ^ All CoreFun's must be enclosed in a CoreApp.
+ | CoreAppCon -- ^ All CoreCon's must be enclosed in a CoreApp.
+ | NoEmptyApp -- ^ All CoreApp's must not have an empty argument list.
+ | CoreCaseVar -- ^ All CoreCase's must be on a variable.
+ | NoCaseDefault -- ^ All constructor CoreCase's must not contain a default.
+ | NoCaseDefaultOne -- ^ All constructor CoreCase defaults must represent at least two constructors.
+ | NoCaseConst -- ^ All CoreCase's must be on constructors, not constants.
+
+ -- Requires new functions to be created
+ | NoRecursiveLet -- ^ CoreLet's must not be recursive. Removal reduces sharing in limited cases
+ | NoCoreLam -- ^ The CoreLam constructor must not occur.
+ | NoPartialAppPrim -- ^ No partial applications of CoreFun to a CorePrim
+ | NoPartialAppCon -- ^ No partial applications of CoreCon
+
+ -- Uniqueness and Normal Form
+ | ConsecutiveFuncs -- ^ Low function numbers
+ | UniqueVarsFunc -- ^ Unique variables in each function
+ | UniqueVarsCore -- ^ Unique variables in the whole program
+
+ -- Global
+ | FuncArityAtMostOne -- ^ All CoreApp CoreFun's must have at most one argument directly present
+ | FuncArityExactlyOne -- ^ All CoreApp CoreFun's must have exactly one argument present
+ deriving (Eq,Show,Enum,Bounded)
+
+
+---------------------------------------------------------------------
+-- * Check Invariants
+
+checkInvariants :: [Invariant] -> Core -> Bool
+checkInvariants is = null . failingInvariants is
+
+
+failingInvariants :: [Invariant] -> Core -> [Invariant]
+failingInvariants is core = filter (not . flip checkInvariant core) is
+
+
+checkInvariant :: Invariant -> Core -> Bool
+checkInvariant = flip check
+
+
+check core NoCoreLet = not $ any isCoreLet $ universeExpr core
+check core NoCoreLam = not $ any isCoreLam $ universeExpr core
+check core NoCorePos = not $ any isCorePos $ universeExpr core
+
+check core NoRecursiveLet = not $ any isCoreLetRec $ universeExpr core
+
+check core ConsecutiveFuncs = f ids
+ where
+ f (i:j:is) | i == j || i+1 == j = f (j:is)
+ f is = length is <= 1
+
+ ids = sort [i | func <- coreFuncs core, isCoreFunc func
+ , let i = snd $ uniqueSplit $ coreFuncName func, i > 2]
+
+check core NoCaseDefaultOne = True -- skip for now!
+
+check core x = error $ "Yhc.Core.checkInvariant: Not yet implemented, " ++ show x
+
+
+---------------------------------------------------------------------
+-- * Ensure Invariants
+
+-- specifying more than one invariant from any pool is an error
+conflicts = [[CoreAppFun, NoEmptyApp], [CoreAppCon, NoEmptyApp]
+ ,[NoCaseDefault, NoCaseDefaultOne], [FuncArityAtMostOne, FuncArityExactlyOne]
+ ,[CoreCaseVar, NoCoreLet]
+ ]
+
+-- return true if there are any invariants
+anyConflicts :: [Invariant] -> Bool
+anyConflicts is = any ((> 1) . length . intersect is) conflicts
+
+
+-- which invariants require an additional one to be inserted before
+requires = [(NoCoreLet, [NoRecursiveLet])]
+
+addRequires :: [Invariant] -> [Invariant]
+addRequires is = is ++ concatMap (fromMaybe [] . flip lookup requires) is
+
+
+-- anything not specified should be done afterwards
+order = concat [
+ [NoRecursiveLet, NoCoreLam]
+ ]
+
+bestOrder :: [Invariant] -> [Invariant]
+bestOrder is = filter (`elem` is) items
+ where items = order ++ ([minBound..maxBound] \\ order)
+
+
+validate :: [Invariant] -> Core -> Core
+validate is c | null fails = c
+ | otherwise = error $ "Yhc.Core.ensureInvariants: BRAIN EXPLODED! " ++ show fails
+ where fails = failingInvariants is c
+
+ensureInvariant :: Invariant -> Core -> Core
+ensureInvariant i = ensureInvariants [i]
+
+
+ensureInvariants :: [Invariant] -> Core -> Core
+ensureInvariants is core
+ | anyConflicts is = error $ "Yhc.Core.ensureInvariants: conflicting invariants\n" ++ show is
+ | otherwise = validate is $ foldl ensure core $ bestOrder $ addRequires is
+
+
+ensure core NoRecursiveLet = removeRecursiveLet core
+ensure core NoCoreLam = coreLambdaLift core
+
+ensure core NoCorePos = transformExpr remCorePos core
+
+ensure core NoCoreLet = transformExpr f core
+ where
+ f (CoreLet bind x) = replaceFreeVars bind x
+ f x = x
+
+ensure core NoCaseDefault = caseRemoveDefault True core
+ensure core NoCaseDefaultOne = caseRemoveDefault False core
+
+ensure core ConsecutiveFuncs = uniqueFuncsRename core
+
+ensure core x = error $ "Yhc.Core.ensureInvariant: Not yet implemented, " ++ show x
+
+
+---------------------------------------------------------------------
+-- ** Case Default Removal
+
+
+caseRemoveDefault :: Bool -> Core -> Core
+caseRemoveDefault alls core = transformExpr f core
+ where
+ check 0 = True
+ check n = alls || n == 1
+
+ f (CoreCase on alts)
+ | length alts > 1 && isPatDefault deflhs && not (null seen) &&
+ isJust dat && check (length missing)
+ = CoreCase on $ init alts ++ concatMap g (coreDataCtors $ fromJust dat)
+ where
+ (deflhs,defrhs) = last alts
+ missing = map coreCtorName (coreDataCtors $ fromJust dat) \\ seen
+ dat = coreCtorDataMaybe core (head seen)
+ seen = [c | (PatCon c _,_) <- alts]
+ free = freeVars 'v' \\ collectAllVars defrhs
+
+ g c | name `notElem` seen = [(PatCon name vars, defrhs)]
+ where
+ vars = take (length $ coreCtorFields c) free
+ name = coreCtorName c
+ g _ = []
+
+ f x = x
diff --git a/Yhc/Core/Invariant/LambdaLift.hs b/Yhc/Core/Invariant/LambdaLift.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/Invariant/LambdaLift.hs
@@ -0,0 +1,32 @@
+
+module Yhc.Core.Invariant.LambdaLift(coreLambdaLift) where
+
+import Yhc.Core.Type
+import Yhc.Core.Uniplate
+import Yhc.Core.UniqueName
+import Yhc.Core.FreeVar
+import Data.List
+
+
+coreLambdaLift :: Core -> Core
+coreLambdaLift = coreLambdaName . coreLambdaClosure
+
+
+coreLambdaName :: Core -> Core
+coreLambdaName = uniqueFuncsSplit f
+ where
+ f newFunc addFunc = transformM (g newFunc addFunc)
+
+ g newFunc addFunc (CoreLam bind body) = do
+ newname <- newFunc
+ addFunc $ CoreFunc newname bind body
+ return $ CoreFun newname
+ g newFunc addFunc x = return x
+
+
+coreLambdaClosure :: Core -> Core
+coreLambdaClosure = transformExpr f
+ where
+ f x@(CoreLam bind body) = coreApp (CoreLam (free++bind) body) (map CoreVar free)
+ where free = nub $ collectFreeVars x
+ f x = x
diff --git a/Yhc/Core/Overlay.hs b/Yhc/Core/Overlay.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/Overlay.hs
@@ -0,0 +1,52 @@
+
+module Yhc.Core.Overlay(coreOverlay) where
+
+import Yhc.Core.Type
+import Yhc.Core.Uniplate
+import Yhc.Core.Prim
+
+import qualified Data.Set as Set
+import Data.List
+import Data.Char
+
+
+-- | coreOverlay original overlay, returns original with the overlay substituted in
+coreOverlay :: Core -> Core -> Core
+coreOverlay original overlay = original
+ {coreDatas = filter localData (coreDatas overlay2) ++ coreDatas original
+ ,coreFuncs = coreFuncs overlay2 ++ filter (not . (`Set.member` ignore) . coreFuncName) (coreFuncs original)}
+ where
+ overlay2 = decodeOverlay overlay
+ ignore = Set.fromList $ map coreFuncName $ coreFuncs overlay2
+ localData = not . isPrefixOf "Global_" . dropModNames . coreDataName
+
+
+decodeOverlay :: Core -> Core
+decodeOverlay core = core{coreFuncs = transformExpr f $ map g $ coreFuncs core}
+ where
+ g func = func{coreFuncName = decodeString $ coreFuncName func}
+
+ f (CoreFun x) = CoreFun $ decodeString x
+ f (CoreCon x) = CoreCon $ decodeString x
+ f x = x
+
+
+
+names = [";'","'ap","._","=eq",">gt"," String
+decodeString x | "global_" `isPrefixOf` map toLower x2 = f (drop 7 x2)
+ | otherwise = x
+ where
+ x2 = dropModNames x
+
+ f ('\'':xs) | not (null chrs) = let (y,ys) = head chrs in y : f (drop (length ys) xs)
+ where chrs = [(y,ys) | y:ys <- names, ys `isPrefixOf` xs]
+ f (x:xs) = x : f xs
+ f [] = []
+
+
+dropModNames :: String -> String
+dropModNames = reverse . takeWhile (/= ';') . reverse
+
diff --git a/Yhc/Core/Play.hs b/Yhc/Core/Play.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/Play.hs
@@ -0,0 +1,93 @@
+
+module Yhc.Core.Play where
+
+import Yhc.Core.Type
+import Yhc.Core.Internal.Play
+
+import Control.Exception
+import Control.Monad
+
+
+-- | All the variables in a CoreExpr
+allCoreVar :: CoreExpr -> [String]
+allCoreVar x = [i | CoreVar i <- allCore x]
+
+
+class PlayCore a where
+ getChildrenCore :: a -> [CoreExpr]
+ setChildrenCore :: a -> [CoreExpr] -> a
+
+
+ allCore :: a -> [CoreExpr]
+ allCore x = concatMap allCore (getChildrenCore x)
+
+ mapOverCore :: (CoreExpr -> CoreExpr) -> a -> a
+ mapOverCore f x = setChildrenCore x $ map (mapOverCore f) $ getChildrenCore x
+
+ mapUnderCore :: (CoreExpr -> CoreExpr) -> a -> a
+ mapUnderCore f x = setChildrenCore x $ map (mapUnderCore f) $ getChildrenCore x
+
+ mapUnderCoreM :: Monad m => (CoreExpr -> m CoreExpr) -> a -> m a
+ mapUnderCoreM f x = liftM (setChildrenCore x) $ mapM (mapUnderCoreM f) $ getChildrenCore x
+
+
+instance Play CoreExpr where
+ getChildren = getChildrenCore
+ setChildren = setChildrenCore
+
+
+instance PlayCore CoreExpr where
+ getChildrenCore x =
+ case x of
+ CoreApp x xs -> x:xs
+ CoreCase x xs -> (x : map snd xs)
+ CoreLet x xs -> xs: map snd x
+ CoreLam x xs -> [xs]
+ CorePos x xs -> [xs]
+ _ -> []
+
+ setChildrenCore x ys =
+ case x of
+ CoreApp _ _ -> CoreApp (head ys) (tail ys)
+
+ CoreCase _ xs -> CoreCase (head ys) (zip (map fst xs) (tail ys))
+
+ CoreLet x _ -> CoreLet (zip (map fst x) (tail ys)) (head ys)
+
+ CoreLam x _ -> let [y1] = ys in CoreLam x y1
+
+ CorePos p _ -> let [y1] = ys in CorePos p y1
+
+ x -> assert (null ys) x
+
+
+ allCore = allChildren
+ mapOverCore = mapOver
+ mapUnderCore = mapUnder
+ mapUnderCoreM = mapUnderM
+
+
+instance PlayCore a => PlayCore [a] where
+ getChildrenCore x = concatMap getChildrenCore x
+
+ setChildrenCore [] [] = []
+ setChildrenCore (x:xs) ys = setChildrenCore x a : setChildrenCore xs b
+ where (a,b) = splitAt (length $ getChildrenCore x) ys
+
+
+instance PlayCore CoreFunc where
+ getChildrenCore (CoreFunc a b c) = [c]
+ getChildrenCore x = []
+
+ setChildrenCore (CoreFunc a b _) [c] = CoreFunc a b c
+ setChildrenCore x [] = x
+
+
+instance PlayCore CoreData where
+ getChildrenCore _ = []
+ setChildrenCore x [] = x
+
+
+instance PlayCore Core where
+ getChildrenCore (Core a b c d) = getChildrenCore d
+ setChildrenCore (Core a b c d) ys = Core a b c $ setChildrenCore d ys
diff --git a/Yhc/Core/Prim.hs b/Yhc/Core/Prim.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/Prim.hs
@@ -0,0 +1,154 @@
+
+module Yhc.Core.Prim(
+ Prim(..), PrimOp(..), PrimType(..), primArity,
+ corePrims, corePrim, corePrimMaybe,
+ coreBytecodePrims, coreHaskellPrims, coreHaskellTypes
+ ) where
+
+import Yhc.Core.Type
+import Data.List
+import Data.Maybe
+
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+
+data PrimType = PrimTypeAny | PrimTypeUnknown | PrimTypeHaskell String | PrimIO
+ | PrimInt | PrimInteger | PrimDouble | PrimFloat | PrimChar | PrimString | PrimBool
+ deriving (Eq, Ord)
+
+instance Show PrimType where
+ show x = case x of
+ PrimTypeAny -> "*"
+ PrimTypeUnknown -> "?"
+ PrimTypeHaskell s -> s ++ "#"
+ PrimInt -> "Int"
+ PrimInteger -> "Integer"
+ PrimDouble -> "Double"
+ PrimFloat -> "Float"
+ PrimChar -> "Char"
+ PrimString -> "String"
+ PrimBool -> "Bool"
+
+
+data Prim = Prim
+ {primName :: String
+ ,primType :: [PrimType] -- | a function signature
+ ,primStrict :: [Bool] -- | True is strict in argument n, [] is unknown
+ ,primEval :: [CoreExpr] -> CoreExpr
+ ,primOp :: PrimOp
+ }
+
+primArity :: Prim -> Int
+primArity = length . tail . primType
+
+
+instance Show Prim where
+ show (Prim name typ strict _ other) = name ++ " :: " ++ t ++ " -- " ++ show other
+ where
+ t = concat $ intersperse " -> " $ zipWith f (strict ++ repeat False) typ
+ f s x = ['!'|s] ++ show x
+
+
+data PrimOp = PrimSeq | PrimOrd
+ | PrimAdd | PrimSub | PrimMul
+ | PrimDiv | PrimRem | PrimQuot | PrimQuotRem
+ | PrimNeg | PrimAbs | PrimSignum
+ | PrimEq | PrimNe | PrimLt | PrimGt | PrimLe | PrimGe
+ | PrimCast | PrimHaskell | PrimOther String
+ deriving Eq
+
+instance Show PrimOp where
+ show (PrimOther x) = x
+ show x = fromMaybe (error "here") $ lookup x table
+ where
+ table = [(PrimSeq,"seq")
+ ,(PrimAdd,"+"),(PrimSub,"-"),(PrimMul,"*")
+ ,(PrimDiv,"/"),(PrimRem,"rem"),(PrimQuot,"quot"),(PrimQuotRem,"quotRem")
+ ,(PrimEq,"=="),(PrimNe,"/="),(PrimLt,"<"),(PrimGt,">"),(PrimLe,"<="),(PrimGe,">=")
+ ,(PrimCast,"cast")
+ ,(PrimNeg,"negate"),(PrimAbs,"abs"),(PrimSignum,"signum")
+ ,(PrimHaskell,"Haskell")]
+
+
+corePrims :: [Prim]
+corePrims = coreBytecodePrims ++ coreHaskellPrims
+
+
+coreBytecodePrims :: [Prim]
+coreBytecodePrims =
+ [Prim "SEQ" [PrimTypeAny,PrimTypeAny,PrimTypeAny] [True,True] undefined PrimSeq
+ ,Prim "ORD" [PrimTypeAny,PrimInt] [True] undefined PrimOrd
+ ,add "ADD_W" PrimInt, add "YHC.Primitive.primIntegerAdd" PrimInteger
+ ,sub "SUB_W" PrimInt, sub "YHC.Primitive.primIntegerSub" PrimInteger
+ ,neg "NEG_W" PrimInt, neg "YHC.Primitive.primIntegerNeg" PrimInteger
+ ,abs "YHC.Primitive.primIntAbs" PrimInt
+ ,signum "YHC.Primitive.primIntSignum" PrimInt
+ ,mul "MUL_W" PrimInt, mul "YHC.Primitive.primIntegerMul" PrimInteger
+ ,div "SLASH_D" PrimDouble, div "SLASH_F" PrimFloat
+ ,rem "REM" PrimInt, rem "YHC.Primitive.primIntegerRem" PrimInteger
+ ,quot "QUOT" PrimInt, quot "YHC.Primitive.primIntegerQuot" PrimInteger
+ ,quotRem "YHC.Primitive.primIntegerQuotRem" PrimInteger
+ ,eq "EQ_W" PrimInt, eq "YHC.Primitive.primIntegerEq" PrimInteger, eq "EQ_F" PrimFloat
+ ,ne "NE_W" PrimInt, ne "YHC.Primitive.primIntegerNe" PrimInteger, ne "NE_F" PrimFloat
+ ,lt "LT_W" PrimInt, lt "YHC.Primitive.primIntegerLt" PrimInteger, lt "LT_F" PrimFloat
+ ,le "LE_W" PrimInt, le "YHC.Primitive.primIntegerLe" PrimInteger, le "LE_F" PrimFloat
+ ,gt "GT_W" PrimInt, gt "YHC.Primitive.primIntegerGt" PrimInteger, gt "GT_F" PrimFloat
+ ,ge "GE_W" PrimInt, ge "YHC.Primitive.primIntegerGe" PrimInteger, ge "GE_F" PrimFloat
+ ,cast "YHC.Primitive.primDoubleFromInteger" PrimInteger PrimDouble
+ ,cast "YHC.Primitive.primIntFromInteger" PrimInteger PrimInt
+ ,cast "YHC.Primitive.primIntegerFromInt" PrimInt PrimInteger
+ ,ne "NE_D" PrimDouble, eq "EQ_D" PrimDouble
+ ,lt "LT_D" PrimDouble, le "LE_D" PrimDouble
+ ,gt "GT_D" PrimDouble, ge "GE_D" PrimDouble
+ ,mul "MUL_D" PrimDouble, add "ADD_D" PrimDouble, sub "SUB_D" PrimDouble,neg "NEG_D" PrimDouble
+ ,mul "MUL_F" PrimFloat , add "ADD_F" PrimFloat , sub "SUB_F" PrimFloat ,neg "NEG_F" PrimFloat
+ ]
+ where
+ add = trip PrimAdd; sub = trip PrimSub; mul = trip PrimMul;
+ div = trip PrimDiv; rem = trip PrimRem; quot = trip PrimQuot
+ quotRem = tup PrimQuotRem
+ eq = comp PrimEq; ne = comp PrimNe; lt = comp PrimLt; gt = comp PrimGt
+ le = comp PrimLe; ge = comp PrimGe
+ neg = one PrimNeg; abs = one PrimAbs; signum = one PrimSignum
+
+ trip symbol name typ = Prim name [typ,typ,typ] [True,True] undefined symbol
+ comp symbol name typ = Prim name [typ,typ,PrimBool] [True,True] undefined symbol
+ one symbol name typ = Prim name [typ,typ] [True] undefined symbol
+ tup symbol name typ = Prim name [typ,typ,PrimTypeUnknown] [True,True] undefined symbol
+ cast name from to = Prim name [from,to] [True] undefined PrimCast
+
+
+corePrim :: String -> Prim
+corePrim s = fromMaybe (error $ "Yhc.Core.Prim.corePrim, could not find primitive: " ++ s) $ corePrimMaybe s
+
+
+corePrimMaybe :: String -> Maybe Prim
+corePrimMaybe search = listToMaybe [x | x <- corePrims, primName x == search]
+
+
+coreHaskellPrims :: [Prim]
+coreHaskellPrims =
+ [hask "System.IO.stdout" [handle]
+ ,hask "System.IO.stderr" [handle]
+ ,hask "System.IO.stdin" [handle]
+ ,hask "System.IO.hPutChar" [handle,PrimChar,io]
+ ,hask "Prelude.putChar" [PrimChar,io]
+ ,hask "Prelude.getChar" [PrimTypeHaskell "IO Char"]
+ ,hask "System.Environment.getArgs" [PrimTypeHaskell "IO [String]"]
+ ,hask "Prelude.error" [PrimString, PrimTypeAny]
+ ,Prim "Prelude.strError" [] [] undefined (PrimOther "show")
+ ]
+ where
+ handle = PrimTypeHaskell "System.IO.Handle"
+ io = PrimTypeHaskell "IO ()"
+ hask name typs = Prim name typs [] undefined PrimHaskell
+
+
+coreHaskellTypes :: [(String, String)]
+coreHaskellTypes =
+ [("YHC.Primitive.Handle", "System.IO.Handle")
+ ,("Prelude.Char","Prelude.Int")
+ ,("Prelude.Int","Prelude.Int")
+ ,("Prelude.String","[Prelude.Char]")
+ ]
diff --git a/Yhc/Core/Reachable.hs b/Yhc/Core/Reachable.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/Reachable.hs
@@ -0,0 +1,35 @@
+
+module Yhc.Core.Reachable(coreReachable, coreReachableMap) where
+
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Yhc.Core.Type
+import Yhc.Core.Uniplate
+
+
+coreReachable :: [CoreFuncName] -> Core -> Core
+coreReachable root = coreReachableDatas . coreReachableFuncs root
+
+
+coreReachableDatas :: Core -> Core
+coreReachableDatas core = core{coreDatas = filter used (coreDatas core)}
+ where
+ ctors = Set.fromList $ [x | CoreCon x <- universeExpr core] ++
+ [x | CoreCase _ alts <- universeExpr core, (PatCon x _,_) <- alts]
+
+ used dat = any (`Set.member` ctors) (map coreCtorName $ coreDataCtors dat)
+
+
+coreReachableFuncs :: [CoreFuncName] -> Core -> Core
+coreReachableFuncs root core = fromCoreFuncMap core $ coreReachableMap root $ toCoreFuncMap core
+
+
+coreReachableMap :: [CoreFuncName] -> CoreFuncMap -> CoreFuncMap
+coreReachableMap root fm = f Map.empty root
+ where
+ f seen [] = seen
+ f seen (x:xs) | x `Map.member` seen = f seen xs
+ | otherwise = f (Map.insert x func seen) (calls ++ xs)
+ where
+ func = coreFuncMap fm x
+ calls = [y | CoreFun y <- universeExpr func]
diff --git a/Yhc/Core/RecursiveLet.hs b/Yhc/Core/RecursiveLet.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/RecursiveLet.hs
@@ -0,0 +1,77 @@
+
+module Yhc.Core.RecursiveLet(
+ isCoreLetRec,
+ removeRecursiveLet,
+ reduceRecursiveLet
+ ) where
+
+import Yhc.Core.Type
+import Yhc.Core.Uniplate
+import Yhc.Core.FreeVar
+import Yhc.Core.UniqueName
+
+import Control.Monad
+import Control.Monad.State
+import Data.List
+
+
+-- | Remove recursive lets
+--
+-- Let's are rearranged so a variable is not used in the defining block
+removeRecursiveLet :: Core -> Core
+removeRecursiveLet = uniqueFuncsSplit (remRecLet True)
+
+
+-- | Reduce the number of recursive lets, but splitting lets
+-- which have recursive bindings, but can be linearised
+reduceRecursiveLet :: Core -> Core
+reduceRecursiveLet = uniqueFuncsSplit (remRecLet False)
+
+
+remRecLet :: Monad m => Bool -> m CoreFuncName -> (CoreFunc -> m ()) -> CoreExpr -> m CoreExpr
+remRecLet always newFunc addFunc = f
+ where
+ f (CoreLet [] x) = f x
+
+ -- handle the variables which are mixed up, but not actually recursive
+ -- let a = b; b = 1 in a
+ f (CoreLet binds x) | not (null free) = do
+ free2 <- mapM (\(a,b) -> liftM ((,) a) $ f b) free
+ locked2 <- f (CoreLet locked x)
+ return $ CoreLet free2 locked2
+ where
+ defined = map fst binds
+ (locked,free) = partition (isLocked . snd) binds
+
+ isLocked = any (`elem` defined) . collectFreeVars
+
+ -- handle the truely recursive ones
+ -- let xs = x:xs in xs
+ f (CoreLet binds x) | always = do
+ names <- replicateM (length binds) newFunc
+ let binds2 = zip lhs (map (\x -> CoreApp (CoreFun x) (map CoreVar vars)) names)
+ newfuncs <- zipWithM (g (zip lhs names) binds2) names rhs
+ mapM_ addFunc newfuncs
+
+ x2 <- f x
+ return $ CoreLet binds2 x2
+ where
+ (lhs,rhs) = unzip binds
+ vars = nub (concatMap collectFreeVars rhs) \\ lhs
+
+ g mapping binds2 name rhs = do
+ let free = collectFreeVars rhs
+ binds3 = filter ((`elem` free) . fst) binds2
+ body <- f $ CoreLet binds3 rhs
+ return $ CoreFunc name vars body
+
+ f x = descendM f x
+
+
+-- | Is a CoreLet recursive, i.e. do any of the introduced variables (LHS of bind)
+-- also show up in the RHS of bind.
+--
+-- Returns False if the expression is not a CoreLet.
+isCoreLetRec :: CoreExpr -> Bool
+isCoreLetRec (CoreLet bind xs) = not $ null $ map fst bind `intersect` concatMap (collectFreeVars . snd) bind
+isCoreLetRec x = False
diff --git a/Yhc/Core/Saturated.hs b/Yhc/Core/Saturated.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/Saturated.hs
@@ -0,0 +1,22 @@
+
+module Yhc.Core.Saturated(coreSaturated) where
+
+import Yhc.Core.Type
+import qualified Data.Map as Map
+
+
+-- | Given an expr (normally a 'CoreApp')
+-- say if it is saturated or not.
+coreSaturated :: Core -> (CoreExpr -> Bool)
+coreSaturated core =
+ \x -> case x of
+ CoreApp (CoreFun x) ys -> f funcArity x ys
+ CoreApp (CoreCon x) ys -> f ctorArity x ys
+ _ -> False
+ where
+ ctorArity = Map.fromList [(name, length args) | dat <- coreDatas core, (CoreCtor name args) <- coreDataCtors dat]
+ funcArity = Map.fromList [(name, length args) | CoreFunc name args _ <- coreFuncs core]
+
+ f mp x ys = case Map.lookup x mp of
+ Nothing -> False
+ Just xn -> xn == length ys
diff --git a/Yhc/Core/Serialise.hs b/Yhc/Core/Serialise.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/Serialise.hs
@@ -0,0 +1,25 @@
+
+module Yhc.Core.Serialise(saveCore, loadCore) where
+
+import Yhc.Core.Type
+import Yhc.Core.Binary
+import Yhc.Core.Internal.Binary
+import System.IO
+
+
+coreStr :: String
+coreStr = "YHC-CORE"
+coreVer :: Int
+coreVer = 4
+
+saveCore :: FilePath -> Core -> IO ()
+saveCore file core = writeBinary file (coreStr,coreVer,core)
+
+loadCore :: FilePath -> IO Core
+loadCore file = do
+ hndl <- openBinaryFile file ReadMode
+ a <- get hndl
+ b <- get hndl
+ if a /= coreStr && b /= coreVer
+ then hClose hndl >> error ("Incompatible Core file, " ++ file)
+ else do c <- get hndl; hClose hndl; return c
diff --git a/Yhc/Core/Show.hs b/Yhc/Core/Show.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/Show.hs
@@ -0,0 +1,122 @@
+
+module Yhc.Core.Show(showCoreExprGroup, isCoreOperator) where
+
+import Data.List
+import Data.Maybe
+import Data.Char
+import Yhc.Core.Type
+
+import Text.PrettyPrint.HughesPJ
+
+
+
+instance Show Core where
+ show (Core modName depends datas funcs) =
+ "module " ++ modName ++ " where\n" ++
+ concatMap ("\nimport " ++) depends ++
+ concatMap ("\n\n"++) (map show datas ++ map show funcs)
+
+instance Show CoreData where
+ show (CoreData name free []) = "data " ++ name ++ concatMap (' ':) free
+ show (CoreData name free (x:xs)) =
+ show (CoreData name free []) ++ " =\n" ++
+ " " ++ show x ++
+ concatMap (("\n | " ++) . show) xs
+
+
+instance Show CoreFunc where
+ show x = render $ docFunc x
+
+
+instance Show CoreCtor where
+ show (CoreCtor name args) = name ++ " " ++
+ ['{' | useRecords] ++
+ (concat $ intersperse sep $ map f args) ++
+ ['}' | useRecords]
+ where
+ useRecords = any (isJust . snd) args
+ sep = ([','|useRecords]++" ")
+
+ f (typ, Nothing) = typ
+ f (typ, Just x) = "_" ++ x ++ " :: " ++ typ
+
+
+instance Show CoreExpr where
+ show = render . docExpr False
+
+
+inner :: Doc -> Doc
+inner = nest 4
+
+(<>>) :: Doc -> Doc -> Doc
+a <>> b = sep [a, inner b]
+
+
+docFunc :: CoreFunc -> Doc
+docFunc (CorePrim name arity ext conv imp types) =
+ text "foreign" <+> text (if imp then "import" else "export") <+> text conv <+> doubleQuotes (text ext) <+> text name <+> text "::" <+> strtype
+ where
+ strtype = text $ concat $ intersperse " -> " types
+docFunc (CoreFunc name args body) = text initial <>> docExpr False body
+ where initial = unwords (name:args) ++ " ="
+
+
+-- | Show a CoreExpr, but with brackets if needed
+-- so the result is a group. Does not bracket
+-- simple variables or constants etc
+showCoreExprGroup :: CoreExpr -> String
+showCoreExprGroup = render . docExpr True
+
+
+-- True is bracket, False is don't
+docExpr :: Bool -> CoreExpr -> Doc
+docExpr b x = f b x
+ where
+ -- True is do bracketing
+ -- False is don't
+
+ f b (CoreCon x) = f b (CoreVar x)
+ f b (CoreFun x) = f b (CoreVar x)
+ f b (CoreVar x) | isCoreOperator x = parens $ text x
+ | otherwise = text x
+
+ f b (CorePos x y) = f b y
+ f b (CoreLit x) = docLit x
+
+ f b (CoreApp x []) = f b x
+ f b (CoreApp x xs) = brack b $ call (f True x) (map (f True) xs)
+
+ f b (CoreLam xs x) = brack b $ text ('\\' : unwords xs) <+> text "->" <+> f False x
+
+ f b (CoreCase on alts) = brack b (text "case" <+> f True on <+> text "of" $$ inner (vcat $ map g alts))
+ where
+ g (a,b) = (f False (patToExpr a) <+> text "->") <>> f False b
+
+ f b (CoreLet binds x) = brack b $ text "let" <+> vcat (map g binds) $$ text "in" <+> f False x
+ where
+ g (lhs,rhs) = text (lhs ++ " =") <>> f False rhs
+
+ call x xs = sep $ x : map (nest 2) xs
+
+brack b = if b then parens else id
+
+
+docLit :: CoreLit -> Doc
+docLit x = f x
+ where
+ f (CoreChr x) = text $ show x
+ f (CoreInt x) = showNum x
+ f (CoreStr x) = showNum x
+ f (CoreInteger x) = showNum x
+ f (CoreFloat x) = showNum x
+ f (CoreDouble x) = showNum x
+
+ showNum x = brack (head s == '-') $ text s
+ where s = show x
+
+
+
+isCoreOperator :: String -> Bool
+isCoreOperator x = case dropModule x of
+ (x:_) | isAlphaNum x || x `elem` " '_([" -> False
+ _ -> True
diff --git a/Yhc/Core/ShowRaw.hs b/Yhc/Core/ShowRaw.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/ShowRaw.hs
@@ -0,0 +1,67 @@
+{-|
+ ShowRaw is intended for debugging, to print a rather complete
+ syntax tree. The basic rule is that every constructor MUST appear
+ visibly in the output. For example, @show (CoreApp x []) == show x@,
+ but @(showRaw x == showRaw y) ==> (x == y)@.
+-}
+module Yhc.Core.ShowRaw(ShowRaw(..)) where
+
+import Yhc.Core.Type
+import Data.List
+
+g x = "(" ++ unwords x ++ ")"
+s x = showRaw x
+
+showRawList xs = "[" ++ concat (intersperse "," xs) ++ "]"
+
+
+class ShowRaw a where
+ showRaw :: a -> String
+
+instance (ShowRaw a, ShowRaw b) => ShowRaw (a,b) where
+ showRaw (a,b) = "(" ++ showRaw a ++ "," ++ showRaw b ++ ")"
+
+instance ShowRaw a => ShowRaw [a] where
+ showRaw xs = showRawList $ map showRaw xs
+
+
+instance ShowRaw Core where
+ showRaw (Core a b c d) = g ["Core", a, showRawList b, s c, s d]
+
+instance ShowRaw CoreData where
+ showRaw (CoreData a b c) = g ["Data", a, showRawList b, s c]
+
+instance ShowRaw CoreCtor where
+ showRaw (CoreCtor a b) = g ["Ctor", a, showRawList $ map f b]
+ where
+ f (a,Nothing) = a
+ f (a,Just b) = b++"="++a
+
+instance ShowRaw CoreFunc where
+ showRaw (CoreFunc a b c) = g ["Func", a, showRawList b, s c]
+ showRaw (CorePrim a b c d e f) = g ["Prim", a, show b, c, d, show e, showRawList f]
+
+instance ShowRaw CoreExpr where
+ showRaw (CoreCon a) = g ["Con", a]
+ showRaw (CoreVar a) = g ["Var", a]
+ showRaw (CoreFun a) = g ["Fun", a]
+ showRaw (CoreApp a b) = g ("App" : s a : map s b)
+ showRaw (CoreLam vs x) = g ("Lam" : vs ++ [s x])
+ showRaw (CoreCase on alts) = g ["Case", s on, s alts]
+ showRaw (CorePos a b) = g ["Pos",show a, s b]
+ showRaw (CoreLit a) = g ["Lit",s a]
+ showRaw (CoreLet vs x) = g ["Let", showRawList $ map f vs, s x]
+ where f (a,b) = "(" ++ a ++ "," ++ s b ++ ")"
+
+instance ShowRaw CoreLit where
+ showRaw (CoreInt a) = g ["Int", show a]
+ showRaw (CoreInteger a) = g ["Integer", show a]
+ showRaw (CoreChr a) = g ["Char", show a]
+ showRaw (CoreStr a) = g ["Str", show a]
+ showRaw (CoreFloat a) = g ["Float", show a]
+ showRaw (CoreDouble a) = g ["Double", show a]
+
+instance ShowRaw CorePat where
+ showRaw (PatCon a b) = g ("PatCon":a:b)
+ showRaw (PatLit a) = g ["PatLit",s a]
+ showRaw (PatDefault) = g ["PatDefault"]
diff --git a/Yhc/Core/Simplify.hs b/Yhc/Core/Simplify.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/Simplify.hs
@@ -0,0 +1,273 @@
+{-
+THIS MODULE NEEDS REDRAFTING
+
+With the new rewrite semantics of traverse it should be possible to
+have a terminating, confluent, rewriting version - which allows others
+to add to the rules.
+
+Would also be nice if we could specify the free variable properties
+more efficiently, and only once.
+-}
+
+
+module Yhc.Core.Simplify(
+ coreSimplify, coreSimplifyExpr,
+ coreSimplifyCaseCon, coreSimplifyCaseCase, coreSimplifyCaseLet,
+ coreSimplifyExprUnique, coreSimplifyExprUniqueExt
+ ) where
+
+import Data.List
+import Data.Maybe
+import Control.Monad
+import Yhc.Core.Internal.General
+
+import Yhc.Core.Type
+import Yhc.Core.Uniplate
+import Yhc.Core.FreeVar3(duplicateExpr)
+import Yhc.Core.FreeVar
+import Yhc.Core.UniqueId
+
+
+
+coreSimplify :: UniplateExpr a => a -> a
+coreSimplify x = context $ map coreSimplifyExpr children
+ where (children,context) = uniplateExpr x
+
+
+
+-- | Simplify a single Core Expr.
+--
+-- Performs NO inlining, guaranteed to run in same or better
+-- space and time. May increase code size.
+--
+-- Bugs lurk here, with inadvertant free variable capture. Move to
+-- a proper free variable monad and a guarantee of uniqueness
+coreSimplifyExpr :: CoreExpr -> CoreExpr
+coreSimplifyExpr = transformExpr f
+ where
+ f (CoreCase (CoreFun x) alts) = f (CoreCase (CoreApp (CoreFun x) []) alts)
+
+ f o@(CoreCase on alts) | isCoreCon $ fst $ fromCoreApp on = transformExpr f $ coreSimplifyCaseCon o
+ f o@(CoreCase (CoreCase _ _) _) = transformExpr f $ coreSimplifyCaseCase o
+ f o@(CoreCase (CoreLet _ _) _) = transformExpr f $ coreSimplifyCaseLet o
+
+ f orig@(CoreApp (CoreCase _ _) _) = f $ CoreCase on (map g alts)
+ where
+ CoreApp (CoreCase on alts) args = uniqueExpr orig
+ g (lhs,rhs) = (lhs, f $ CoreApp rhs args)
+
+ f (CoreCase (CoreLet bind on) alts) = f $ CoreLet bind (f $ CoreCase on alts)
+
+ f (CoreLet bind x) = coreLet many (transformExpr f $ replaceFreeVars once x)
+ where
+ bindVars = [i | CoreVar i <- concatMap (universeExpr . snd) bind]
+ (once,many) = partition (uncurry isValid) bind
+
+ isValid lhs rhs = lhs `notElem` bindVars && (isSimple rhs || countFreeVar lhs x <= 1)
+
+ isSimple (CoreApp x []) = isSimple x
+ isSimple (CoreFun x) = True
+ isSimple (CorePos x y) = isSimple y
+ isSimple (CoreVar x) = True
+ isSimple (CoreApp (CorePos _ (CoreFun name)) args) = isSimple (CoreApp (CoreFun name) args)
+ isSimple _ = False
+
+ f (CoreLet binds (CoreCase on alts1))
+ | disjoint (universeExprVar on) (map fst binds) = f $ CoreCase on (map g alts1)
+ where g (lhs,rhs) = (lhs,f $ coreLet (filter ((`notElem` patVariables lhs) . fst) binds) $ f rhs)
+
+ f (CoreApp (CoreApp x xs) ys) = f $ CoreApp x (xs++ys)
+
+ f o@(CoreApp (CoreLam bind x) args) = transformExpr f $
+ coreApp (coreLam bindnew (replaceFreeVars rep x)) args2
+ where
+ args2 = drop (length bind) args
+ bind2 = drop (length args) bind
+ bindnew = take (length bind2) (freeVars 'v' \\ collectAllVars o)
+ rep = zip bind (args ++ map CoreVar bindnew)
+
+ f x@(CoreApp (CoreLet bind xs) ys) =
+ CoreLet (zip fresh (map rep rhs)) (CoreApp (rep xs) ys)
+ where
+ (lhs,rhs) = unzip bind
+ rep = replaceFreeVars (zip fresh (map CoreVar lhs))
+ fresh = freeVars 'x' \\ collectAllVars x
+
+ f x = x
+
+
+
+-- | Apply the Case (CoreCon ..) rule
+-- This rule has a serious sharing bug (doh!)
+coreSimplifyCaseCon :: CoreExpr -> CoreExpr
+coreSimplifyCaseCon (CoreCase (CoreCon con) alts) = coreSimplifyCaseCon $ CoreCase (CoreApp (CoreCon con) []) alts
+coreSimplifyCaseCon (CoreCase on@(CoreApp (CoreCon con) fields) alts)
+ | not $ null matches = head matches
+ where
+ matches = mapMaybe g alts
+
+ g (PatCon x xs, rhs) | x == con = Just $ replaceFreeVars (zip xs fields) rhs
+ g (PatDefault, rhs) = Just rhs
+ g _ = Nothing
+coreSimplifyCaseCon x = x
+
+
+-- | Apply the Case (Case ..) rule
+coreSimplifyCaseCase :: CoreExpr -> CoreExpr
+coreSimplifyCaseCase o@(CoreCase (CoreCase on alts1) alts2) = CoreCase on (map g alts1)
+ where
+ vars = freeVars 'v' \\ collectAllVars o
+ g (PatCon c vs,rhs) = (PatCon c vs2, CoreCase rhs2 alts2)
+ where
+ vs2 = take (length vs) vars
+ rhs2 = replaceFreeVars (zip vs (map CoreVar vs2)) rhs
+ g (lhs,rhs) = (lhs, CoreCase rhs alts2)
+coreSimplifyCaseCase x = x
+
+
+-- | Apply the Case (Let ..) rule
+coreSimplifyCaseLet :: CoreExpr -> CoreExpr
+coreSimplifyCaseLet o@(CoreCase (CoreLet bind x) alts) =
+ CoreLet (zipWith f newvars bind) (CoreCase (rep x) alts)
+ where
+ newvars = freeVars 'v' \\ collectAllVars o
+ rep = replaceFreeVars $ zip (map fst bind) (map CoreVar newvars)
+ f new (lhs,rhs) = (new, rep rhs)
+
+
+
+uniqueExpr :: CoreExpr -> CoreExpr
+uniqueExpr x = uniqueBoundVarsWithout (collectAllVars x) x
+
+
+freeVars :: Char -> [String]
+freeVars c = [c:show i | i <- [1..]]
+
+
+{- |
+ Precondition:
+ All variables must be unique
+
+ The following patterns must not occur:
+
+ CoreApp _ []
+ CoreLet [] _
+ CoreLam [] _
+ CorePos _ _
+
+ CoreCase on _ => on `notElem` {CoreCon _, CoreApp (CoreCon _) _, CoreLet _ _, CoreCase _ _}
+ CoreApp x _ => x `notElem` {CoreApp _ _, CoreLet _ _, CoreCase _ _, CoreLam _ _}
+ CoreLet bind _ => all (map snd bind) `notElem` {CoreLet _ _, CoreVar _}
+
+ The following should be applied if possible (and not breaking sharing):
+
+ CoreLet bind x => replaceFreeVars bind x
+ CoreLet (CoreCase x alts) => CoreCase x (CoreLet inside each alt)
+-}
+coreSimplifyExprUnique :: UniqueIdM m => CoreExpr -> m CoreExpr
+coreSimplifyExprUnique = coreSimplifyExprUniqueExt (const return)
+
+
+{- |
+ Sismplify in an extensible manner.
+
+ @myfunc retransform@
+
+ You should invoke retransform on all constructors you create.
+-}
+coreSimplifyExprUniqueExt :: UniqueIdM m => (
+ (CoreExpr -> m CoreExpr) ->
+ (CoreExpr -> m CoreExpr)
+ ) -> CoreExpr -> m CoreExpr
+coreSimplifyExprUniqueExt ext = fs
+ where
+ fs = transformM f
+
+ -- helpers, ' is yes, _ is no
+ coreCase__ x y = f $ CoreCase x y ; coreCase_' x y = f . CoreCase x =<< y
+ coreLet__ x y = f $ CoreLet x y ; coreLet_' x y = f . CoreLet x =<< y
+ coreLam__ x y = f $ CoreLam x y ; coreLam_' x y = f . CoreLam x =<< y
+ coreApp__ x y = f $ CoreApp x y ; coreApp'_ x y = f . flip CoreApp y =<< x
+
+ -- Simplistic transformations
+ f (CorePos _ x ) = return x
+ f (CoreApp x []) = return x
+ f (CoreLet [] x) = return x
+ f (CoreLam [] x) = return x
+
+ -------------------------------------------------------------
+ -- CASE RULES
+
+ -- Case/Con rule
+ f (CoreCase on alts) | isCoreCon con && not (null matches) = head matches
+ where
+ (con,fields) = fromCoreApp on
+ matches = mapMaybe g alts
+
+ g (PatDefault,rhs) = Just $ return rhs
+ g (PatCon x xs, rhs) | x == fromCoreCon con = Just $ coreLet__ (zip xs fields) rhs
+ g _ = Nothing
+
+ -- Case/Case
+ f (CoreCase (CoreCase on alts1) alts2) =
+ coreCase_' on (mapM g alts1)
+ where
+ g (lhs,rhs) = do
+ CoreCase _ alts22 <- duplicateExpr $ CoreCase (CoreLit $ CoreInt 0) alts2
+ rhs2 <- coreCase__ rhs alts22
+ return (lhs,rhs2)
+
+ -- Let's should float upwards
+ f (CoreCase (CoreLet bind x) alts) =
+ coreLet_' bind (coreCase__ x alts)
+
+ -------------------------------------------------------------
+ -- APP RULES
+ f (CoreApp (CoreApp x xs) ys) = coreApp__ x (xs++ys)
+
+ f (CoreApp (CoreLet bind xs) ys) =
+ coreLet_' bind (coreApp__ xs ys)
+
+ f (CoreApp (CoreCase on alts) args) = coreCase_' on (mapM g alts)
+ where
+ g (lhs,rhs) = do
+ args2 <- mapM duplicateExpr args
+ rhs2 <- coreApp__ rhs args2
+ return (lhs,rhs2)
+
+ f (CoreApp (CoreLam bind x) args) =
+ coreApp'_ (coreLam_' bind2 (coreLet__ (zip bind1 args1) x)) args2
+ where
+ m = min (length bind) (length args)
+
+ (bind1,bind2) = splitAt m bind
+ (args1,args2) = splitAt m args
+
+ -------------------------------------------------------------
+ -- LET RULES
+ f (CoreLet bind (CoreCase on alts))
+ | disjoint (collectFreeVars on) (map fst bind)
+ = coreCase_' on (mapM g alts)
+ where
+ g (lhs,rhs) = do
+ rhs2 <- coreLet__ bind rhs
+ rhs3 <- duplicateExpr rhs2
+ return (lhs,rhs3)
+
+ f (CoreLet bind x) | any (isCoreLet . snd) bind =
+ coreLet_' (concat bs) $ coreLet__ vs_xs x
+ where
+ (vs_xs,bs) = unzip [((v,x),b) | (v,rhs) <- bind, let (b,x) = fromCoreLet rhs]
+
+ f (CoreLet bind x) | not $ null once = coreLet_' many (fs $ replaceFreeVars once x)
+ where
+ bindVars = [i | CoreVar i <- concatMap (universe . snd) bind]
+ (once,many) = partition (uncurry isValid) bind
+
+ isValid lhs rhs = lhs `notElem` bindVars && (isSimple rhs || countFreeVar lhs x <= 1)
+ isSimple x = isCoreFun x || isCoreVar x || (isCoreLit x && isCoreLitSmall (fromCoreLit x))
+
+ f x = ext f x
+
+
+
diff --git a/Yhc/Core/Strictness.hs b/Yhc/Core/Strictness.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/Strictness.hs
@@ -0,0 +1,75 @@
+
+module Yhc.Core.Strictness(coreStrictness) where
+
+import Yhc.Core.Type
+import Yhc.Core.Prim
+
+import qualified Data.Map as Map
+import Data.List(intersect, nub, partition)
+
+{-
+ALGORITHM:
+
+SCC PARTIAL SORT:
+First sort the functions so that they occur in the childmost order:
+x1 < x2, if x1 doesn't transitive-call x2, and x2 does transitive-call x1
+Being wrong is fine, but being better gives better results
+
+PRIM STRICTNESS:
+The strictness of the various primitive operations
+
+BASE STRICTNESS:
+If all paths case on a particular value, then these are strict in that one
+If call onwards, then strict based on the caller
+-}
+
+
+-- | Given a function, return a list of arguments.
+-- True is strict in that argument, False is not.
+-- [] is unknown strictness
+coreStrictness :: Core -> (CoreFuncName -> [Bool])
+coreStrictness core = \funcname -> Map.findWithDefault [] funcname mp
+ where mp = mapStrictness $ sccSort $ coreFuncs core
+
+
+
+
+mapStrictness :: [CoreFunc] -> Map.Map CoreFuncName [Bool]
+mapStrictness funcs = foldl f Map.empty funcs
+ where
+ f mp (CorePrim{coreFuncName=name}) = case corePrimMaybe name of
+ Nothing -> mp
+ Just p -> Map.insert name (primStrict p) mp
+
+ f mp (CoreFunc name args body) = Map.insert name (map (`elem` strict) args) mp
+ where
+ strict = strictVars body
+
+ -- which variables are strict
+ strictVars :: CoreExpr -> [String]
+ strictVars (CorePos _ x) = strictVars x
+ strictVars (CoreVar x) = [x]
+
+ strictVars (CoreCase (CoreVar x) alts) = nub $ x : intersectList (map (strictVars . snd) alts)
+ strictVars (CoreCase x alts) = strictVars x
+
+ strictVars (CoreApp (CoreFun x) xs)
+ | length xs == length res
+ = nub $ concatMap strictVars $ map snd $ filter fst $ zip res xs
+ where res = Map.findWithDefault [] x mp
+
+ strictVars (CoreApp x xs) = strictVars x
+
+ strictVars _ = []
+
+
+intersectList :: Eq a => [[a]] -> [a]
+intersectList [] = []
+intersectList xs = foldr1 intersect xs
+
+
+
+-- do a sort in approximate SCC order
+sccSort :: [CoreFunc] -> [CoreFunc]
+sccSort xs = prims ++ funcs
+ where (prims,funcs) = partition isCorePrim xs
diff --git a/Yhc/Core/Type.hs b/Yhc/Core/Type.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/Type.hs
@@ -0,0 +1,313 @@
+{-# OPTIONS_DERIVE --module=Yhc.Core.Binary --derive=BinaryOld --output=Binary.hs #-}
+{-# OPTIONS_DERIVE --import --import=Yhc.Core.Internal.Binary --import=Control.Monad #-}
+
+module Yhc.Core.Type where
+
+-- while it may seem tempting to add type signatures to Core
+-- it won't work - by this stage all the type signatures are
+-- wrong because of desugarring
+
+import Control.Monad(liftM)
+import Data.Maybe(fromMaybe, listToMaybe, mapMaybe)
+import Data.Char(isSpace)
+import Data.List(intersperse)
+import qualified Data.Map as Map
+
+
+{-! global: GhcBinary !-}
+
+type CoreVarName = String
+type CoreFuncName = String
+type CoreDataName = String
+type CoreCtorName = String
+type CoreFieldName = String
+
+-- module name, imports, items in the module
+data Core = Core {coreName :: String, coreImports :: [String],
+ coreDatas :: [CoreData], coreFuncs :: [CoreFunc]}
+ deriving (Eq,Ord)
+
+data CoreData = CoreData {coreDataName :: CoreDataName, coreDataTypes :: [String], coreDataCtors :: [CoreCtor]}
+ deriving (Eq,Ord)
+
+-- Name, then list of maybe field names
+data CoreCtor = CoreCtor {coreCtorName :: CoreCtorName, coreCtorFields :: [(String, Maybe CoreFieldName)]}
+ deriving (Eq,Ord)
+
+data CoreFunc = CoreFunc {coreFuncName :: CoreFuncName, coreFuncArgs :: [CoreVarName], coreFuncBody :: CoreExpr}
+ | CorePrim {
+ coreFuncName :: CoreFuncName,
+ corePrimArity :: Int,
+ corePrimExternal :: String,
+ corePrimConv :: String,
+ corePrimImport :: Bool,
+ corePrimTypes :: [String]
+ }
+ deriving (Eq,Ord)
+
+isCoreFunc, isCorePrim :: CoreFunc -> Bool
+isCoreFunc (CoreFunc{}) = True; isCoreFunc _ = False
+isCorePrim (CorePrim{}) = True; isCorePrim _ = False
+
+
+coreFuncArity :: CoreFunc -> Int
+coreFuncArity (CorePrim{corePrimArity=x}) = x
+coreFuncArity x = length $ coreFuncArgs x
+
+-- An universal replacement for coreFuncArgs that now does not match in all cases
+
+coreFuncArgList :: CoreFunc -> [CoreVarName]
+coreFuncArgList (CorePrim{coreFuncName=n,corePrimArity=x}) = take x $ map (("__" ++ n ++ "_") ++) (map show [1..])
+coreFuncArgList x = coreFuncArgs x
+
+type CoreFuncMap = Map.Map CoreFuncName CoreFunc
+
+
+
+data CoreExpr = CoreCon CoreCtorName
+ | CoreVar CoreVarName
+ | CoreFun CoreFuncName
+ | CoreApp CoreExpr [CoreExpr]
+ | CoreLam [CoreVarName] CoreExpr
+ | CoreCase CoreExpr [(CorePat,CoreExpr)]
+ | CoreLet [(CoreVarName,CoreExpr)] CoreExpr
+ | CorePos String CoreExpr
+ | CoreLit CoreLit
+ deriving (Ord,Eq)
+
+
+data CoreLit = CoreInt Int
+ | CoreInteger Integer
+ | CoreChr Char
+ | CoreStr String
+ | CoreFloat Float
+ | CoreDouble Double
+ deriving (Ord,Eq,Show)
+
+
+data CorePat = PatCon {patCon :: CoreCtorName, patVars :: [CoreVarName]}
+ | PatLit {patLit :: CoreLit}
+ | PatDefault
+ deriving (Ord,Eq,Show)
+
+
+-- smart constructors
+coreApp :: CoreExpr -> [CoreExpr] -> CoreExpr
+coreApp x [] = x
+coreApp x xs = CoreApp x xs
+
+coreLet :: [(CoreVarName,CoreExpr)] -> CoreExpr -> CoreExpr
+coreLet [] x = x
+coreLet xs x = CoreLet xs x
+
+coreLam :: [CoreVarName] -> CoreExpr -> CoreExpr
+coreLam [] x = x
+coreLam xs x = CoreLam xs x
+
+
+fromCoreLit :: CoreExpr -> CoreLit
+fromCoreLit (CoreLit x) = x
+fromCoreLit x = error $ "Yhc.Core.fromCoreLit on a non-literal"
+
+fromCoreCon, fromCoreVar, fromCoreFun :: CoreExpr -> String
+fromCoreCon (CoreCon x) = x
+fromCoreVar (CoreVar x) = x
+fromCoreFun (CoreFun x) = x
+
+fromCoreApp :: CoreExpr -> (CoreExpr,[CoreExpr])
+fromCoreApp (CoreApp x y) = (x,y)
+fromCoreApp x = (x,[])
+
+fromCoreLet :: CoreExpr -> ([(CoreVarName,CoreExpr)],CoreExpr)
+fromCoreLet (CoreLet x y) = (x,y)
+fromCoreLet x = ([],x)
+
+fromCoreLam :: CoreExpr -> ([CoreVarName],CoreExpr)
+fromCoreLam (CoreLam x y) = (x,y)
+fromCoreLam x = ([],x)
+
+isCoreCon, isCoreVar, isCoreFun, isCoreLam :: CoreExpr -> Bool
+isCorePos, isCoreLet, isCoreCase, isCoreLit :: CoreExpr -> Bool
+isCoreCon x = case x of {CoreCon{} -> True; _ -> False}
+isCoreVar x = case x of {CoreVar{} -> True; _ -> False}
+isCoreFun x = case x of {CoreFun{} -> True; _ -> False}
+isCoreLam x = case x of {CoreLam{} -> True; _ -> False}
+isCorePos x = case x of {CorePos{} -> True; _ -> False}
+isCoreLet x = case x of {CoreLet{} -> True; _ -> False}
+isCoreCase x = case x of {CoreCase{} -> True; _ -> False}
+isCoreLit x = case x of {CoreLit{} -> True; _ -> False}
+
+isCoreStr, isCoreChr, isCoreInt :: CoreLit -> Bool
+isCoreStr x = case x of {CoreStr{} -> True; _ -> False}
+isCoreChr x = case x of {CoreChr{} -> True; _ -> False}
+isCoreInt x = case x of {CoreInt{} -> True; _ -> False}
+
+isPatDefault, isPatLit, isPatCon :: CorePat -> Bool
+isPatDefault x = case x of {PatDefault{} -> True; _ -> False}
+isPatLit x = case x of {PatLit{} -> True; _ -> False}
+isPatCon x = case x of {PatCon{} -> True; _ -> False}
+
+
+{-# DEPRECATED fromPatLit "use patLit instead" #-}
+fromPatLit = patLit
+
+patVariables (PatCon _ xs) = xs
+patVariables _ = []
+
+patToExpr :: CorePat -> CoreExpr
+patToExpr (PatCon c xs) = coreApp (CoreCon c) (map CoreVar xs)
+patToExpr (PatLit x) = CoreLit x
+patToExpr PatDefault = CoreVar "_"
+
+exprToPat :: CoreExpr -> CorePat
+exprToPat (CoreApp (CoreCon c) vs) = PatCon c (map fromCoreVar vs)
+exprToPat (CoreCon c) = PatCon c []
+exprToPat (CoreLit x) = PatLit x
+exprToPat (CoreVar _) = PatDefault
+
+
+-- | Returns true for constants that take a small, bounded
+-- amount of space
+isCoreLitSmall :: CoreLit -> Bool
+isCoreLitSmall x = isCoreInt x || isCoreChr x
+
+
+remCorePos :: CoreExpr -> CoreExpr
+remCorePos (CorePos _ x) = x
+remCorePos x = x
+
+
+-- | drop a module from a Core declaration
+dropModule :: String -> String
+dropModule x = f x False x
+ where
+ f x False (';':_) = x
+ f _ True (';':x) = f x False x
+ f x _ (_:xs) = f x True xs
+ f x _ [] = x
+
+
+-- | Get a function from a Core type
+-- crashes if the function does not exist
+coreFunc :: Core -> CoreFuncName -> CoreFunc
+coreFunc core name = fromMaybe (error msg) (coreFuncMaybe core name)
+ where msg = "Yhc.Core.Type.coreFunc, function not found: " ++ name
+
+
+-- | A non-crashing version of 'coreFunc'
+-- returns Nothing if the function does not exist.
+-- If multiple functions with the same name exist, this crashes.
+coreFuncMaybe :: Core -> CoreFuncName -> Maybe CoreFunc
+coreFuncMaybe core name =
+ case [x | x <- coreFuncs core, coreFuncName x == name] of
+ [] -> Nothing
+ [x] -> Just x
+ xs -> error $ "Yhc.Core.Type.mbCoreFunc, found found " ++ show (length xs) ++ " times: " ++ name
+
+
+
+-- | Get a 'CoreData' from a field (the snd element of 'coreCtorFields')
+coreFieldDataMaybe :: Core -> CoreFieldName -> Maybe CoreData
+coreFieldDataMaybe core name = coreFieldCtorMaybe core name >>= coreCtorDataMaybe core . coreCtorName
+
+-- | Get a 'CoreData' from a ctor name
+coreCtorDataMaybe :: Core -> CoreCtorName -> Maybe CoreData
+coreCtorDataMaybe core name = listToMaybe [dat | dat <- coreDatas core, name `elem` map coreCtorName (coreDataCtors dat)]
+
+-- | Get a 'CoreCtor' from a field name
+coreFieldCtorMaybe :: Core -> CoreFieldName -> Maybe CoreCtor
+coreFieldCtorMaybe core name = listToMaybe [ctr | dat <- coreDatas core, ctr <- coreDataCtors dat
+ , name `elem` mapMaybe snd (coreCtorFields ctr)]
+
+
+coreFieldData :: Core -> CoreFieldName -> CoreData
+coreFieldData core name = fromMaybe (error msg) $ coreFieldDataMaybe core name
+ where msg = "Yhc.Core.coreFieldData, looking for " ++ name
+
+coreCtorData :: Core -> CoreCtorName -> CoreData
+coreCtorData core = fromMaybe (error "Yhc.Core.coreCtorData") . coreCtorDataMaybe core
+
+coreFieldCtor :: Core -> CoreFieldName -> CoreCtor
+coreFieldCtor core = fromMaybe (error "Yhc.Core.coreFieldCtor") . coreFieldCtorMaybe core
+
+coreCtor :: Core -> CoreCtorName -> CoreCtor
+coreCtor core name = head [ctr | dat <- coreDatas core, ctr <- coreDataCtors dat, coreCtorName ctr == name]
+
+coreData :: Core -> CoreDataName -> CoreData
+coreData core name = head [dat | dat <- coreDatas core, coreDataName dat == name]
+
+
+-- | Take a function that operates on bodies, and apply it to a program
+applyBodyCore :: (CoreExpr -> CoreExpr) -> (Core -> Core)
+applyBodyCore f = applyFuncCore (applyBodyFunc f)
+
+
+-- | Take a function that operates on bodies, and apply it to a function
+applyBodyFunc :: (CoreExpr -> CoreExpr) -> (CoreFunc -> CoreFunc)
+applyBodyFunc f func | isCoreFunc func = func{coreFuncBody = f (coreFuncBody func)}
+ | otherwise = func
+
+
+-- | Take a function that operates on functions, and apply it to a program
+applyFuncCore :: (CoreFunc -> CoreFunc) -> (Core -> Core)
+applyFuncCore f core = core{coreFuncs = map f (coreFuncs core)}
+
+
+applyCtorCore :: (CoreCtor -> CoreCtor) -> (Core -> Core)
+applyCtorCore f = applyDataCore (applyCtorData f)
+
+applyDataCore :: (CoreData -> CoreData) -> (Core -> Core)
+applyDataCore f core = core{coreDatas = map f (coreDatas core)}
+
+applyCtorData :: (CoreCtor -> CoreCtor) -> (CoreData -> CoreData)
+applyCtorData f dat = dat{coreDataCtors = map f (coreDataCtors dat)}
+
+
+applyBodyCoreM :: Monad m => (CoreExpr -> m CoreExpr) -> Core -> m Core
+applyBodyCoreM f = applyFuncCoreM g
+ where
+ g (CoreFunc a b c) = liftM (CoreFunc a b) $ f c
+ g x = return x
+
+
+applyFuncCoreM :: Monad m => (CoreFunc -> m CoreFunc) -> Core -> m Core
+applyFuncCoreM f c = do
+ res <- mapM f (coreFuncs c)
+ return $ c{coreFuncs = res}
+
+
+
+-- | Split up a coreDataType into lexical elements
+-- None of the result elements will be space, or blank
+-- Some may be "(", ")" or "!"
+coreDataTypeSplit :: String -> [String]
+coreDataTypeSplit [] = []
+coreDataTypeSplit (x:xs)
+ | x `elem` special = [x] : coreDataTypeSplit xs
+ | isSpace x = coreDataTypeSplit xs
+ | otherwise = let (a,b) = break (\x -> isSpace x || x `elem` special) (x:xs)
+ in a : coreDataTypeSplit b
+ where
+ special = "!()"
+
+
+-- | can pretty print much nicer, just something that works for now
+coreDataTypeJoin :: [String] -> String
+coreDataTypeJoin = concat . intersperse " "
+
+
+
+fromCoreFuncMap :: Core -> CoreFuncMap -> Core
+fromCoreFuncMap core fm = core{coreFuncs = Map.elems fm}
+
+toCoreFuncMap :: Core -> CoreFuncMap
+toCoreFuncMap core = Map.fromList [(coreFuncName x, x) | x <- coreFuncs core]
+
+coreFuncMap :: CoreFuncMap -> CoreFuncName -> CoreFunc
+coreFuncMap fm name = fromMaybe (error $ "Yhc.Core.coreFuncMap, function not found, " ++ name) $
+ Map.lookup name fm
+
+coreFuncMapMaybe :: CoreFuncMap -> CoreFuncName -> Maybe CoreFunc
+coreFuncMapMaybe fm name = Map.lookup name fm
+
+
diff --git a/Yhc/Core/Uniplate.hs b/Yhc/Core/Uniplate.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/Uniplate.hs
@@ -0,0 +1,59 @@
+
+module Yhc.Core.Uniplate(
+ module Yhc.Core.Uniplate,
+ module Data.Generics.UniplateOn
+ ) where
+
+import Yhc.Core.Type
+import Data.Generics.UniplateOn
+
+
+universeExprVar :: UniplateExpr a => a -> [String]
+universeExprVar x = [i | CoreVar i <- universeExpr x]
+
+
+class UniplateExpr a where
+ uniplateExpr :: BiplateType a CoreExpr
+
+
+instance UniplateExpr a => UniplateExpr [a] where
+ uniplateExpr = uniplateOnList uniplateExpr
+
+instance UniplateExpr Core where
+ uniplateExpr (Core a b c d) = (col, \ns -> Core a b c (gen ns))
+ where (col,gen) = uniplateExpr d
+
+instance UniplateExpr CoreFunc where
+ uniplateExpr (CoreFunc name args body) = ([body], \[body] -> CoreFunc name args body)
+ uniplateExpr x = ([], \[] -> x)
+
+instance UniplateExpr CoreExpr where
+ uniplateExpr x = ([x], \[x] -> x)
+
+
+instance Uniplate CoreExpr where
+ uniplate x =
+ case x of
+ CoreApp x xs -> (x:xs, \(n:ns) -> CoreApp n ns)
+ CoreLam x xs -> ([xs], \[xs] -> CoreLam x xs)
+ CorePos x xs -> ([xs], \[xs] -> CorePos x xs)
+
+ CoreLet x xs -> (map snd x ++ [xs],
+ \ys -> CoreLet (zip (map fst x) (init ys)) (last ys))
+
+ CoreCase x xs -> (x : map snd xs
+ ,\(y:ys) -> CoreCase y (zip (map fst xs) ys))
+
+ _ -> ([], \[] -> x)
+
+
+
+childrenExpr x = childrenOn uniplateExpr x
+universeExpr x = universeOn uniplateExpr x
+transformExpr x = transformOn uniplateExpr x
+transformExprM x = transformOnM uniplateExpr x
+rewriteExpr x = rewriteOn uniplateExpr x
+rewriteExprM x = rewriteOnM uniplateExpr x
+descendExpr x = descendOn uniplateExpr x
+descendExprM x = descendOnM uniplateExpr x
+contextsExpr x = contextsOn uniplateExpr x
diff --git a/Yhc/Core/UniqueId.hs b/Yhc/Core/UniqueId.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/UniqueId.hs
@@ -0,0 +1,37 @@
+{- |
+ This module implements unique ID's in Yhc.Core.
+
+ The intention is that a program can use this interface to a unique ID quite cheaply.
+ Or an existing state monad can be reused.
+-}
+
+module Yhc.Core.UniqueId where
+
+import Control.Monad.State
+
+
+-- store the value to use next
+class UniqueId a where
+ getId :: a -> Int
+ putId :: Int -> a -> a
+
+
+instance UniqueId Int where
+ getId = id
+ putId = const
+
+
+class Monad m => UniqueIdM m where
+ getIdM :: m Int
+ putIdM :: Int -> m ()
+
+
+instance UniqueId a => UniqueIdM (State a) where
+ getIdM = liftM getId get
+ putIdM n = modify (putId n)
+
+
+nextId :: UniqueIdM m => m Int
+nextId = do i <- getIdM
+ putIdM (i+1)
+ return i
diff --git a/Yhc/Core/UniqueName.hs b/Yhc/Core/UniqueName.hs
new file mode 100644
--- /dev/null
+++ b/Yhc/Core/UniqueName.hs
@@ -0,0 +1,100 @@
+{- |
+ This module implements unique names in Yhc.Core.
+
+ Given a name, it can be dividied into [rest][digits].
+ The digits form a number (0 for no digits).
+
+ Given a set of names, they must all represent unique numbers.
+-}
+
+module Yhc.Core.UniqueName(
+ uniqueNamesNext, uniqueSplit, uniqueJoin,
+ uniqueFuncsNext, uniqueFuncsSplit, uniqueFuncsRename
+ ) where
+
+import Yhc.Core.Type
+import Yhc.Core.Uniplate
+
+import Data.Char
+import Control.Monad.State
+import qualified Data.Map as Map
+
+
+-- * General Uniqueness Functions
+
+
+uniqueNamesNext :: [String] -> Int
+uniqueNamesNext xs = maximum (0 : map (snd . uniqueSplit) xs) + 1
+
+
+-- | Split a name into a prefix and a unique id.
+-- 0 means no trailing number.
+uniqueSplit :: String -> (String,Int)
+uniqueSplit x = (reverse b, if null a then 0 else read $ reverse a)
+ where (a,b) = span isDigit $ reverse x
+
+
+-- | Given a name, and a unique id, join them together.
+-- Replaces any existing id.
+uniqueJoin :: String -> Int -> String
+uniqueJoin s n = a ++ if n == 0 then "" else show n
+ where (a,b) = uniqueSplit s
+
+
+-- * Those Specialised for Core
+
+uniqueFuncsNext :: Core -> Int
+uniqueFuncsNext = uniqueNamesNext . map coreFuncName . coreFuncs
+
+
+type FuncsSplitM a = State FuncsSplit a
+data FuncsSplit = FuncsSplit Int [CoreFunc]
+
+-- | A more advanced combinator to capture the pattern of splitting
+-- one function into many (i.e. recursive let's, lambda lifting)
+--
+-- Needs rank-2 types to do properly
+uniqueFuncsSplit :: (
+ (FuncsSplitM CoreFuncName) ->
+ (CoreFunc -> FuncsSplitM ()) ->
+ CoreExpr -> FuncsSplitM CoreExpr
+ ) -> Core -> Core
+uniqueFuncsSplit op core =
+ flip evalState (uniqueFuncsNext core) $ do
+ funcs <- mapM f (coreFuncs core)
+ return $ core{coreFuncs = concat funcs}
+ where
+ newFunc name = do
+ FuncsSplit j done <- get
+ let name2 = uniqueJoin name j
+ put $ FuncsSplit (j+1) done
+ return name2
+
+ addFunc func = do
+ FuncsSplit j done <- get
+ put $ FuncsSplit j (func:done)
+
+ f x | isCorePrim x = return [x]
+ f (CoreFunc name args body) = do
+ i <- get
+ let (body2,FuncsSplit i2 funcs2) = runState (op (newFunc name) addFunc body) (FuncsSplit i [])
+ put i2
+ return $ CoreFunc name args body2 : reverse funcs2
+
+
+-- | Rename functions so they use consecutive numbers starting at 2,
+-- to aid human understanding
+uniqueFuncsRename :: Core -> Core
+uniqueFuncsRename core
+ | Map.null ren = core
+ | otherwise = applyFuncCore g $ transformExpr f core
+ where
+ names = [x | CoreFunc x _ _ <- coreFuncs core, snd (uniqueSplit x) /= 0]
+ ren = Map.fromList $ zip names $ zipWith uniqueJoin names [1..]
+
+ f (CoreFun x) = CoreFun $ Map.findWithDefault x x ren
+ f x = x
+
+ g o@CoreFunc{coreFuncName=x} = o{coreFuncName = Map.findWithDefault x x ren}
+ g x = x
+
diff --git a/yhccore.cabal b/yhccore.cabal
new file mode 100644
--- /dev/null
+++ b/yhccore.cabal
@@ -0,0 +1,59 @@
+Cabal-Version: >= 1.2
+Name: yhccore
+Version: 0.9
+Copyright: 2006-8, Neil Mitchell and The Yhc Team
+Maintainer: ndmitchell@gmail.com
+Homepage: http://www.haskell.org/haskellwiki/Yhc
+License: BSD3
+License-File: LICENSE
+Build-Type: Simple
+Author: Neil Mitchell
+Synopsis: Yhc's Internal Core language.
+Description:
+ A minimal Core language to which Haskell can be reduced,
+ implemented in the Yhc compiler.
+Category: Development
+
+Flag splitBase
+ Description: Choose the new smaller, split-up base package.
+
+Library
+ if flag(splitBase)
+ build-depends: base >= 3, mtl, pretty, containers
+ else
+ build-depends: base < 3, mtl
+ build-depends: mtl, uniplate
+
+ Exposed-modules:
+ Yhc.Core
+ Yhc.Core.Binary
+ Yhc.Core.CaseElimination
+ Yhc.Core.Clean
+ Yhc.Core.Equal
+ Yhc.Core.FreeVar
+ Yhc.Core.FreeVar2
+ Yhc.Core.FreeVar3
+ Yhc.Core.Haskell
+ Yhc.Core.Html
+ Yhc.Core.Inline
+ Yhc.Core.Invariant
+ Yhc.Core.Overlay
+ Yhc.Core.Play
+ Yhc.Core.Prim
+ Yhc.Core.Reachable
+ Yhc.Core.RecursiveLet
+ Yhc.Core.Saturated
+ Yhc.Core.Serialise
+ Yhc.Core.Show
+ Yhc.Core.ShowRaw
+ Yhc.Core.Simplify
+ Yhc.Core.Strictness
+ Yhc.Core.Type
+ Yhc.Core.Uniplate
+ Yhc.Core.UniqueId
+ Yhc.Core.UniqueName
+ Yhc.Core.Internal.Binary
+ Yhc.Core.Internal.General
+ Yhc.Core.Internal.HughesPJ
+ Yhc.Core.Internal.Play
+ Yhc.Core.Invariant.LambdaLift