├── Setup.hs ├── .gitignore ├── cps-core.cabal ├── GHC ├── Primitives.hs ├── Var.hs ├── Coercion.hs ├── Data.hs ├── Type.hs ├── Kind.hs └── Syntax.hs ├── LICENSE ├── Name.hs ├── UniqueSupply.hs ├── Main.hs ├── CPS ├── FromGHC.hs └── Syntax.hs └── Utilities.hs /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Temporary directories 2 | disabled/ 3 | 4 | # OS crap 5 | .DS_Store 6 | Thumbs.db 7 | 8 | # Build artifacts 9 | *.hi 10 | *.o 11 | dist/ -------------------------------------------------------------------------------- /cps-core.cabal: -------------------------------------------------------------------------------- 1 | Cabal-Version: >= 1.2 2 | Build-Type: Simple 3 | Name: cps-core 4 | Version: 0.1 5 | Maintainer: Max Bolingbroke 6 | Homepage: http://www.github.com/batterseapower/cps-core 7 | License: BSD3 8 | License-File: LICENSE 9 | Author: Max Bolingbroke 10 | Synopsis: A core language that is both simpler and more expressive than GHC Core 11 | Category: Language 12 | 13 | Executable cpscore 14 | Main-Is: Main.hs 15 | 16 | Build-Depends: base >= 4 && < 5, containers >= 0.3 && < 0.5, 17 | pretty >= 1.0.1.1 && < 1.1, prettyclass >= 1 && < 1.2, 18 | haskell-src-exts >= 1.9.0 && < 1.12.0, cpphs >= 1.11 && < 1.14 19 | 20 | Ghc-Options: -rtsopts -Wall -fno-warn-name-shadowing 21 | 22 | -------------------------------------------------------------------------------- /GHC/Primitives.hs: -------------------------------------------------------------------------------- 1 | module GHC.Primitives where 2 | 3 | import Utilities 4 | 5 | 6 | data PrimOp = Add | Subtract | Multiply | Divide | Modulo | Equal | LessThan | LessThanEqual 7 | deriving (Eq, Ord, Show) 8 | 9 | data Literal = Int Integer 10 | deriving (Eq, Show) 11 | 12 | instance Pretty PrimOp where 13 | pPrint Add = text "(+)" 14 | pPrint Subtract = text "(-)" 15 | pPrint Multiply = text "(*)" 16 | pPrint Divide = text "div" 17 | pPrint Modulo = text "mod" 18 | pPrint Equal = text "(==)" 19 | pPrint LessThan = text "(<)" 20 | pPrint LessThanEqual = text "(<=)" 21 | 22 | instance Pretty Literal where 23 | pPrintPrec level prec (Int i) | level == haskellLevel = prettyParen (prec >= appPrec) $ pPrintPrec level appPrec i <+> text ":: Int" 24 | | otherwise = pPrintPrec level prec i 25 | -------------------------------------------------------------------------------- /GHC/Var.hs: -------------------------------------------------------------------------------- 1 | module GHC.Var where 2 | 3 | import GHC.Kind 4 | import GHC.Type 5 | 6 | import Name 7 | import Utilities 8 | 9 | 10 | data Id = Id { 11 | idName :: Name, 12 | idType :: Type 13 | } deriving (Show) 14 | 15 | instance Eq Id where 16 | (==) = (==) `on` idName 17 | 18 | instance Ord Id where 19 | compare = compare `on` idName 20 | 21 | instance Pretty Id where 22 | pPrintPrec level prec = pPrintPrec level prec . idName 23 | 24 | 25 | type CoVarId = Id 26 | 27 | data Var = AnId !Id | ATyVar !TyVar 28 | deriving (Eq, Ord, Show) 29 | 30 | instance Pretty Var where 31 | pPrintPrec level prec (AnId x) = pPrintPrec level prec x 32 | pPrintPrec level prec (ATyVar a) = pPrintPrec level prec a 33 | 34 | 35 | mkPiTy :: Var -> Type -> Type 36 | mkPiTy (AnId x) = (idType x `mkFunTy`) 37 | mkPiTy (ATyVar a) = (a `ForAllTy`) 38 | 39 | mkPiTys :: [Var] -> Type -> Type 40 | mkPiTys xs ty = foldr mkPiTy ty xs 41 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Max Bolingbroke 2009-2010. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Max Bolingbroke nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /GHC/Coercion.hs: -------------------------------------------------------------------------------- 1 | module GHC.Coercion where 2 | 3 | import GHC.Kind 4 | import GHC.Var 5 | import GHC.Type 6 | 7 | import Utilities 8 | 9 | 10 | data Coercion = CoVarCo CoVarId 11 | | ReflCo Type 12 | | AppCo Coercion Coercion 13 | | SymCo Coercion 14 | | TransCo Coercion Coercion 15 | | NthCo Int Coercion 16 | | ForAllCo TyVar Coercion 17 | | InstCo Coercion Type 18 | | UnsafeCo Type Type -- Also used for instantiated axioms 19 | deriving (Eq, Show) 20 | 21 | instance Pretty Coercion where 22 | pPrint _ = text "co" -- FIXME 23 | 24 | 25 | mkCoercionType :: Type -> Type -> Type 26 | mkCoercionType ty1 ty2 = mkTyConAppTy (eqHashTyCon (typeKind ty1)) [ty1, ty2] 27 | 28 | splitCoercionType :: Type -> (Type, Type) 29 | splitCoercionType ty = case splitTyConAppTy_maybe ty of 30 | Just (tc, [ty1, ty2]) | tc == eqHashTyCon (typeKind ty1) -> (ty1, ty2) 31 | _ -> error "splitCoercionType" 32 | 33 | 34 | coVarIdType' :: CoVarId -> (Type, Type) 35 | coVarIdType' = splitCoercionType . idType 36 | 37 | coercionType :: Coercion -> Type 38 | coercionType = uncurry mkCoercionType . coercionType' 39 | 40 | coercionType' :: Coercion -> (Type, Type) 41 | coercionType' (CoVarCo x) = coVarIdType' x 42 | coercionType' (ReflCo ty) = (ty, ty) 43 | coercionType' (AppCo co1 co2) = (ty1a `AppTy` ty2a, ty1b `AppTy` ty2b) 44 | where (ty1a, ty1b) = coercionType' co1 45 | (ty2a, ty2b) = coercionType' co2 46 | coercionType' (SymCo co) = (ty2, ty1) 47 | where (ty1, ty2) = coercionType' co 48 | coercionType' (TransCo co1 co2) = (ty1a, ty2b) 49 | where (ty1a, _ty1b) = coercionType' co1 50 | (_ty2a, ty2b) = coercionType' co2 51 | coercionType' (NthCo n co) = (f ty1, f ty2) 52 | where (ty1, ty2) = coercionType' co 53 | f ty = case splitTyConAppTy_maybe ty of 54 | Just (_, tys) | n < length tys -> tys !! n 55 | _ -> error "coercionType': NthCo" 56 | coercionType' (ForAllCo a co) = (ForAllTy a ty1, ForAllTy a ty2) 57 | where (ty1, ty2) = coercionType' co 58 | coercionType' (InstCo co ty) = (instTy ty1 ty, instTy ty2 ty) 59 | where (ty1, ty2) = coercionType' co 60 | coercionType' (UnsafeCo ty1 ty2) = (ty1, ty2) 61 | -------------------------------------------------------------------------------- /Name.hs: -------------------------------------------------------------------------------- 1 | module Name ( 2 | Name(..), 3 | freshName, freshNames, 4 | shadowyNames, 5 | 6 | InScopeSet, 7 | emptyInScopeSet, mkInScopeSet, 8 | uniqAway, uniqAwayName 9 | ) where 10 | 11 | import Utilities 12 | 13 | import Data.Char 14 | import Data.Ord 15 | import qualified Data.Set as S 16 | 17 | import System.IO.Unsafe (unsafePerformIO) 18 | 19 | 20 | {-# NOINLINE shadowyNameUniques #-} 21 | shadowyNameUniques :: UniqueSupply 22 | shadowyNameUniques = unsafePerformIO (initUniqueSupply 'v') 23 | 24 | shadowyNames :: [String] -> [Name] 25 | shadowyNames = snd . freshNames shadowyNameUniques 26 | 27 | 28 | data Name = Name { 29 | nameString :: String, 30 | nameUnique :: !Unique 31 | } 32 | 33 | instance Show Name where 34 | show n = "(name " ++ show (show (pPrint n)) ++ ")" 35 | 36 | instance Eq Name where 37 | (==) = (==) `on` nameUnique 38 | 39 | instance Ord Name where 40 | compare = compare `on` nameUnique 41 | 42 | instance Uniqueable Name where 43 | getUnique = nameUnique 44 | 45 | instance Pretty Name where 46 | pPrintPrec level _ n = text (escape $ nameString n) <> text "_" <> text (show (nameUnique n)) 47 | where escape | level == haskellLevel = concatMap escapeHaskellChar 48 | | otherwise = id 49 | escapeHaskellChar c 50 | | c == 'z' = "zz" 51 | | isAlphaNum c || c `elem` ['_', '\''] = [c] 52 | | otherwise = 'z' : show (ord c) 53 | 54 | freshName :: UniqueSupply -> String -> (UniqueSupply, Name) 55 | freshName us s = second (Name s) $ stepUniqueSupply us 56 | 57 | freshNames :: UniqueSupply -> [String] -> (UniqueSupply, [Name]) 58 | freshNames = mapAccumL freshName 59 | 60 | 61 | newtype InScopeSet = ISS (S.Set Unique) 62 | 63 | emptyInScopeSet :: InScopeSet 64 | emptyInScopeSet = ISS S.empty 65 | 66 | mkInScopeSet :: (Ord a, Uniqueable a) => S.Set a -> InScopeSet 67 | mkInScopeSet = ISS . S.map getUnique 68 | 69 | uniqAway :: InScopeSet -> Unique -> (InScopeSet, Unique) 70 | uniqAway (ISS iss) = go 71 | where go u | u `S.member` iss = go (bumpUnique u) 72 | | otherwise = (ISS (S.insert u iss), u) 73 | 74 | uniqAwayName :: InScopeSet -> Name -> (InScopeSet, Name) 75 | uniqAwayName iss n = (iss', n { nameUnique = u' }) 76 | where (iss', u') = uniqAway iss (nameUnique n) 77 | -------------------------------------------------------------------------------- /GHC/Data.hs: -------------------------------------------------------------------------------- 1 | module GHC.Data where 2 | 3 | import GHC.Kind 4 | import GHC.Type 5 | 6 | import Utilities 7 | 8 | 9 | type Arity = Int 10 | data DataCon = DataCon { 11 | dataConName :: String, 12 | dataConUnivTyVars :: [TyVar], -- Binders both universal.. 13 | dataConExTyVars :: [TyVar], -- ..and existential.. 14 | dataConFields :: [Type], -- ..scoping over these (including coercions for GADTs).. 15 | dataConTyCon :: TyCon, -- ..and this TyCon.. 16 | dataConTyConArgs :: [Type], -- ..applied to these. 17 | dataConSiblings :: [DataCon] -- Other DataCons belonging to this TyCon, excluding this one 18 | } deriving (Show) 19 | 20 | instance Eq DataCon where 21 | (==) = (==) `on` dataConName 22 | 23 | instance Ord DataCon where 24 | compare = compare `on` dataConName 25 | 26 | instance Pretty DataCon where 27 | pPrint = text . dataConName 28 | 29 | dataConType :: DataCon -> Type 30 | dataConType dc = mkForAllTys (dataConUnivTyVars dc) (mkForAllTys (dataConExTyVars dc) (mkFunTys (dataConFields dc) (mkTyConAppTy (dataConTyCon dc) (dataConTyConArgs dc)))) 31 | 32 | -- All DataCons in the family, sorted into a consistent order suitable for e.g. deciding on a tagging 33 | dataConFamily :: DataCon -> [DataCon] 34 | dataConFamily dc = sortBy (compare `on` dataConName) (dc : dataConSiblings dc) 35 | 36 | 37 | pairDataCon :: DataCon 38 | pairDataCon = DataCon { 39 | dataConName = "(,)", 40 | dataConUnivTyVars = [a_tv, b_tv], 41 | dataConExTyVars = [], 42 | dataConFields = [a_ty, b_ty], 43 | dataConTyCon = pairTyCon, 44 | dataConTyConArgs = [a_ty, b_ty], 45 | dataConSiblings = [] 46 | } where ([a_tv, b_tv], [a_ty, b_ty]) = shadowyTyVarsTypes [("a", LiftedTypeKind), ("b", LiftedTypeKind)] 47 | 48 | unboxedTupleDataCon :: Int -> DataCon 49 | unboxedTupleDataCon n = DataCon { 50 | dataConName = "(#" ++ replicate (n - 1) ',' ++ "#)", 51 | dataConUnivTyVars = tvs, 52 | dataConExTyVars = [], 53 | dataConFields = tys, 54 | dataConTyCon = unboxedTupleTyCon n, 55 | dataConTyConArgs = tys, 56 | dataConSiblings = [] 57 | } where (tvs, tys) = shadowyTyVarsTypes [("a" ++ show n, OpenTypeKind) | n <- [1..n]] 58 | 59 | iHashDataCon :: DataCon 60 | iHashDataCon = DataCon { 61 | dataConName = "I#", 62 | dataConUnivTyVars = [], 63 | dataConExTyVars = [], 64 | dataConFields = [intHashTy], 65 | dataConTyCon = intTyCon, 66 | dataConTyConArgs = [], 67 | dataConSiblings = [] 68 | } 69 | 70 | trueDataCon, falseDataCon :: DataCon 71 | trueDataCon = DataCon { 72 | dataConName = "True", 73 | dataConUnivTyVars = [], 74 | dataConExTyVars = [], 75 | dataConFields = [], 76 | dataConTyCon = boolTyCon, 77 | dataConTyConArgs = [], 78 | dataConSiblings = [falseDataCon] 79 | } 80 | falseDataCon = DataCon { 81 | dataConName = "False", 82 | dataConUnivTyVars = [], 83 | dataConExTyVars = [], 84 | dataConFields = [], 85 | dataConTyCon = boolTyCon, 86 | dataConTyConArgs = [], 87 | dataConSiblings = [trueDataCon] 88 | } 89 | -------------------------------------------------------------------------------- /UniqueSupply.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | 3 | -- | This module provides splittable supplies for unique identifiers. 4 | -- The main idea gows back to L. Augustsson, M. Rittri, and D. Synek 5 | -- and is described in their paper 'On generating unique names' 6 | -- (Journal of Functional Programming 4(1), 1994. pp. 117-123). The 7 | -- implementation at hand is taken from the GHC sources and includes 8 | -- bit fiddling to allow multiple supplies that generate unique 9 | -- identifiers by prepending a character given at initialization. 10 | -- 11 | -- This is a custom version of uniqueid-0.1.1 to resolve some bugs I 12 | -- found in it. 13 | module UniqueSupply ( 14 | Unique, hashedUnique, bumpUnique, UniqueSupply, initUniqueSupply, splitUniqueSupplyL, splitUniqueSupply, uniqueFromSupply 15 | ) where 16 | 17 | import GHC.Exts 18 | -- MCB: change to uniqueid-0.1.1: use GHC.IO rather than GHC.IOBase 19 | import GHC.IO ( unsafeDupableInterleaveIO ) 20 | 21 | import Data.IORef 22 | import System.IO.Unsafe ( unsafePerformIO ) 23 | 24 | 25 | -- | Unique identifiers are of type 'Unique' and can be hashed to an 'Int' 26 | -- usning the function 'hashedUnique'. 27 | newtype Unique = Unique { hashedUnique :: Int } 28 | 29 | bumpUnique :: Unique -> Unique 30 | bumpUnique u = Unique { hashedUnique = hashedUnique u + 1 } 31 | 32 | -- | Supplies for unique identifiers are of type 'UniqueSupply' and can be 33 | -- split into two new supplies or yield a unique identifier. 34 | data UniqueSupply = UniqueSupply Int# UniqueSupply UniqueSupply 35 | 36 | -- | Generates a new supply of unique identifiers. The given character 37 | -- is prepended to generated numbers. 38 | initUniqueSupply :: Char -> IO UniqueSupply 39 | initUniqueSupply (C# c) = 40 | case uncheckedIShiftL# (ord# c) (unboxedInt 24) of 41 | mask -> 42 | let mkSupply = 43 | unsafeDupableInterleaveIO ( 44 | nextInt >>= \ (I# u) -> 45 | mkSupply >>= \ l -> 46 | mkSupply >>= \ r -> 47 | return (UniqueSupply (word2Int# (or# (int2Word# mask) (int2Word# u))) l r)) 48 | in mkSupply 49 | 50 | -- | Splits a supply of unique identifiers to yield two of them. 51 | splitUniqueSupply :: UniqueSupply -> (UniqueSupply,UniqueSupply) 52 | splitUniqueSupply (UniqueSupply _ l r) = (l,r) 53 | 54 | -- | Splits a supply of unique identifiers to yield an infinite list of them. 55 | splitUniqueSupplyL :: UniqueSupply -> [UniqueSupply] 56 | splitUniqueSupplyL ids = ids1 : splitUniqueSupplyL ids2 57 | where 58 | (ids1, ids2) = splitUniqueSupply ids 59 | 60 | -- | Yields the unique identifier from a supply. 61 | uniqueFromSupply :: UniqueSupply -> Unique 62 | uniqueFromSupply (UniqueSupply n _ _) = Unique (I# n) 63 | 64 | instance Eq Unique where Unique (I# x) == Unique (I# y) = x ==# y 65 | 66 | instance Ord Unique 67 | where 68 | Unique (I# x) < Unique (I# y) = x <# y 69 | Unique (I# x) <= Unique (I# y) = x <=# y 70 | 71 | compare (Unique (I# x)) (Unique (I# y)) = 72 | if x ==# y then EQ else if x <# y then LT else GT 73 | 74 | instance Show Unique 75 | where 76 | showsPrec _ i s = case unpackUnique i of (c,n) -> c:show n++s 77 | 78 | 79 | 80 | 81 | unboxedInt :: Int -> Int# 82 | unboxedInt (I# x) = x 83 | 84 | -- MCB: change to uniqueid-0.1.1: ensure that the global IORef is not inlined! 85 | {-# NOINLINE global #-} 86 | global :: IORef Int 87 | global = unsafePerformIO (newIORef 0) 88 | 89 | -- MCB: change to uniqueid-0.1.1: prevent race conditions 90 | nextInt :: IO Int 91 | nextInt = atomicModifyIORef global (\n -> (succ n, succ n)) 92 | 93 | unpackUnique :: Unique -> (Char,Int) 94 | unpackUnique (Unique (I# i)) = 95 | let tag = C# (chr# (uncheckedIShiftRL# i (unboxedInt 24))) 96 | num = I# (word2Int# (and# (int2Word# i) 97 | (int2Word# (unboxedInt 16777215)))) 98 | in (tag, num) -------------------------------------------------------------------------------- /GHC/Type.hs: -------------------------------------------------------------------------------- 1 | module GHC.Type where 2 | 3 | import GHC.Kind 4 | 5 | import Name 6 | import Utilities 7 | 8 | import qualified Data.Set as S 9 | 10 | 11 | data Type = TyVarTy TyVar 12 | | TyConTy TyCon 13 | | AppTy Type Type 14 | | ForAllTy TyVar Type 15 | deriving (Eq, Show) 16 | 17 | instance Pretty Type where 18 | pPrintPrec level prec ty = case ty of 19 | TyVarTy a -> pPrintPrec level prec a 20 | TyConTy tc -> pPrintPrec level prec tc 21 | AppTy ty1 ty2 -> pPrintPrecApp level prec ty1 ty2 22 | ForAllTy a ty -> text "forall" <+> pPrintPrec level noPrec a <> text "." <+> pPrintPrec level noPrec ty 23 | 24 | mkAppTys :: Type -> [Type] -> Type 25 | mkAppTys = foldl AppTy 26 | 27 | mkTyConAppTy :: TyCon -> [Type] -> Type 28 | mkTyConAppTy = mkAppTys . TyConTy 29 | 30 | splitTyConAppTy_maybe :: Type -> Maybe (TyCon, [Type]) 31 | splitTyConAppTy_maybe = go [] 32 | where go args (AppTy ty1 ty2) = go (ty2:args) ty1 33 | go args (TyConTy tc) = Just (tc, args) 34 | go _ _ = Nothing 35 | 36 | infixr 7 `mkFunTy` 37 | 38 | mkFunTy :: Type -> Type -> Type 39 | mkFunTy ty1 ty2 = mkTyConAppTy funTyCon [ty1, ty2] 40 | 41 | mkFunTys :: [Type] -> Type -> Type 42 | mkFunTys tys ty = foldr mkFunTy ty tys 43 | 44 | mkForAllTys :: [TyVar] -> Type -> Type 45 | mkForAllTys tvs ty = foldr ForAllTy ty tvs 46 | 47 | splitFunTy_maybe :: Type -> Maybe (Type, Type) 48 | splitFunTy_maybe ty = case splitTyConAppTy_maybe ty of 49 | Just (tc, [ty1, ty2]) | tc == funTyCon -> Just (ty1, ty2) 50 | _ -> Nothing 51 | 52 | funResTy :: Type -> Type 53 | funResTy ty = case splitFunTy_maybe ty of 54 | Just (_, ty2) -> ty2 55 | _ -> error $ "funResTy: " ++ show ty 56 | 57 | instTy :: Type -> Type -> Type 58 | instTy (ForAllTy a ty_body) ty_a = renameType (mkInScopeSet (typeFreeVars ty_a)) (mkTypeSubst a ty_a) ty_body 59 | instTy _ _ = error "mkInstTy" 60 | 61 | 62 | newtype TypeSubst = TypeSubst { unTypeSubst :: UniqueMap Type } 63 | 64 | mkTypeSubst :: TyVar -> Type -> TypeSubst 65 | mkTypeSubst a ty = TypeSubst (insertUniqueMap a ty emptyUniqueMap) 66 | 67 | renameTyVar :: TypeSubst -> TyVar -> Type 68 | renameTyVar subst a = findUniqueWithDefault (error "renameTyVar: out of scope") a (unTypeSubst subst) 69 | 70 | renameTypeBinder :: InScopeSet -> TypeSubst -> TyVar -> (InScopeSet, TypeSubst, TyVar) 71 | renameTypeBinder iss subst a = (iss', TypeSubst (insertUniqueMap a (TyVarTy a') (unTypeSubst subst)), a') 72 | where n = tyVarName a 73 | (iss', n') = uniqAwayName iss n 74 | a' = a { tyVarName = n' } -- NB: don't need to rename types 75 | 76 | 77 | typeFreeVars :: Type -> S.Set TyVar 78 | typeFreeVars ty = case ty of 79 | TyVarTy a -> S.singleton a 80 | TyConTy _ -> S.empty 81 | AppTy ty1 ty2 -> typeFreeVars ty1 `S.union` typeFreeVars ty2 82 | ForAllTy a ty -> S.delete a (typeFreeVars ty) 83 | 84 | 85 | renameType :: InScopeSet -> TypeSubst -> Type -> Type 86 | renameType iss subst ty = case ty of 87 | TyVarTy a -> renameTyVar subst a 88 | TyConTy tc -> TyConTy tc 89 | AppTy ty1 ty2 -> AppTy (renameType iss subst ty1) (renameType iss subst ty2) 90 | ForAllTy a ty -> ForAllTy a' (renameType iss' subst' ty) 91 | where (iss', subst', a') = renameTypeBinder iss subst a 92 | 93 | 94 | intTy :: Type 95 | intTy = TyConTy intTyCon 96 | 97 | intHashTy :: Type 98 | intHashTy = TyConTy intHashTyCon 99 | 100 | boolTy :: Type 101 | boolTy = TyConTy boolTyCon 102 | 103 | 104 | shadowyTyVarsTypes :: [(String, Kind)] -> ([TyVar], [Type]) 105 | shadowyTyVarsTypes xkinds = (tvs, map TyVarTy tvs) 106 | where tvs = shadowyTyVars xkinds 107 | 108 | 109 | typeKind :: Type -> Kind 110 | typeKind (TyVarTy a) = tyVarKind a 111 | typeKind (TyConTy tc) = tyConKind tc 112 | typeKind (AppTy ty1 _) = arrowResKind (typeKind ty1) 113 | typeKind (ForAllTy _ ty) = typeKind ty 114 | -------------------------------------------------------------------------------- /GHC/Kind.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards #-} 2 | module GHC.Kind where 3 | 4 | import Name 5 | import Utilities 6 | 7 | 8 | infixr 7 `ArrowKind` 9 | 10 | data Kind = ArgTypeKind | OpenTypeKind | LiftedTypeKind | UnliftedTypeKind | UnboxedTupleTypeKind 11 | | ArrowKind Kind Kind 12 | deriving (Eq, Show) 13 | 14 | mkArrowKinds :: [Kind] -> Kind -> Kind 15 | mkArrowKinds ks k = foldr ArrowKind k ks 16 | 17 | splitArrowKinds :: Kind -> ([Kind], Kind) 18 | splitArrowKinds (ArrowKind k1 k2) = first (k1:) $ splitArrowKinds k2 19 | splitArrowKinds k = ([], k) 20 | 21 | arrowResKind :: Kind -> Kind 22 | arrowResKind (ArrowKind _ k2) = k2 23 | arrowResKind k = error $ "arrowResKind: " ++ show k 24 | 25 | isSubKind :: Kind -> Kind -> Bool 26 | -- Otherwise-incomparable arrow elements: 27 | isSubKind (ArrowKind k1a k2a) (ArrowKind k1b k2b) = k1b `isSubKind` k1a && k2a `isSubKind` k2b 28 | isSubKind (ArrowKind _ _) _ = False 29 | isSubKind _ (ArrowKind _ _) = False 30 | -- The top element: 31 | isSubKind _ OpenTypeKind = True 32 | isSubKind OpenTypeKind _ = False 33 | -- Various bottom elements: 34 | isSubKind LiftedTypeKind LiftedTypeKind = True 35 | isSubKind _ LiftedTypeKind = False 36 | isSubKind UnliftedTypeKind UnliftedTypeKind = True 37 | isSubKind _ UnliftedTypeKind = False 38 | isSubKind UnboxedTupleTypeKind UnboxedTupleTypeKind = True 39 | isSubKind _ UnboxedTupleTypeKind = False 40 | -- The intermediate element: 41 | isSubKind _ ArgTypeKind = True 42 | 43 | 44 | data TyCon = TyCon { 45 | tyConName :: String, 46 | tyConKind :: Kind 47 | } deriving (Show) 48 | 49 | instance Eq TyCon where 50 | (==) = (==) `on` tyConName 51 | 52 | instance Ord TyCon where 53 | compare = compare `on` tyConName 54 | 55 | instance Pretty TyCon where 56 | pPrint = text . tyConName 57 | 58 | funTyCon :: TyCon 59 | funTyCon = TyCon { 60 | tyConName = "(->)", 61 | tyConKind = ArgTypeKind `ArrowKind` OpenTypeKind `ArrowKind` LiftedTypeKind 62 | } 63 | 64 | pairTyCon :: TyCon 65 | pairTyCon = TyCon { 66 | tyConName = "(,)", 67 | tyConKind = LiftedTypeKind `ArrowKind` LiftedTypeKind `ArrowKind` LiftedTypeKind 68 | } 69 | 70 | unboxedTupleTyCon :: Int -> TyCon 71 | unboxedTupleTyCon n = TyCon { 72 | tyConName = "(#" ++ replicate (n - 1) ',' ++ "#)", 73 | tyConKind = replicate n ArgTypeKind `mkArrowKinds` UnboxedTupleTypeKind 74 | } 75 | 76 | isUnboxedTupleTyCon_maybe :: TyCon -> Maybe Int 77 | isUnboxedTupleTyCon_maybe tc 78 | | k == UnboxedTupleTypeKind = Just (length ks) 79 | | otherwise = Nothing 80 | where (ks, k) = splitArrowKinds (tyConKind tc) 81 | 82 | intHashTyCon :: TyCon 83 | intHashTyCon = TyCon { 84 | tyConName = "Int#", 85 | tyConKind = UnliftedTypeKind 86 | } 87 | 88 | eqHashTyCon :: Kind -> TyCon 89 | eqHashTyCon k = TyCon { 90 | tyConName = "~#", 91 | tyConKind = k `ArrowKind` k `ArrowKind` UnliftedTypeKind 92 | } 93 | 94 | isEqHashTyCon :: TyCon -> Maybe Kind 95 | isEqHashTyCon tc 96 | | tyConName tc == "~#" 97 | , k `ArrowKind` _ `ArrowKind` UnliftedTypeKind <- tyConKind tc 98 | = Just k 99 | | otherwise 100 | = Nothing 101 | 102 | intTyCon :: TyCon 103 | intTyCon = TyCon { 104 | tyConName = "Int", 105 | tyConKind = LiftedTypeKind 106 | } 107 | 108 | boolTyCon :: TyCon 109 | boolTyCon = TyCon { 110 | tyConName = "Bool", 111 | tyConKind = LiftedTypeKind 112 | } 113 | 114 | 115 | data TyVar = TyVar { 116 | tyVarName :: Name, 117 | tyVarKind :: Kind 118 | } deriving (Show) 119 | 120 | instance Eq TyVar where 121 | (==) = (==) `on` tyVarName 122 | 123 | instance Ord TyVar where 124 | compare = compare `on` tyVarName 125 | 126 | instance Uniqueable TyVar where 127 | getUnique = getUnique . tyVarName 128 | 129 | instance Pretty TyVar where 130 | pPrintPrec level prec = pPrintPrec level prec . tyVarName 131 | 132 | 133 | shadowyTyVars :: [(String, Kind)] -> [TyVar] 134 | shadowyTyVars xkinds = zipWith TyVar ns kinds 135 | where (xs, kinds) = unzip xkinds 136 | ns = shadowyNames xs 137 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import CPS.Syntax 4 | import CPS.FromGHC 5 | 6 | import GHC.Data as G 7 | import GHC.Var as G 8 | import GHC.Kind as G 9 | import GHC.Type as G 10 | import GHC.Syntax as G 11 | import GHC.Primitives 12 | 13 | import Name 14 | import Utilities 15 | 16 | import qualified Data.Set as S 17 | import qualified Data.Map as M 18 | 19 | 20 | functionExample :: G.Term 21 | functionExample = G.Case (G.Value (G.Literal (Int 2))) intHashTy two [(G.DefaultAlt, 22 | G.LetRec [(lifted_id, G.Value (G.Lambda (G.ATyVar a) (G.Value (G.Lambda (G.AnId x) (G.Var x))))), 23 | (prim_id', G.Value (G.Lambda (G.AnId y) (G.Var y))), 24 | (prim_id, G.Var lifted_id `G.TyApp` G.idType prim_id' `G.App` prim_id')] $ 25 | G.PrimOp Add [G.PrimOp Add [G.Value (G.Literal (Int 1)), G.Var prim_id `G.App` two], G.Var prim_id `G.App` two])] -- Use prim_id twice to test thunk update works 26 | where 27 | [a_n, id_n, prim_id_n, prim_id_n', x_n, y_n, two_n] = shadowyNames ["a", "id", "prim_id", "prim_id'", "x", "y", "two"] 28 | a = G.TyVar { G.tyVarName = a_n, G.tyVarKind = G.LiftedTypeKind } 29 | lifted_id = G.Id { G.idName = id_n, G.idType = G.ForAllTy a (G.TyVarTy a `G.mkFunTy` G.TyVarTy a) } 30 | prim_id = G.Id { G.idName = prim_id_n, G.idType = intHashTy `G.mkFunTy` intHashTy } 31 | prim_id' = G.Id { G.idName = prim_id_n', G.idType = intHashTy `G.mkFunTy` intHashTy } 32 | x = G.Id { G.idName = x_n, G.idType = G.TyVarTy a } 33 | y = G.Id { G.idName = y_n, G.idType = intHashTy } 34 | two = G.Id { G.idName = two_n, G.idType = intHashTy } 35 | 36 | 37 | dataExample :: G.Term 38 | dataExample = G.Case (G.Value (G.Literal (Int 1))) intHashTy one [(G.DefaultAlt, 39 | G.Case (G.Value (G.Data G.trueDataCon [] [] [])) intHashTy true [ 40 | (G.DefaultAlt, G.Value (G.Literal (Int 1))), 41 | (G.DataAlt G.trueDataCon [] [], G.LetRec [(unboxy_fun, G.Value (G.Lambda (G.AnId one) (G.Value (G.Data (G.unboxedTupleDataCon 2) [G.intHashTy, G.boolTy] [] [one, true]))))] $ 42 | G.Case (G.Var unboxy_fun `G.App` one) G.intHashTy unbx [ 43 | (G.DataAlt (G.unboxedTupleDataCon 2) [] [x, y], G.Var x)])])] 44 | where 45 | [true_n, one_n, unbx_n, unboxy_fun_n, x_n, y_n] = shadowyNames ["true", "one", "unbx", "unboxy_fun", "x", "y"] 46 | true = G.Id { G.idName = true_n, G.idType = G.boolTy } 47 | one = G.Id { G.idName = one_n, G.idType = G.intHashTy } 48 | unbx = G.Id { G.idName = unbx_n, G.idType = G.mkTyConAppTy (G.unboxedTupleTyCon 2) [G.intHashTy, G.boolTy] } 49 | unboxy_fun = G.Id { G.idName = unboxy_fun_n, G.idType = G.mkFunTy G.intHashTy (G.idType unbx) } 50 | x = G.Id { G.idName = x_n, G.idType = G.intHashTy } 51 | y = G.Id { G.idName = y_n, G.idType = G.boolTy } 52 | 53 | caseBoundFunctionExample :: G.Term 54 | caseBoundFunctionExample = G.Case (G.Value (G.Lambda (G.ATyVar a) (G.Value (G.Lambda (G.AnId x) (G.Var x))))) intTy lifted_id [(G.DefaultAlt, 55 | G.Case (G.Value (G.Literal (Int 1))) intTy one [(G.DefaultAlt, 56 | G.LetRec [(boxed_one, G.Value (G.Data G.iHashDataCon [] [] [one]))] $ 57 | G.Var lifted_id `G.TyApp` intTy `G.App` boxed_one)])] 58 | where 59 | [a_n, one_n, boxed_one_n, lifted_id_n, x_n] = shadowyNames ["a", "one", "boxed_one", "lifted_id", "x"] 60 | a = G.TyVar { G.tyVarName = a_n, G.tyVarKind = G.LiftedTypeKind } 61 | one = G.Id { G.idName = one_n, G.idType = G.intHashTy } 62 | boxed_one = G.Id { G.idName = boxed_one_n, G.idType = G.intTy } 63 | lifted_id = G.Id { G.idName = lifted_id_n, G.idType = G.ForAllTy a (G.TyVarTy a `G.mkFunTy` G.TyVarTy a) } 64 | x = G.Id { G.idName = x_n, G.idType = G.TyVarTy a } 65 | 66 | 67 | the_example :: G.Term 68 | --the_example = functionExample 69 | --the_example = dataExample 70 | the_example = caseBoundFunctionExample 71 | 72 | 73 | main :: IO () 74 | main = do 75 | ids <- initUniqueSupply 'x' 76 | let (ids', halt_n) = freshName ids "halt" 77 | halt = CoId { coIdName = halt_n, coIdType = [IntHashTy] } 78 | steps e = e : unfoldr (\s -> let e = stateToTerm s 79 | in case runLintM (lintTerm emptyUniqueMap (insertUniqueMap halt_n [IntHashTy] emptyUniqueMap) e) of 80 | [] -> fmap ((,) e) (step s) 81 | errs -> error (unlines (map pPrintRender errs))) s 82 | where s = (mkInScopeSet (S.singleton halt_n), M.empty, (substFromCoIdSubst (mkCoIdSubst (S.singleton halt)), e), []) 83 | putStrLn $ pPrintRender the_example 84 | mapM_ (putStrLn . pPrintRender) $ steps $ fromTerm (ids', emptyInScopeSet) (emptyUniqueMap, the_example) (Unknown halt) 85 | -------------------------------------------------------------------------------- /GHC/Syntax.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards, ViewPatterns, TypeSynonymInstances, FlexibleInstances, Rank2Types #-} 2 | module GHC.Syntax where 3 | 4 | import GHC.Coercion 5 | import GHC.Data 6 | import GHC.Type 7 | import GHC.Primitives 8 | import GHC.Var 9 | import GHC.Kind 10 | 11 | import Name 12 | import Utilities 13 | 14 | 15 | data AltCon = DataAlt DataCon [TyVar] [Id] | LiteralAlt Literal | DefaultAlt 16 | deriving (Eq, Show) 17 | 18 | -- Note [Case wildcards] 19 | -- ~~~~~~~~~~~~~~~~~~~~~ 20 | -- 21 | -- Simon thought that I should use the variable in the DefaultAlt to agressively rewrite occurences of a scrutinised variable. 22 | -- The motivation is that this lets us do more inlining above the case. For example, take this code fragment from foldl': 23 | -- 24 | -- let n' = c n y 25 | -- in case n' of wild -> foldl' c n' ys 26 | -- 27 | -- If we rewrite, n' becomes linear: 28 | -- 29 | -- let n' = c n y 30 | -- in case n' of wild -> foldl c wild ys 31 | -- 32 | -- This lets us potentially inline n' directly into the scrutinee position (operationally, this prevent creation of a thunk for n'). 33 | -- However, I don't think that this particular form of improving linearity helps the supercompiler. We only want to inline n' in 34 | -- somewhere if it meets some interesting context, with which it can cancel. But if we are creating an update frame for n' at all, 35 | -- it is *probably* because we had no information about what it evaluated to. 36 | -- 37 | -- An interesting exception is when n' binds a case expression: 38 | -- 39 | -- let n' = case unk of T -> F; F -> T 40 | -- in case (case n' of T -> F; F -> T) of 41 | -- wild -> e[n'] 42 | -- 43 | -- You might think that we want n' to be linear so we can inline it into the case on it. However, the splitter will save us and produce: 44 | -- 45 | -- case unk of 46 | -- T -> let n' = F 47 | -- in case (case n' of T -> F; F -> T) of wild -> e[n'] 48 | -- F -> let n' = T 49 | -- in case (case n' of T -> F; F -> T) of wild -> e[n'] 50 | -- 51 | -- Since we now know the form of n', everything works out nicely. 52 | -- 53 | -- Conclusion: I don't think rewriting to use the case wildcard buys us anything at all. 54 | 55 | data Term = Var Id 56 | | Value Value 57 | | App Term Id 58 | | TyApp Term Type 59 | | PrimOp PrimOp [Term] 60 | | Case Term Type Id [Alt] 61 | | LetRec [(Id, Term)] Term 62 | | Cast Term Coercion 63 | deriving (Eq, Show) 64 | 65 | type Alt = (AltCon, Term) 66 | 67 | data Value = Coercion Coercion | Lambda Var Term | Data DataCon [Type] [Type] [Id] | Literal Literal 68 | deriving (Eq, Show) 69 | 70 | instance Pretty Term where 71 | pPrintPrec level prec e = case e of 72 | LetRec xes e -> pPrintPrecLetRec level prec xes e 73 | Var x -> pPrintPrec level prec x 74 | Value v -> pPrintPrec level prec v 75 | App e1 x2 -> pPrintPrecApp level prec e1 x2 76 | TyApp e1 ty2 -> pPrintPrecApp level prec e1 ty2 77 | PrimOp pop xs -> pPrintPrecApps level prec pop xs 78 | Case e _ x alts -> pPrintPrecCase level prec e x alts 79 | Cast e co -> pPrintPrecCast level prec e co 80 | 81 | pPrintPrecCase :: (Pretty a, Pretty b, Pretty c, Pretty d) => PrettyLevel -> Rational -> a -> d -> [(b, c)] -> Doc 82 | pPrintPrecCase level prec e x alts = prettyParen (prec > noPrec) $ hang (text "case" <+> pPrintPrec level appPrec e <> text "@" <> pPrintPrec level noPrec x <+> text "of") 2 $ vcat (map (pPrintPrecAlt level noPrec) alts) 83 | 84 | pPrintPrecAlt :: (Pretty a, Pretty b) => PrettyLevel -> Rational -> (a, b) -> Doc 85 | pPrintPrecAlt level _ (alt_con, alt_e) = hang (pPrintPrec level noPrec alt_con <+> text "->") 2 (pPrintPrec level noPrec alt_e) 86 | 87 | pPrintPrecCast :: (Pretty a, Pretty b) => PrettyLevel -> Rational -> a -> b -> Doc 88 | pPrintPrecCast level prec e co = prettyParen (prec >= appPrec) $ pPrintPrec level opPrec e <+> text "|>" <+> pPrintPrec level appPrec co 89 | 90 | instance Pretty AltCon where 91 | pPrintPrec level prec altcon = case altcon of 92 | DataAlt dc xtys xs -> prettyParen (prec >= appPrec) $ pPrintPrec level noPrec dc <+> hsep (map (pPrintPrec level appPrec) xtys ++ map (pPrintPrec level appPrec) xs) 93 | LiteralAlt l -> pPrint l 94 | DefaultAlt -> text "_" 95 | 96 | instance Pretty Value where 97 | pPrintPrec level prec v = case v of 98 | -- Unfortunately, this nicer pretty-printing doesn't work for general (TermF ann): 99 | --Lambda x e -> pPrintPrecLam level prec (x:xs) e' 100 | -- where (xs, e') = collectLambdas e 101 | Lambda x e -> pPrintPrecLams level prec [x] e 102 | Data dc utys xtys xs -> pPrintPrecApps level prec dc (map asPrettyFunction utys ++ map asPrettyFunction xtys ++ map asPrettyFunction xs) 103 | Literal l -> pPrintPrec level prec l 104 | Coercion co -> pPrintPrec level prec co 105 | 106 | pPrintPrecLams :: Pretty a => PrettyLevel -> Rational -> [Var] -> a -> Doc 107 | pPrintPrecLams level prec xs e = prettyParen (prec > noPrec) $ text "\\" <> hsep [pPrintPrec level appPrec y | y <- xs] <+> text "->" <+> pPrintPrec level noPrec e 108 | 109 | 110 | termType :: Term -> Type 111 | termType (Var x) = idType x 112 | termType (Value v) = valueType v 113 | termType (App e _) = funResTy (termType e) 114 | termType (TyApp e ty) = instTy (termType e) ty 115 | termType (PrimOp pop es) = case (pop, map termType es) of 116 | (pop, [ty1, ty2]) 117 | | pop `elem` [Add, Subtract, Multiply, Divide, Modulo] 118 | , ty1 == intHashTy 119 | , ty2 == intHashTy 120 | -> intHashTy 121 | | pop `elem` [Equal, LessThan, LessThanEqual] 122 | , ty1 == intHashTy 123 | , ty2 == intHashTy 124 | -> boolTy 125 | _ -> error "termType: PrimOp" 126 | termType (Case _ ty _ _) = ty 127 | termType (LetRec _ e) = termType e 128 | termType (Cast _ co) = snd $ coercionType' co 129 | 130 | valueType :: Value -> Type 131 | valueType (Coercion co) = coercionType co 132 | valueType (Lambda x e) = mkPiTy x (termType e) 133 | valueType (Data dc utys xtys xs) = nTimes (length xs) funResTy $ foldl' instTy (dataConType dc) (utys ++ xtys) 134 | valueType (Literal l) = literalType l 135 | 136 | literalType :: Literal -> Type 137 | literalType (Int _) = intHashTy 138 | 139 | 140 | freshFloatId :: UniqueSupply -> String -> Term -> (UniqueSupply, Maybe (Id, Term), Id) 141 | freshFloatId ids _ (Var x) = (ids, Nothing, x) 142 | freshFloatId ids s e = (ids', Just (y, e), y) 143 | where (ids', n) = freshName ids s 144 | y = Id n (termType e) 145 | 146 | freshFloatIds :: UniqueSupply -> String -> [Term] -> (UniqueSupply, [(Id, Term)], [Id]) 147 | freshFloatIds ids s es = reassociate $ mapAccumL (\ids -> associate . freshFloatId ids s) ids es 148 | where reassociate (ids, unzip -> (mb_floats, xs)) = (ids, catMaybes mb_floats, xs) 149 | associate (ids, mb_float, x) = (ids, (mb_float, x)) 150 | -------------------------------------------------------------------------------- /CPS/FromGHC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards #-} 2 | module CPS.FromGHC where 3 | 4 | import CPS.Syntax hiding (Subst, renameIdBinder) 5 | 6 | import qualified GHC.Data as G 7 | import qualified GHC.Var as G 8 | import qualified GHC.Syntax as G 9 | import qualified GHC.Type as G 10 | import qualified GHC.Kind as G 11 | import GHC.Primitives 12 | 13 | import Name 14 | import Utilities 15 | 16 | -- FIXME: it might be easier to just permit unboxed tuples everywhere, including inside other unboxed tuples and on the left-hand-side of function arrows. 17 | -- The only wrinkle is that fromId may have to manufacture some fresh names. 18 | -- FIXME: we can even permit unboxed tuples as e.g. arguments to (,)! Of course, you can't use such types as arguments to polymorphic functions (ill-kinded type application). 19 | -- In GHC we would also have to be careful about what info tables such things get -- we can't reuse the polymorphic one (closure layout will change). 20 | 21 | 22 | -- NB: the input type must be of a TypeKind kind 23 | -- NB: the type returned is the *unlifted* version of the type 24 | -- NB: may return multiple types for unboxed tuples 25 | -- NB: do not look through newtypes here or we may produce an infinite type 26 | fromType :: G.Type -> [Type] 27 | fromType (G.ForAllTy _ ty) = fromType ty 28 | fromType ty = case G.splitTyConAppTy_maybe ty of 29 | Just (tc, [_, _]) 30 | | tc == G.funTyCon -> [PtrTy] 31 | | Just _ <- G.isEqHashTyCon tc -> [] 32 | | tc == G.pairTyCon -> [PtrTy] 33 | Just (tc, []) 34 | | tc == G.boolTyCon -> [PtrTy] 35 | | tc == G.intTyCon -> [PtrTy] 36 | | tc == G.intHashTyCon -> [IntHashTy] 37 | Just (tc, tys) 38 | | Just n <- G.isUnboxedTupleTyCon_maybe tc 39 | , n == length tys 40 | -> concatMap fromTypeThunky tys -- NB: this does not actualy permit nested unboxed tuples, the list is needed if some components are void 41 | Just _ -> error "fromType: unrecognised explicit TyCon" 42 | Nothing -> case G.typeKind ty of 43 | G.LiftedTypeKind -> [PtrTy] 44 | _ -> error "fromType: non-TyCon non-lifted type" 45 | -- GHC currently has a bug where you can lambda-abstract over type variables of non-lifted kind. 46 | -- This is a serious problem because there is no way to reliably determine the representation of 47 | -- that type variable. This becomes explicit in our translation. 48 | -- 49 | -- FIXME: we should allow such types in *result* positions (e.g. for error :: forall (a :: OPEN). a). 50 | -- In this case, we can return [] on the understanding that such functions can never return. 51 | 52 | -- NB: the input type must be lifted 53 | fromLiftedType :: G.Type -> Type 54 | fromLiftedType ty = case fromType ty of 55 | [ty] -> ty 56 | _ -> error "fromLiftedType: non-unary input type - must be an unboxed tuple or void unlifted type" 57 | 58 | -- NB: the input type must be lifted 59 | fromLiftedTypeThunky :: G.Type -> Type 60 | fromLiftedTypeThunky ty = case fromTypeThunky ty of 61 | [ty] -> ty 62 | _ -> error "fromLiftedTypeThunky: non-unary input type - must be an unboxed tuple or void unlifted type" 63 | 64 | fromTypeThunky :: G.Type -> [Type] 65 | fromTypeThunky ty 66 | | G.typeKind ty /= G.LiftedTypeKind = fromType ty 67 | | otherwise = [PtrTy] 68 | 69 | -- We don't have to worry about occurrences of unboxed tuple Ids, but void Ids may occur 70 | fromId :: G.Id -> [Id] 71 | fromId x = case fromTypeThunky (G.idType x) of 72 | [] -> [] 73 | [ty] -> [Id { idName = G.idName x, idType = ty }] 74 | _ -> error "fromId: unboxed tuple Ids are not present in the input" 75 | 76 | -- NB: the type of the input Id must be lifted 77 | fromLiftedId :: G.Id -> Id 78 | fromLiftedId x = case fromId x of [x] -> x 79 | _ -> error "fromLiftedId: void input Id" 80 | 81 | type Context = (UniqueSupply, InScopeSet) 82 | 83 | type Subst = UniqueMap (Maybe Trivial) 84 | type In a = (Subst, a) 85 | 86 | instance Uniqueable G.Id where 87 | getUnique = getUnique . G.idName 88 | 89 | rename :: Subst -> G.Id -> Maybe Trivial 90 | rename subst x = findUniqueWithDefault (error "rename: out of scope") x subst 91 | 92 | renameLifted :: Subst -> G.Id -> Trivial 93 | renameLifted subst x = case rename subst x of 94 | Just t -> t 95 | Nothing -> error "renameLifted: binding not lifted" 96 | 97 | renameIdBinder :: Context -> Subst -> G.Id -> (Context, Subst, Maybe Id) 98 | renameIdBinder ids subst x = (ids', insertUniqueMap x (fmap IdOcc mb_x') subst, mb_x') 99 | where 100 | (ids', mb_x') = renameIdBinder' ids x 101 | 102 | renameIdBinder' :: Context -> G.Id -> (Context, Maybe Id) 103 | renameIdBinder' (ids, iss) x = case fromTypeThunky (G.idType x) of 104 | [] -> ((ids, iss), Nothing) 105 | [ty] -> ((ids, iss'), Just x') 106 | where n = G.idName x 107 | (iss', n') = uniqAwayName iss n 108 | x' = Id { idName = n', idType = ty } -- NB: don't need to rename types 109 | _ -> error "renameIdBinder': unboxed tuple binders are always dead" 110 | 111 | --renameBinders :: Context -> Subst -> [G.Id] -> (Context, Subst, [Maybe Id]) 112 | --renameBinders ids subst = third3 catMaybes . mapAccumL (\(ids, subst) x -> case renameBinder ids subst x of (ids, subst, mb_x') -> ((ids, subst, mb_x'))) (ids, subst) 113 | 114 | 115 | freshId :: Context -> String -> Type -> (Context, Id) 116 | freshId (ids, iss) s ty = ((ids', iss'), Id { idName = n', idType = ty }) 117 | where (ids', n) = freshName ids s 118 | (iss', n') = uniqAwayName iss n 119 | 120 | freshCoId :: Context -> String -> CoType -> (Context, CoId) 121 | freshCoId (ids, iss) s nty = ((ids', iss'), CoId { coIdName = n', coIdType = nty }) 122 | where (ids', n) = freshName ids s 123 | (iss', n') = uniqAwayName iss n 124 | 125 | freshs :: (Context -> String -> a -> (Context, b)) 126 | -> Context -> String -> [a] -> (Context, [b]) 127 | freshs fresh ids s tys = mapAccumL (\ids ty -> fresh ids s ty) ids tys 128 | 129 | 130 | -- fromTerm ids (subst, e) u 131 | -- 132 | -- NB: 133 | -- fromType (termType e) `allR subType` coIdType u 134 | -- FVs are available in the environment of the output with their *thunky* types 135 | data Kont = Unknown CoId 136 | | Known [Type] (Context -> [Trivial] -> Term) 137 | 138 | returnToKont :: Kont -> Context -> [Trivial] -> Term 139 | returnToKont (Unknown u) _ ts = Term [] [] (Return u ts) 140 | returnToKont (Known _ f) ids ts = f ids ts 141 | 142 | bindKont :: Kont -> Context -> (Context -> CoId -> Term) -> Term 143 | bindKont (Unknown u) ids nested = nested ids u 144 | bindKont (Known tys f) ids0 nested = addContinuation u k (nested ids2 u) -- FIXME: should tys come from bindCont caller? (Casts) 145 | where k = Continuation xs (f ids2 (map IdOcc xs)) 146 | (ids1, u) = freshCoId ids0 "u" (continuationCoType k) 147 | (ids2, xs) = freshs freshId ids1 "x" tys 148 | 149 | fromTerm :: Context -> In G.Term -> Kont -> Term 150 | fromTerm ids (subst, G.Var x) u 151 | | G.typeKind (G.idType x) /= G.LiftedTypeKind = returnToKont u ids (maybeToList (rename subst x)) 152 | | otherwise = bindKont u ids $ \_ u -> Term [] [] (Call (renameLifted subst x) (Enter []) [u]) 153 | fromTerm ids0 (subst, G.Value v) u = case v of 154 | G.Coercion _ -> returnToKont u ids0 [] 155 | G.Lambda (G.ATyVar _) e -> fromTerm ids0 (subst, e) u 156 | G.Lambda (G.AnId x) e -> addFunction y f (returnToKont u ids1 [IdOcc y]) 157 | where (ids1, y) = freshId ids0 "fun" PtrTy 158 | (ids2, subst', mb_x') = renameIdBinder ids1 subst x 159 | (ids3, w) = freshCoId ids2 "w" (fromType (G.termType e)) 160 | f = Function (maybeToList mb_x') [w] (fromTerm ids3 (subst', e) (Unknown w)) 161 | G.Data dc _ _ xs 162 | | Just _ <- G.isUnboxedTupleTyCon_maybe (G.dataConTyCon dc) 163 | -> returnToKont u ids0 (mapMaybe (rename subst) xs) 164 | | otherwise 165 | -> addFunction y f (returnToKont u ids1 [IdOcc y]) 166 | where dcs = G.dataConFamily dc 167 | ListPoint tys_lefts _tys_here tys_rights = fmap (concatMap fromTypeThunky . G.dataConFields) $ locateListPoint (==dc) dcs 168 | f = Box tys_lefts (mapMaybe (rename subst) xs) tys_rights 169 | (ids1, y) = freshId ids0 "data" PtrTy 170 | G.Literal l -> returnToKont u ids0 [Literal l] 171 | fromTerm ids (subst, G.App e x) u = fromTerm ids (subst, e) $ Known (fromType (G.termType e)) $ \ids [t] -> bindKont u ids $ \_ u -> Term [] [] (Call t (Enter (maybeToList (rename subst x))) [u]) 172 | fromTerm ids (subst, G.TyApp e _) u = fromTerm ids (subst, e) u 173 | fromTerm ids (subst, G.PrimOp pop es) u = foldr (\e known ids ts -> fromTerm ids (subst, e) $ Known (fromType (G.termType e)) $ \ids extra_ts -> known ids (ts ++ extra_ts)) 174 | (\ids ts -> bindKont u ids $ \_ u -> Term [] [] (Call (PrimOp pop) (Enter ts) [u])) es ids [] 175 | fromTerm ids0 (subst, G.Case e _ x alts) u 176 | | [(G.DataAlt dc _ xs, e_alt)] <- alts 177 | , Just _ <- G.isUnboxedTupleTyCon_maybe (G.dataConTyCon dc) 178 | , let combine [] [] = [] 179 | combine (x:xs) ts = case fromTypeThunky (G.idType x) of 180 | [] -> (x, Nothing) : combine xs ts 181 | [_] | (t:ts) <- ts -> (x, Just t) : combine xs ts 182 | _ -> error "combine: binder, but no matching trivials" 183 | combine [] (_:_) = error "combine: not enough trivials" 184 | = fromTerm ids0 (subst, e) $ Known (fromType (G.idType x)) $ \ids0 ts -> fromTerm ids0 (foldr (uncurry insertUniqueMap) subst (combine xs ts), e_alt) u 185 | 186 | | otherwise 187 | = fromTerm ids0 (subst, e) $ Known (fromType (G.idType x)) $ \ids0 ts -> let subst' = insertUniqueMap x (if G.typeKind (G.idType x) /= G.LiftedTypeKind then listToMaybe ts else Just (case ts of [t] -> t)) subst in case alts of 188 | [(G.DefaultAlt, e)] -> fromTerm ids0 (subst', e) u 189 | ((G.DefaultAlt, e_def):(G.DataAlt dc _ xs, e):alts) | [t] <- ts -> fromAlts (selectData t) ids0 subst' (Just e_def) ((dc, (xs, e)):[(dc, (xs, e)) | (G.DataAlt dc _ xs, e) <- alts]) u 190 | ((G.DataAlt dc _ xs, e):alts) | [t] <- ts -> fromAlts (selectData t) ids0 subst' Nothing ((dc, (xs, e)):[(dc, (xs, e)) | (G.DataAlt dc _ xs, e) <- alts]) u 191 | ((G.DefaultAlt, e_def):(G.LiteralAlt l, e):alts) | [t] <- ts -> fromAlts (selectLiteral t) ids0 subst' (Just e_def) ((l, ([], e)):[(l, ([], e)) | (G.LiteralAlt l, e) <- alts]) u 192 | ((G.LiteralAlt l, e):alts) | [t] <- ts -> fromAlts (selectLiteral t) ids0 subst' Nothing ((l, ([], e)):[(l, ([], e)) | (G.LiteralAlt l, e) <- alts]) u 193 | fromTerm ids0 (subst0, G.LetRec xes e) u = e' 194 | where (ids3, subst2, e') = foldr (\(x, e) (ids1, subst0, e') -> let (ids2, subst1, Just x') = renameIdBinder ids1 subst0 x 195 | ty = fromLiftedType (G.termType e) 196 | (ids3, w) = freshCoId ids2 "w" [ty] 197 | in (ids2, subst1, addFunction x' (Function [] [w] (fromTerm ids3 (subst2, e) (Known [ty] $ \_ [t] -> Term [] [] (Call (Update [] (coIdType w) []) (Enter [IdOcc x', t]) [w])))) e')) 198 | (ids0, subst0, fromTerm ids3 (subst2, e) u) xes 199 | fromTerm ids (subst, G.Cast e _) u = fromTerm ids (subst, e) u 200 | -- FIXME: I'm a bit worried about the type-precision consequences of this -- dropping casts may kill typeability of the output! 201 | -- 202 | -- Consider: 203 | -- \(y :: Int) -> let x :: F Int = (\(x :: Int) -> x) |> (co :: (Int -> Int) ~ F Int) 204 | -- in x |> (sym co) y 205 | -- 206 | -- Which would naively translate to: 207 | -- let x :: * = \(x :: *) -> x 208 | -- in x y 209 | -- 210 | -- Which is ill typed. 211 | -- 212 | -- How about in CPS-core? (NB: I'm using * to stand for the evaluated form of the lifted type Int) 213 | -- let x :: <> -> * = \<> (k :: *) -> let xv :: (<> -> *) -> * = \x k -> x <> k 214 | -- in k xv 215 | -- l :: (<> -> *) -> * = \(xv :: (<> -> *) -> *) -> xv y halt 216 | -- in x l 217 | -- 218 | -- This is STILL ill typed -- look at the (x l) application, where l demands more than the x can supply. 219 | -- 220 | -- Even worse, since x is hidden by a lambda: 221 | -- \(y :: Int) -> let x :: F Int = (\(x :: Int) -> x) |> (co :: (Int -> Int) ~ F Int) 222 | -- in (\(x :: F Int) -> x |> (sym co) y) x 223 | -- 224 | -- One other thing we have to be careful about is recursive types: 225 | -- f :: Rec = (\(x :: Int) -> f) |> (nt_ax :: (Int -> Rec) ~ Rec) 226 | -- 227 | -- Translating to: 228 | -- f :: * = (\(x :: *) -> f) :: * -> * 229 | -- 230 | -- From this, it is clear that we could -- but *should not* -- update let-binder types from the type of 231 | -- their RHSs, since we can iterate this forever and build infinite arbitrarily large types. 232 | 233 | selectData :: Trivial -> CoId -> [(G.DataCon, CoId)] -> Term 234 | selectData t u_def dcs_us = Term [] [] (Call t Unbox [lookup dc dcs_us `orElse` u_def | dc <- dc_family]) 235 | where dc_family = G.dataConFamily (fst (head dcs_us)) 236 | 237 | selectLiteral :: Trivial -> CoId -> [(Literal, CoId)] -> Term 238 | selectLiteral t = error "FIXME: selectLiteral (perhaps via a primitive Id we can call)" t 239 | 240 | typeFromVar :: G.Var -> [Type] 241 | typeFromVar (G.AnId x) = fromTypeThunky (G.idType x) 242 | typeFromVar (G.ATyVar _) = [] 243 | 244 | fromVar :: G.Var -> [Id] 245 | fromVar (G.AnId x) = fromId x 246 | fromVar (G.ATyVar _) = [] 247 | 248 | fromAlts :: (CoId -> [(a, CoId)] -> Term) 249 | -> Context -> Subst -> Maybe G.Term -> [(a, ([G.Id], G.Term))] -> Kont -> Term 250 | fromAlts select ids0 subst mb_def selectors_alts u = bindKont u ids0 fromAlts' 251 | where 252 | fromAlts' ids0 u = e2 253 | where 254 | e0 = select (mb_def_u `orElse` error "FIXME: add an unreachable fallback") selector_us 255 | ((ids1, mb_def_u), e1) = case mb_def of 256 | Nothing -> ((ids0, Nothing), e0) 257 | Just e -> ((ids1, Just w), addContinuation w (Continuation [] (fromTerm ids2 (subst, e) (Unknown u))) e0) 258 | where (ids1, w) = freshCoId ids0 "w" [] 259 | ((ids2, e2), selector_us) = mapAccumL (\(ids1, e1) (selector, (xs, e)) -> let k = Continuation (catMaybes mb_ys) (fromTerm ids2 (subst', e) (Unknown u)) 260 | (ids2a, w) = freshCoId ids1 "w" (continuationCoType k) 261 | (ids2b, subst', mb_ys) = renameBinders renameIdBinder ids2a subst xs 262 | in ((ids2b, addContinuation w k e1), (selector, w))) 263 | (ids1, e1) selectors_alts 264 | -------------------------------------------------------------------------------- /CPS/Syntax.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards #-} 2 | module CPS.Syntax where 3 | 4 | import GHC.Primitives 5 | 6 | import Name 7 | import Utilities 8 | 9 | import qualified Data.Map as M 10 | import qualified Data.Set as S 11 | 12 | 13 | type CoType = [Type] 14 | 15 | data Type = IntHashTy | PtrTy 16 | deriving (Eq, Show) 17 | 18 | 19 | data Id = Id { 20 | idName :: Name, 21 | idType :: Type 22 | } deriving (Show) 23 | 24 | instance Eq Id where (==) = (==) `on` getUnique 25 | instance Ord Id where compare = compare `on` getUnique 26 | 27 | data CoId = CoId { 28 | coIdName :: Name, 29 | coIdType :: CoType 30 | } deriving (Show) 31 | 32 | instance Eq CoId where (==) = (==) `on` getUnique 33 | instance Ord CoId where compare = compare `on` getUnique 34 | 35 | 36 | -- Things which are available with literally zero computational effort 37 | -- NB: do not include arithmetic operation applications since we may want to share them 38 | data Trivial = IdOcc Id 39 | | Literal Literal 40 | | PrimOp PrimOp 41 | | Update [CoType] CoType [CoType] 42 | deriving (Show) 43 | -- FIXME: add "blackhole"/"update-with-bh" primop (useful if moving update out of a thunk itself statically, as well as at runtime) 44 | 45 | -- Interesting simplification rules: 46 | -- * Call to something of boxy type with a single no-args cont can be simplified to a call to that cont 47 | -- * No need to update things that are already values: perhaps we can do this by evaluating an update directly in the RHS of the updatee at compile time. 48 | -- Note that if we start shifting updates around we can't just evaluate *any* update whenever we see an update to a let-bound thing, because there may 49 | -- be two syntactically distinct updates to the same variable e.g. after simplifying (let x = case y of A -> B; B -> A in case x of A -> e1; B -> e2) 50 | -- * Updating a pun can just be dropped (NB: check this makes sense) 51 | -- * Continuations should be floated as far in as possible because that ensures they are syntactically nested within their dominators, which 52 | -- can expose information available at all call sites 53 | -- * We can do pun introduction: we can simplify x <> (\. e) to x <> (\. e[pun x'/x]). This is one of the rules where floating continuations 54 | -- maximally in is useful. 55 | 56 | -- FIXME: have a CoTrivial with a polymorphic "unreachable" as well as monotyped "halt"? 57 | 58 | data Function = Function [Id] [CoId] Term | Box [CoType] [Trivial] [CoType] 59 | deriving (Show) 60 | 61 | data Continuation = Continuation [Id] Term 62 | deriving (Show) 63 | 64 | data Term = Term [(Id, Function)] [(CoId, Continuation)] Transfer 65 | deriving (Show) 66 | 67 | data CallArgs = Unbox | Enter [Trivial] 68 | deriving (Show) 69 | 70 | data Transfer = Return CoId [Trivial] 71 | | Call Trivial CallArgs [CoId] 72 | deriving (Show) 73 | 74 | instance Pretty Type where 75 | pPrint ty = case ty of 76 | IntHashTy -> text "Int#" 77 | PtrTy -> text "*" 78 | 79 | instance Pretty Id where 80 | pPrintPrec level prec = pPrintPrec level prec . idName 81 | 82 | instance Pretty CoId where 83 | pPrintPrec level prec = pPrintPrec level prec . coIdName 84 | 85 | instance Pretty Trivial where 86 | pPrintPrec level prec t = case t of 87 | IdOcc x -> pPrintPrec level prec x 88 | Literal l -> pPrintPrec level prec l 89 | PrimOp pop -> pPrintPrec level prec pop 90 | Update ntys1 nt ntys2 -> pPrintPrecFunny level prec (text "Update") ntys1 nt ntys2 91 | 92 | instance Pretty Function where 93 | pPrintPrec level prec f = case f of 94 | Function xs us e -> pPrintPrecLams level prec [PrettyFunction $ \level prec -> pPrintPrecMulti level prec xs, PrettyFunction $ \level prec -> pPrintPrecMulti level prec us] e 95 | Box ntys1 ts ntys2 -> pPrintPrecFunny level prec (text "Box") ntys1 ts ntys2 96 | 97 | instance Pretty Continuation where 98 | pPrintPrec level prec (Continuation xs e) = pPrintPrecLams level prec [PrettyFunction $ \level prec -> pPrintPrecMulti level prec xs] e 99 | 100 | instance Pretty Term where 101 | pPrintPrec level prec (Term xfs uks r) = pPrintPrecLetRec level prec ([(asPrettyFunction x, asPrettyFunction f) | (x, f) <- xfs] ++ [(asPrettyFunction u, asPrettyFunction k) | (u, k) <- uks]) r 102 | 103 | instance Pretty CallArgs where 104 | pPrintPrec level prec a = case a of 105 | Unbox -> text "" 106 | Enter ts -> pPrintPrecMulti level prec ts 107 | 108 | instance Pretty Transfer where 109 | pPrintPrec level prec r = case r of 110 | Return u ts -> pPrintPrecApps level prec u ts 111 | Call t cas us -> pPrintPrecApps level prec t [asPrettyFunction cas, PrettyFunction $ \level prec -> pPrintPrecMulti level prec us] 112 | 113 | pPrintPrecFunny :: (Pretty a, Pretty b, Pretty c, Pretty d) => PrettyLevel -> Rational -> a -> [[b]] -> [c] -> [[d]] -> Doc 114 | pPrintPrecFunny level prec hd ntys1 ts ntys2 = pPrintPrecApps level prec hd [PrettyFunction $ \level prec -> pPrintPrecAlty level prec $ [PrettyFunction $ \level prec -> pPrintPrecMulti level prec nty | nty <- ntys1] ++ 115 | [PrettyFunction $ \level prec -> text "!" <> pPrintPrecMulti level prec ts] ++ 116 | [PrettyFunction $ \level prec -> pPrintPrecMulti level prec nty | nty <- ntys2]] 117 | 118 | pPrintPrecMulti :: Pretty a => PrettyLevel -> Rational -> [a] -> Doc 119 | pPrintPrecMulti level prec [x] = pPrintPrec level prec x 120 | pPrintPrecMulti level prec xs = prettyAngles (prec >= appPrec) $ hsep (punctuate (text ",") [pPrintPrec level noPrec x | x <- xs]) 121 | -- Experimental pretty-printing change: skip the angle brackets if we can avoid it, so that True is (Box <|!>) rather than (Box <<>|!<>>). 122 | -- FIXME: as a consequence we do get (<> -> Int#,Int#) instead of (<> -> ), but maybe that is OK? 123 | 124 | prettyAngles :: Bool -> Doc -> Doc 125 | prettyAngles False = id 126 | prettyAngles True = angles 127 | 128 | pPrintPrecAlty :: Pretty a => PrettyLevel -> Rational -> [a] -> Doc 129 | pPrintPrecAlty level prec [x] = pPrintPrec level prec x 130 | pPrintPrecAlty level _ xs = angles (hcat (intersperse (text "|") [pPrintPrec level noPrec x | x <- xs])) 131 | 132 | pPrintPrecLams :: (Pretty a, Pretty b) => PrettyLevel -> Rational -> [a] -> b -> Doc 133 | pPrintPrecLams level prec xs e = prettyParen (prec > noPrec) $ text "\\" <> hsep [pPrintPrec level appPrec y | y <- xs] <+> text "->" <+> pPrintPrec level noPrec e 134 | 135 | 136 | newtype LintM a = LintM { unLintM :: [Doc] -> ([Doc], a) } 137 | 138 | instance Monad LintM where 139 | return x = LintM $ \doc -> (doc, x) 140 | mx >>= fxmy = LintM $ \doc -> case unLintM mx doc of (doc, x) -> unLintM (fxmy x) doc 141 | 142 | runLintM :: LintM () -> [Doc] 143 | runLintM mx = case unLintM mx [] of (docs, ()) -> docs 144 | 145 | warnM :: [Doc] -> LintM () 146 | warnM xs = LintM $ \docs -> (xs ++ docs, ()) 147 | 148 | lintDistinct :: (Pretty a, Ord a) => Doc -> [a] -> LintM () 149 | lintDistinct what xs = warnM [what <+> text "not distinct: " <+> pPrint xs | allDistinct xs == False] 150 | 151 | lintTerm :: UniqueMap Type -> UniqueMap CoType -> Term -> LintM () 152 | lintTerm x_tys u_ntys (Term xfs uks r) = do 153 | x_tys <- lintIdBinders x_tys (map fst xfs) 154 | u_ntys <- lintCoIdBinders u_ntys (map fst uks) 155 | mapM_ (uncurry (lintFunction x_tys)) xfs 156 | mapM_ (uncurry (lintContinuation x_tys u_ntys)) uks 157 | lintTransfer x_tys u_ntys r 158 | 159 | lintIdBinders :: UniqueMap Type -> [Id] -> LintM (UniqueMap Type) 160 | lintIdBinders x_tys xs = do 161 | lintDistinct (text "Id binders") xs 162 | return x_tys' 163 | where x_tys' = foldr (\x -> insertUniqueMap x (idType x)) x_tys xs 164 | 165 | lintCoIdBinders :: UniqueMap CoType -> [CoId] -> LintM (UniqueMap CoType) 166 | lintCoIdBinders u_ntys us = do 167 | lintDistinct (text "CoId binders") us 168 | return u_ntys' 169 | where u_ntys' = foldr (\u -> insertUniqueMap u (coIdType u)) u_ntys us 170 | 171 | lintFunction :: UniqueMap Type -> Id -> Function -> LintM () 172 | lintFunction x_tys x f = do 173 | case f of Function xs us e -> do 174 | x_tys <- lintIdBinders x_tys xs 175 | u_ntys <- lintCoIdBinders emptyUniqueMap us 176 | lintTerm x_tys u_ntys e 177 | Box _ ts _ -> mapM_ (lintTrivial x_tys) ts 178 | warnM [hang (pPrint x <+> text "RHS type incompatible") 2 179 | (text "Bound as:" <+> pPrint (idType x) $$ 180 | text "RHS is:" <+> pPrint PtrTy) 181 | | idType x /= PtrTy] 182 | 183 | lintContinuation :: UniqueMap Type -> UniqueMap CoType -> CoId -> Continuation -> LintM () 184 | lintContinuation x_tys u_ntys u k@(Continuation xs e) = do 185 | x_tys <- lintIdBinders x_tys xs 186 | lintTerm x_tys u_ntys e 187 | warnM [hang (pPrint u <+> text "RHS cotype incompatible") 2 188 | (text "Bound as:" <+> pPrint (coIdType u) $$ 189 | text "RHS is:" <+> pPrint (continuationCoType k)) 190 | | coIdType u /= continuationCoType k] 191 | 192 | lintTransfer :: UniqueMap Type -> UniqueMap CoType -> Transfer -> LintM () 193 | lintTransfer x_tys u_ntys (Return u ts) = do 194 | lintCoId u_ntys u 195 | mapM_ (lintTrivial x_tys) ts 196 | warnM [hang (pPrint u <+> text "return type incompatible:") 2 197 | (text "Applied:" <+> pPrint ts <+> text "::" <+> pPrint (map trivialType ts) $$ 198 | text "Expected:" <+> pPrint (coIdType u)) 199 | | map trivialType ts /= coIdType u] 200 | lintTransfer x_tys u_ntys (Call t ca us) = do 201 | lintTrivial x_tys t 202 | case ca of Enter ts -> mapM_ (lintTrivial x_tys) ts 203 | Unbox -> return () 204 | mapM_ (lintCoId u_ntys) us 205 | warnM [hang (text "Function of unexpected type:") 2 206 | (text "Saw:" <+> pPrint t <+> text "::" <+> pPrint (trivialType t) $$ 207 | text "Expected:" <+> pPrint PtrTy) 208 | | trivialType t /= PtrTy] 209 | 210 | lintTrivial :: UniqueMap Type -> Trivial -> LintM () 211 | lintTrivial x_tys (IdOcc x) = case lookupUniqueMap x x_tys of 212 | Nothing -> warnM [pPrint x <+> text "out of scope"] 213 | Just x_ty -> warnM [pPrint x <+> text "occurrence type not up to date" | x_ty /= idType x] 214 | lintTrivial _ (Literal _) = return () 215 | lintTrivial _ (PrimOp _) = return () 216 | lintTrivial _ (Update _ _ _) = return () 217 | 218 | lintCoId :: UniqueMap CoType -> CoId -> LintM () 219 | lintCoId u_ntys u = case lookupUniqueMap u u_ntys of 220 | Nothing -> warnM [pPrint u <+> text "out of scope"] 221 | Just u_ty -> warnM [pPrint u <+> text "occurrence type not up to date" | u_ty /= coIdType u] 222 | 223 | 224 | literalType :: Literal -> Type 225 | literalType (Int _) = IntHashTy 226 | 227 | trivialType :: Trivial -> Type 228 | trivialType (IdOcc x) = idType x 229 | trivialType (Literal l) = literalType l 230 | trivialType (PrimOp _) = PtrTy 231 | trivialType (Update _ _ _) = PtrTy 232 | 233 | continuationCoType :: Continuation -> CoType 234 | continuationCoType (Continuation xs _) = map idType xs 235 | 236 | 237 | instance Uniqueable Id where 238 | getUnique = getUnique . idName 239 | 240 | instance Uniqueable CoId where 241 | getUnique = getUnique . coIdName 242 | 243 | 244 | newtype IdSubst = IdSubst { unIdSubst :: UniqueMap Trivial } 245 | 246 | mkIdSubst :: S.Set Id -> IdSubst 247 | mkIdSubst xs = IdSubst (M.fromList [(getUnique x, IdOcc x) | x <- S.toList xs]) 248 | 249 | newtype CoIdSubst = CoIdSubst { unCoIdSubst :: UniqueMap CoId } 250 | 251 | mkCoIdSubst :: S.Set CoId -> CoIdSubst 252 | mkCoIdSubst us = CoIdSubst (M.fromList [(getUnique u, u) | u <- S.toList us]) 253 | 254 | data Subst = Subst { idSubst :: IdSubst, coIdSubst :: CoIdSubst } 255 | 256 | emptySubst :: Subst 257 | emptySubst = Subst { idSubst = IdSubst M.empty, coIdSubst = CoIdSubst M.empty } 258 | 259 | substFromIdSubst :: IdSubst -> Subst 260 | substFromIdSubst idsubst = Subst { idSubst = idsubst, coIdSubst = CoIdSubst M.empty } 261 | 262 | substFromCoIdSubst :: CoIdSubst -> Subst 263 | substFromCoIdSubst coidsubst = Subst { idSubst = IdSubst M.empty, coIdSubst = coidsubst } 264 | 265 | 266 | renameIdBinder' :: InScopeSet -> IdSubst -> Id -> (InScopeSet, IdSubst, Id) 267 | renameIdBinder' iss idsubst x = (iss', IdSubst (insertUniqueMap n (IdOcc x') (unIdSubst idsubst)), x') 268 | where n = idName x 269 | (iss', n') = uniqAwayName iss n 270 | x' = x { idName = n' } -- NB: don't need to rename types 271 | 272 | renameIdBinder :: InScopeSet -> Subst -> Id -> (InScopeSet, Subst, Id) 273 | renameIdBinder iss subst x = (iss', subst { idSubst = idsubst' }, x') 274 | where (iss', idsubst', x') = renameIdBinder' iss (idSubst subst) x 275 | 276 | renameCoIdBinder' :: InScopeSet -> CoIdSubst -> CoId -> (InScopeSet, CoIdSubst, CoId) 277 | renameCoIdBinder' iss coidsubst u = (iss', CoIdSubst (insertUniqueMap n u' (unCoIdSubst coidsubst)), u') 278 | where n = coIdName u 279 | (iss', n') = uniqAwayName iss n 280 | u' = u { coIdName = n' } -- NB: don't need to rename types 281 | 282 | renameCoIdBinder :: InScopeSet -> Subst -> CoId -> (InScopeSet, Subst, CoId) 283 | renameCoIdBinder iss subst u = (iss', subst { coIdSubst = coidsubst' }, u') 284 | where (iss', coidsubst', u') = renameCoIdBinder' iss (coIdSubst subst) u 285 | 286 | renameBinders :: (iss -> subst -> a -> (iss, subst, b)) 287 | -> iss -> subst -> [a] -> (iss, subst, [b]) 288 | renameBinders rename = curry ((unnest .) . mapAccumL (\(ids, subst) -> nest . rename ids subst)) 289 | where unnest ((a, b), c) = (a, b, c) 290 | nest (a, b, c) = ((a, b), c) 291 | 292 | renameId :: IdSubst -> Id -> Trivial 293 | renameId idsubst x = findUniqueWithDefault (error $ "renameId: " ++ pPrintRender x ++ " out of scope") x (unIdSubst idsubst) 294 | 295 | renameCoId :: CoIdSubst -> CoId -> CoId 296 | renameCoId coidsubst u = findUniqueWithDefault (error $ "renameId: " ++ pPrintRender u ++ " out of scope") u (unCoIdSubst coidsubst) 297 | 298 | insertIdRenaming :: Id -> Trivial -> Subst -> Subst 299 | insertIdRenaming x t' subst = subst { idSubst = IdSubst (insertUniqueMap x t' (unIdSubst (idSubst subst))) } 300 | 301 | insertCoIdRenaming :: CoId -> CoId -> Subst -> Subst 302 | insertCoIdRenaming u u' subst = subst { coIdSubst = CoIdSubst (insertUniqueMap u u' (unCoIdSubst (coIdSubst subst))) } 303 | 304 | insertRenamings :: (Pretty a, Pretty b) 305 | => (a -> b -> Subst -> Subst) 306 | -> [a] -> [b] -> Subst -> Subst 307 | insertRenamings insert xs ys subst = foldl' (\subst (x, y) -> insert x y subst) subst (expectJust ("insertRenamings: " ++ pPrintRender (xs, ys)) (xs `zipEqual` ys)) 308 | 309 | 310 | renameTrivial :: IdSubst -> Trivial -> Trivial 311 | renameTrivial idsubst (IdOcc x) = renameId idsubst x 312 | renameTrivial _ (Literal x) = Literal x 313 | renameTrivial _ (PrimOp pop) = PrimOp pop 314 | renameTrivial _ (Update ntys1 nt ntys2) = Update ntys1 nt ntys2 315 | 316 | 317 | renameFunction :: InScopeSet -> IdSubst -> Function -> Function 318 | renameFunction iss0 idsubst0 (Function xs us e) = Function xs' us' (renameTerm iss2 subst2 e) 319 | where (iss1, idsubst1, xs') = renameBinders renameIdBinder' iss0 idsubst0 xs 320 | (iss2, subst2, us') = renameBinders renameCoIdBinder iss1 (substFromIdSubst idsubst1) us 321 | renameFunction _ idsubst0 (Box tys0 ts tys1) = Box tys0 (map (renameTrivial idsubst0) ts) tys1 322 | 323 | renameContinuation :: InScopeSet -> Subst -> Continuation -> Continuation 324 | renameContinuation iss0 subst0 (Continuation xs e) = Continuation xs' (renameTerm iss1 subst1 e) 325 | where (iss1, subst1, xs') = renameBinders renameIdBinder iss0 subst0 xs 326 | 327 | renameTerm :: InScopeSet -> Subst -> Term -> Term 328 | renameTerm iss0 subst0 (Term xfs uks r) = Term (xs' `zip` map (renameFunction iss2 (idSubst subst2)) fs) 329 | (us' `zip` map (renameContinuation iss2 subst2) ks) 330 | (renameTransfer subst2 r) 331 | where (xs, fs) = unzip xfs 332 | (us, ks) = unzip uks 333 | (iss1, subst1, xs') = renameBinders renameIdBinder iss0 subst0 xs 334 | (iss2, subst2, us') = renameBinders renameCoIdBinder iss1 subst1 us 335 | 336 | renameCallArgs :: IdSubst -> CallArgs -> CallArgs 337 | renameCallArgs idsubst (Enter ts) = Enter (map (renameTrivial idsubst) ts) 338 | renameCallArgs _ Unbox = Unbox 339 | 340 | renameTransfer :: Subst -> Transfer -> Transfer 341 | renameTransfer subst (Return u ts) = Return (renameCoId (coIdSubst subst) u) (map (renameTrivial (idSubst subst)) ts) 342 | renameTransfer subst (Call t ca us) = Call (renameTrivial (idSubst subst) t) (renameCallArgs (idSubst subst) ca) (map (renameCoId (coIdSubst subst)) us) 343 | 344 | 345 | trivialFreeIds :: Trivial -> S.Set Id 346 | trivialFreeIds (IdOcc x) = S.singleton x 347 | trivialFreeIds (Literal _) = S.empty 348 | trivialFreeIds (PrimOp _) = S.empty 349 | trivialFreeIds (Update _ _ _) = S.empty 350 | 351 | 352 | type Heap = M.Map Id (IdSubst, Function) 353 | 354 | type Stack = [M.Map CoId (Subst, Continuation)] 355 | 356 | stackLookup :: CoId -> Stack -> Maybe ((Subst, Continuation), Stack) 357 | stackLookup _ [] = Nothing 358 | stackLookup u (kf:k) = case M.lookup u kf of 359 | Just res -> Just (res, kf:k) 360 | Nothing -> stackLookup u k 361 | 362 | type State = (InScopeSet, Heap, (Subst, Term), Stack) 363 | 364 | addFunction :: Id -> Function -> Term -> Term 365 | addFunction x f (Term xfs uks r) = Term ((x, f) : xfs) uks r 366 | 367 | addContinuation :: CoId -> Continuation -> Term -> Term 368 | addContinuation u k (Term xfs uks r) = Term xfs ((u, k) : uks) r 369 | 370 | stateToTerm :: State -> Term 371 | stateToTerm (iss, h, (subst, e), k) = flip (foldr (\(x, (idsubst, f)) -> addFunction x (renameFunction iss idsubst f))) (M.toList h) $ 372 | flip (foldr (\kf -> flip (foldr (\(u, (subst, k)) -> addContinuation u (renameContinuation iss subst k))) (M.toList kf))) k $ 373 | renameTerm iss subst e 374 | 375 | -- FIXME: blackholing. When we first enter we should blackhole the thunk: x |-> \<> k. blackhole <> <> 376 | 377 | -- Principal: it's OK to error out if the term is badly typed, but not if some information is missing 378 | -- NB: the output type is guaranteed to be a *subtype* of the input type. In representation-type systems 379 | -- with subtyping reduction may improve the type e.g.: 380 | -- 381 | -- let id :: forall a. a -> a = /\a. \(x :: a). x 382 | -- f :: Int -> Int = id @Int 383 | -- in id @(Int -> Int) f :: Int -> Int 384 | -- 385 | -- let id :: * -> * = \(x :: *). x 386 | -- f :: * -> * = id 387 | -- in id f :: * 388 | -- 389 | -- let id :: * -> * = \(x :: *). x 390 | -- f :: * -> * = id 391 | -- in f :: * -> * 392 | step :: State -> Maybe State 393 | step (iss0, h, (subst0, Term xfs uks r), k) = case renameTransfer subst2 r of 394 | Return u' ts' -> return_step (iss2, h', (u', ts'), k') 395 | Call t' ca' us' -> case t' of 396 | IdOcc x' -> do 397 | (idsubst, f) <- M.lookup x' h' 398 | case f of Function ys vs e 399 | | Enter ts' <- ca' 400 | -> return (iss2, h', (insertRenamings insertIdRenaming ys ts' (insertRenamings insertCoIdRenaming vs us' (substFromIdSubst idsubst)), e), k') 401 | Box tys ss _ 402 | | Unbox <- ca' 403 | , Just u' <- us' `at` length tys 404 | -> return_step (iss2, h', (u', map (renameTrivial idsubst) ss), k') 405 | | Enter [] <- ca' 406 | , [u'] <- us' 407 | -> return_step (iss2, h', (u', [t']), k') 408 | _ -> error "step: untypeable call to IdOcc?" 409 | Update ntys1 nty ntys2 410 | | Enter ts' <- ca' 411 | , (IdOcc x':ts_update') <- ts' 412 | , [u'] <- us' 413 | , let one iss nty = case uniqAway iss (getUnique x') of (iss, u) -> (iss, CoId { coIdName = Name { nameString = "k", nameUnique = u }, coIdType = nty }) 414 | (iss3, vs'1) = mapAccumL one iss2 ntys1 415 | (iss4, v') = one iss3 nty 416 | (_, vs'2) = mapAccumL one iss4 ntys2 417 | vs' = vs'1 ++ [v'] ++ vs'2 418 | -> -- NB: updating anything other than IdOcc is impossible (FIXME: can be cleaner?) 419 | return_step (iss2, M.insert x' (mkIdSubst (S.unions (map trivialFreeIds ts_update')), {- Box ntys1 ts_update' ntys2 -} Function [] vs' (Term [] [] (Return v' ts_update'))) h', (u', ts_update'), k') 420 | -- NB: we *can* do update-in-place for thunks in general, but do we want to? 421 | -- In the common case where (length ts_update' == 1) and the thing updated with is a box, it is unambiguously good: 422 | -- any extra heap allocation can be eliminated by the GC when it collapses indirections (using punning). But if we do 423 | -- it in general then we risk overwriting several heap cells with the same Boxes! 424 | -- 425 | -- One thing is clear: the compiler must be very careful when it introduces one of these boxes. Perhaps it should only 426 | -- do so when it is clear that the thunk will not in fact be updated (think about CPR). 427 | PrimOp pop 428 | | Enter ts' <- ca' 429 | , Just t' <- stepPrimOp pop ts' 430 | , [u'] <- us' -> 431 | return_step (iss2, h', (u', [t']), k') 432 | _ -> error "step: untypeable call to non-IdOcc?" 433 | where 434 | (xs, fs) = unzip xfs 435 | (us, ks) = unzip uks 436 | (iss1, subst1, xs') = renameBinders renameIdBinder iss0 subst0 xs 437 | (iss2, subst2, us') = renameBinders renameCoIdBinder iss1 subst1 us 438 | h' = M.fromList (xs' `zip` map ((,) (idSubst subst2)) fs) `M.union` h 439 | k' = M.fromList (us' `zip` map ((,) subst2) ks) : k 440 | 441 | return_step (iss, h, (u', ts'), k) = do 442 | ((subst, Continuation ys e), k) <- stackLookup u' k 443 | return (iss, h, (insertRenamings insertIdRenaming ys ts' subst, e), k) 444 | 445 | stepPrimOp :: PrimOp -> [Trivial] -> Maybe Trivial 446 | stepPrimOp pop = case pop of 447 | Add -> int_int_int (+) 448 | Subtract -> int_int_int (+) 449 | Multiply -> int_int_int (*) 450 | Divide -> int_int_int div 451 | Modulo -> int_int_int mod 452 | Equal -> int_int_bool (==) 453 | LessThan -> int_int_bool (==) 454 | LessThanEqual -> int_int_bool (==) 455 | where 456 | int_int_int f [Literal (Int i1), Literal (Int i2)] = Just (Literal (Int (f i1 i2))) 457 | int_int_int _ _ = Nothing 458 | 459 | int_int_bool f [Literal (Int i1), Literal (Int i2)] = error "FIXME: stepPrimOp with Bool result" (f i1 i2) 460 | int_int_bool _ _ = Nothing 461 | -------------------------------------------------------------------------------- /Utilities.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections, PatternGuards, ExistentialQuantification, DeriveFunctor, DeriveFoldable, DeriveTraversable, GeneralizedNewtypeDeriving, 2 | TypeSynonymInstances, FlexibleInstances, IncoherentInstances, OverlappingInstances, TypeOperators, CPP #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | module Utilities ( 5 | module UniqueSupply, 6 | module Utilities, 7 | 8 | module Control.Arrow, 9 | module Control.Monad, 10 | 11 | module Data.Function, 12 | module Data.Maybe, 13 | module Data.List, 14 | 15 | module Debug.Trace, 16 | 17 | module Text.PrettyPrint.HughesPJClass 18 | ) where 19 | 20 | import UniqueSupply 21 | 22 | import Control.Arrow (first, second, (***), (&&&)) 23 | import Control.Monad hiding (join) 24 | 25 | import Data.Function (on) 26 | import Data.Maybe 27 | import Data.Monoid 28 | import Data.List 29 | import qualified Data.IntMap as IM 30 | import qualified Data.IntSet as IS 31 | import qualified Data.Map as M 32 | import qualified Data.Set as S 33 | import Data.Tree 34 | import qualified Data.Foldable as Foldable 35 | import qualified Data.Traversable as Traversable 36 | 37 | import Debug.Trace 38 | 39 | import Text.PrettyPrint.HughesPJClass hiding (render, int, float, char) 40 | import qualified Text.PrettyPrint.HughesPJClass as Pretty 41 | 42 | import System.IO 43 | import System.IO.Unsafe (unsafePerformIO) 44 | 45 | 46 | -- | Copointed functors. The defining property is: 47 | -- 48 | -- extract (fmap f a) == f (extract a) 49 | class Functor f => Copointed f where 50 | extract :: f a -> a 51 | 52 | instance Copointed ((,) a) where 53 | extract = snd 54 | 55 | 56 | class Functor z => Zippable z where 57 | -- Naturality: 58 | -- fmap (first f) (zip_ as bs) == zip_ (fmap f as) bs 59 | -- fmap (second f) (zip_ as bs) == zip_ as (fmap f bs) 60 | -- 61 | -- Information preservation: 62 | -- fmap fst (zip_ as bs) == as 63 | -- fmap snd (zip_ as bs) == bs 64 | 65 | zip_ :: z a -> z b -> z (a, b) 66 | zip_ = zipWith_ (,) 67 | 68 | zipWith_ :: (a -> b -> c) -> z a -> z b -> z c 69 | zipWith_ f as bs = fmap (uncurry f) (zip_ as bs) 70 | 71 | 72 | #ifdef MIN_VERSION_base 73 | #if !(MIN_VERSION_base(4, 3, 0)) 74 | 75 | -- These instances are in base-4.3 76 | 77 | instance Monad (Either a) where 78 | return = Right 79 | 80 | Left l >>= _ = Left l 81 | Right x >>= fxmy = fxmy x 82 | 83 | #endif 84 | #endif 85 | 86 | 87 | class Show1 f where 88 | showsPrec1 :: Show a => Int -> f a -> ShowS 89 | 90 | instance (Show1 f, Show a) => Show (f a) where 91 | showsPrec = showsPrec1 92 | 93 | 94 | class Eq1 f where 95 | eq1 :: Eq a => f a -> f a -> Bool 96 | 97 | instance (Eq1 f, Eq a) => Eq (f a) where 98 | (==) = eq1 99 | 100 | 101 | class Eq1 f => Ord1 f where 102 | compare1 :: Ord a => f a -> f a -> Ordering 103 | 104 | instance (Ord1 f, Ord a) => Ord (f a) where 105 | compare = compare1 106 | 107 | 108 | class Pretty1 f where 109 | pPrintPrec1 :: Pretty a => PrettyLevel -> Rational -> f a -> Doc 110 | 111 | instance (Pretty1 f, Pretty a) => Pretty (f a) where 112 | pPrintPrec = pPrintPrec1 113 | 114 | 115 | newtype (f :.: g) a = Comp { unComp :: f (g a) } 116 | 117 | infixr 9 :.: 118 | 119 | instance (Copointed f, Copointed g) => Copointed (f :.: g) where 120 | extract = extract . extract . unComp 121 | 122 | instance (Show1 f, Show1 g) => Show1 (f :.: g) where 123 | showsPrec1 prec (Comp x) = showParen (prec >= appPrec) (showString "Comp" . showsPrec appPrec x) 124 | 125 | instance (Eq1 f, Eq1 g) => Eq1 (f :.: g) where 126 | eq1 (Comp x1) (Comp x2) = x1 == x2 127 | 128 | instance (Ord1 f, Ord1 g) => Ord1 (f :.: g) where 129 | compare1 (Comp x1) (Comp x2) = x1 `compare` x2 130 | 131 | instance (Pretty1 f, Pretty1 g) => Pretty1 (f :.: g) where 132 | pPrintPrec1 level prec (Comp x) = pPrintPrec level prec x 133 | 134 | instance (Functor f, Functor g) => Functor (f :.: g) where 135 | fmap f (Comp x) = Comp (fmap (fmap f) x) 136 | 137 | instance (Foldable.Foldable f, Foldable.Foldable g) => Foldable.Foldable (f :.: g) where 138 | foldMap f = Foldable.foldMap (Foldable.foldMap f) . unComp 139 | 140 | instance (Traversable.Traversable f, Traversable.Traversable g) => Traversable.Traversable (f :.: g) where 141 | traverse f = fmap Comp . Traversable.traverse (Traversable.traverse f) . unComp 142 | 143 | 144 | newtype Down a = Down { unDown :: a } deriving (Eq) 145 | 146 | instance Ord a => Ord (Down a) where 147 | Down a `compare` Down b = b `compare` a 148 | 149 | 150 | -- | Natural numbers on the cheap (for efficiency reasons) 151 | type Nat = Int 152 | 153 | 154 | newtype Fin = Fin { unFin :: Int } deriving (Eq, Ord, Show, Pretty) 155 | type FinSet = IS.IntSet 156 | type FinMap = IM.IntMap 157 | 158 | 159 | data Tag = TG { tagFin :: Fin, tagOccurrences :: Nat } deriving (Eq, Ord, Show) 160 | 161 | instance Pretty Tag where 162 | pPrint (TG i occs) = pPrint i <> brackets (pPrint occs) 163 | 164 | mkTag :: Int -> Tag 165 | mkTag i = TG (Fin i) 1 166 | 167 | injectTag :: Int -> Tag -> Tag 168 | injectTag cls (TG (Fin i) occs) = TG (Fin (cls * i)) occs 169 | 170 | tagInt :: Tag -> Int 171 | tagInt = unFin . tagFin 172 | 173 | data Tagged a = Tagged { tag :: !Tag, tagee :: !a } 174 | deriving (Functor, Foldable.Foldable, Traversable.Traversable) 175 | 176 | instance Copointed Tagged where 177 | extract = tagee 178 | 179 | instance Show1 Tagged where 180 | showsPrec1 prec (Tagged tg x) = showParen (prec >= appPrec) (showString "Tagged" . showsPrec appPrec tg . showsPrec appPrec x) 181 | 182 | instance Eq1 Tagged where 183 | eq1 (Tagged tg1 x1) (Tagged tg2 x2) = tg1 == tg2 && x1 == x2 184 | 185 | instance Ord1 Tagged where 186 | compare1 (Tagged tg1 x1) (Tagged tg2 x2) = (tg1, x1) `compare` (tg2, x2) 187 | 188 | instance Pretty1 Tagged where 189 | pPrintPrec1 level prec (Tagged tg x) = braces (pPrint tg) <+> pPrintPrec level prec x 190 | 191 | 192 | type Size = Int 193 | 194 | data Sized a = Sized { size :: !Size, sizee :: !a } 195 | deriving (Functor, Foldable.Foldable, Traversable.Traversable) 196 | 197 | instance Copointed Sized where 198 | extract = sizee 199 | 200 | instance Show1 Sized where 201 | showsPrec1 prec (Sized sz x) = showParen (prec >= appPrec) (showString "Sized" . showsPrec appPrec sz . showsPrec appPrec x) 202 | 203 | instance Eq1 Sized where 204 | eq1 (Sized sz1 x1) (Sized sz2 x2) = sz1 == sz2 && x1 == x2 205 | 206 | instance Ord1 Sized where 207 | compare1 (Sized sz1 x1) (Sized sz2 x2) = (sz1, x1) `compare` (sz2, x2) 208 | 209 | instance Pretty1 Sized where 210 | pPrintPrec1 level prec (Sized sz x) = bananas (text (show sz)) <> pPrintPrec level prec x 211 | 212 | 213 | instance Show UniqueSupply where 214 | show = show . uniqueFromSupply 215 | 216 | 217 | instance Pretty Doc where 218 | pPrint = id 219 | 220 | instance Pretty Rational where 221 | pPrint = rational 222 | 223 | instance Pretty Unique where 224 | pPrint = text . show 225 | 226 | instance Pretty IS.IntSet where 227 | pPrint xs = braces $ hsep (punctuate comma (map pPrint $ IS.toList xs)) 228 | 229 | instance Pretty v => Pretty (IM.IntMap v) where 230 | pPrint m = brackets $ fsep (punctuate comma [pPrint k <+> text "|->" <+> pPrint v | (k, v) <- IM.toList m]) 231 | 232 | instance Pretty a => Pretty (S.Set a) where 233 | pPrint xs = braces $ hsep (punctuate comma (map pPrint $ S.toList xs)) 234 | 235 | instance (Pretty k, Pretty v) => Pretty (M.Map k v) where 236 | pPrint m = brackets $ fsep (punctuate comma [pPrint k <+> text "|->" <+> pPrint v | (k, v) <- M.toList m]) 237 | 238 | instance Pretty a => Pretty (Tree a) where 239 | pPrint = text . drawTree . fmap (show . pPrint) 240 | 241 | deleteList :: Ord a => [a] -> S.Set a -> S.Set a 242 | deleteList = flip $ foldr S.delete 243 | 244 | deleteListMap :: Ord k => [k] -> M.Map k v -> M.Map k v 245 | deleteListMap = flip $ foldr M.delete 246 | 247 | fmapSet :: (Ord a, Ord b) => (a -> b) -> S.Set a -> S.Set b 248 | fmapSet f = S.fromList . map f . S.toList 249 | 250 | fmapMap :: (Ord a, Ord b) => (a -> b) -> M.Map a v -> M.Map b v 251 | fmapMap f = M.fromList . map (first f) . M.toList 252 | 253 | restrict :: Ord k => M.Map k v -> S.Set k -> M.Map k v 254 | -- restrict m s 255 | -- | M.size m < S.size s = M.filterWithKey (\k _ -> k `S.member` s) m -- O(m * log s) 256 | -- | otherwise = S.fold (\k out -> case M.lookup k m of Nothing -> out; Just v -> M.insert k v out) M.empty s -- O(s * log m) 257 | restrict m s = M.fromDistinctAscList $ merge (M.toAscList m) (S.toAscList s) 258 | where 259 | -- Theoretically O(m + s), so should outperform previous algorithm... 260 | merge _ [] = [] 261 | merge [] _ = [] 262 | merge ((k_m, v):kvs) (k_s:ks) = case compare k_m k_s of 263 | LT -> merge kvs (k_s:ks) 264 | EQ -> (k_m, v):merge kvs ks 265 | GT -> merge ((k_m, v):kvs) ks 266 | 267 | exclude :: Ord k => M.Map k v -> S.Set k -> M.Map k v 268 | --exclude m s = M.filterWithKey (\k _ -> k `S.notMember` s) m -- O(m * log s) 269 | exclude m s = M.fromDistinctAscList $ merge (M.toAscList m) (S.toAscList s) 270 | where 271 | -- Theoretically O(m + s), so should outperform previous algorithm... 272 | merge kvs [] = kvs 273 | merge [] _ = [] 274 | merge ((k_m, v):kvs) (k_s:ks) = case compare k_m k_s of 275 | LT -> (k_m, v):merge kvs (k_s:ks) 276 | EQ -> merge kvs ks 277 | GT -> merge ((k_m, v):kvs) ks 278 | 279 | mapMaybeSet :: (Ord a, Ord b) => (a -> Maybe b) -> S.Set a -> S.Set b 280 | mapMaybeSet f = S.fromList . mapMaybe f . S.toList 281 | 282 | listToMap :: Ord k => v -> [k] -> M.Map k v 283 | listToMap v = M.fromList . map (,v) 284 | 285 | setToMap :: Ord k => v -> S.Set k -> M.Map k v 286 | setToMap v = M.fromDistinctAscList . map (,v) . S.toAscList 287 | 288 | -- Essentially XOR on sets. See 289 | symmetricDifference :: Ord a => S.Set a -> S.Set a -> S.Set a 290 | symmetricDifference a b = (a S.\\ b) `S.union` (b S.\\ a) 291 | 292 | 293 | data Combining a b = LeftOnly a | Both a b | RightOnly b 294 | 295 | {-# INLINE finishCombining #-} 296 | finishCombining :: (a -> c) -> (b -> c) -> (a -> b -> c) -> Combining a b -> c 297 | finishCombining l r both combining = case combining of 298 | LeftOnly x -> l x 299 | Both x y -> both x y 300 | RightOnly y -> r y 301 | 302 | {-# INLINE combineMaps #-} 303 | combineMaps :: Ord k 304 | => (a -> c) -> (b -> c) -> (a -> b -> c) 305 | -> M.Map k a -> M.Map k b -> M.Map k c 306 | combineMaps l r both m1 m2 = M.map (finishCombining l r both) $ M.unionWith (\(LeftOnly x) (RightOnly y) -> Both x y) (M.map LeftOnly m1) (M.map RightOnly m2) 307 | 308 | {-# INLINE combineIntMaps #-} 309 | combineIntMaps :: (a -> c) -> (b -> c) -> (a -> b -> c) 310 | -> IM.IntMap a -> IM.IntMap b -> IM.IntMap c 311 | combineIntMaps l r both im1 im2 = IM.map (finishCombining l r both) $ IM.unionWith (\(LeftOnly x) (RightOnly y) -> Both x y) (IM.map LeftOnly im1) (IM.map RightOnly im2) 312 | 313 | 314 | {-# NOINLINE parseUniqueSupply #-} 315 | parseUniqueSupply :: UniqueSupply 316 | parseUniqueSupply = unsafePerformIO $ initUniqueSupply 'a' 317 | 318 | {-# NOINLINE expandUniqueSupply #-} 319 | expandUniqueSupply :: UniqueSupply 320 | expandUniqueSupply = unsafePerformIO $ initUniqueSupply 'e' 321 | 322 | {-# NOINLINE reduceUniqueSupply #-} 323 | reduceUniqueSupply :: UniqueSupply 324 | reduceUniqueSupply = unsafePerformIO $ initUniqueSupply 'u' 325 | 326 | {-# NOINLINE tagUniqueSupply #-} 327 | tagUniqueSupply :: UniqueSupply 328 | tagUniqueSupply = unsafePerformIO $ initUniqueSupply 't' 329 | 330 | {-# NOINLINE prettyUniqueSupply #-} 331 | prettyUniqueSupply :: UniqueSupply 332 | prettyUniqueSupply = unsafePerformIO $ initUniqueSupply 'p' 333 | 334 | {-# NOINLINE prettifyUniqueSupply #-} 335 | prettifyUniqueSupply :: UniqueSupply 336 | prettifyUniqueSupply = unsafePerformIO $ initUniqueSupply 'r' 337 | 338 | {-# NOINLINE matchUniqueSupply #-} 339 | matchUniqueSupply :: UniqueSupply 340 | matchUniqueSupply = unsafePerformIO $ initUniqueSupply 'm' 341 | 342 | stepUniqueSupply :: UniqueSupply -> (UniqueSupply, Unique) 343 | stepUniqueSupply = second uniqueFromSupply . splitUniqueSupply 344 | 345 | 346 | type UniqueMap a = M.Map Unique a 347 | 348 | class Uniqueable k where 349 | getUnique :: k -> Unique 350 | 351 | instance Uniqueable Unique where 352 | getUnique = id 353 | 354 | emptyUniqueMap :: UniqueMap a 355 | emptyUniqueMap = M.empty 356 | 357 | insertUniqueMap :: Uniqueable k => k -> a -> UniqueMap a -> UniqueMap a 358 | insertUniqueMap k v = M.insert (getUnique k) v 359 | 360 | lookupUniqueMap :: Uniqueable k => k -> UniqueMap a -> Maybe a 361 | lookupUniqueMap k = M.lookup (getUnique k) 362 | 363 | findUniqueWithDefault :: Uniqueable k => a -> k -> UniqueMap a -> a 364 | findUniqueWithDefault def k = M.findWithDefault def (getUnique k) 365 | 366 | 367 | data Train a b = Wagon a (Train a b) 368 | | Caboose b 369 | 370 | 371 | appPrec, opPrec, noPrec :: Num a => a 372 | appPrec = 2 -- Argument of a function application 373 | opPrec = 1 -- Argument of an infix operator 374 | noPrec = 0 -- Others 375 | 376 | normalLevel, haskellLevel :: PrettyLevel 377 | normalLevel = PrettyLevel 0 378 | haskellLevel = PrettyLevel 1 379 | 380 | 381 | pPrintPrecApp :: (Pretty a, Pretty b) => PrettyLevel -> Rational -> a -> b -> Doc 382 | pPrintPrecApp level prec e1 e2 = prettyParen (prec >= appPrec) $ pPrintPrec level opPrec e1 <+> pPrintPrec level appPrec e2 383 | 384 | pPrintPrecApps :: (Pretty a, Pretty b) => PrettyLevel -> Rational -> a -> [b] -> Doc 385 | pPrintPrecApps level prec e1 es2 = prettyParen (not (null es2) && prec >= appPrec) $ pPrintPrec level opPrec e1 <+> hsep (map (pPrintPrec level appPrec) es2) 386 | 387 | pPrintPrecLetRec :: (Pretty a, Pretty b, Pretty c) => PrettyLevel -> Rational -> [(a, b)] -> c -> Doc 388 | pPrintPrecLetRec level prec xes e_body 389 | | [] <- xes = pPrintPrec level prec e_body 390 | | otherwise = prettyParen (prec > noPrec) $ hang (if level == haskellLevel then text "let" else text "letrec") 2 (vcat [pPrintPrec level noPrec x <+> text "=" <+> pPrintPrec level noPrec e | (x, e) <- xes]) $$ text "in" <+> pPrintPrec level noPrec e_body 391 | 392 | 393 | angles, coangles, bananas :: Doc -> Doc 394 | angles d = Pretty.char '<' <> d <> Pretty.char '>' 395 | coangles d = Pretty.char '>' <> d <> Pretty.char '<' 396 | bananas d = text "(|" <> d <> text "|)" 397 | 398 | 399 | pPrintPrec' :: Pretty a => a -> PrettyLevel -> Rational -> Doc 400 | pPrintPrec' x level prec = pPrintPrec level prec x 401 | 402 | -- NB: this render function is exported instead of the one from the library 403 | render :: Doc -> String 404 | render = renderStyle (style { lineLength = 120 }) 405 | 406 | pPrintRender :: Pretty a => a -> String 407 | pPrintRender = render . pPrint 408 | 409 | panic :: String -> Doc -> a 410 | panic s d = error $ "PANIC!\n" ++ s ++ ": " ++ render d 411 | 412 | 413 | traceRender :: Pretty a => a -> b -> b 414 | traceRender x = trace (pPrintRender x) 415 | 416 | traceRenderM :: (Pretty a, Monad m) => a -> m () 417 | traceRenderM x = traceRender x (return ()) 418 | 419 | assertRender :: Pretty a => a -> Bool -> b -> b 420 | --assertRender _ _ x | not aSSERTIONS = x 421 | assertRender _ True x = x 422 | assertRender a False _ = error (render $ text "ASSERT FAILED!" $$ pPrint a) 423 | 424 | assertRenderM :: (Pretty a, Monad m) => a -> Bool -> m () 425 | assertRenderM a b = assertRender a b (return ()) 426 | 427 | 428 | removeOnes :: [a] -> [[a]] 429 | removeOnes [] = [] 430 | removeOnes (x:xs) = xs : map (x:) (removeOnes xs) 431 | 432 | listContexts :: [a] -> [([a], a, [a])] 433 | listContexts xs = zipWith (\is (t:ts) -> (is, t, ts)) (inits xs) (init (tails xs)) 434 | 435 | bagContexts :: [a] -> [(a, [a])] 436 | bagContexts xs = [(x, is ++ ts) | (is, x, ts) <- listContexts xs] 437 | 438 | seperate :: Eq a => a -> [a] -> [[a]] 439 | seperate c = go [] 440 | where 441 | go sofar [] = [reverse sofar] 442 | go sofar (x:xs) 443 | | x == c = reverse sofar : go [] xs 444 | | otherwise = go (x:sofar) xs 445 | 446 | allDistinct :: Ord a => [a] -> Bool 447 | allDistinct xs = S.size (S.fromList xs) == length xs 448 | 449 | 450 | accumL :: (acc -> (acc, a)) -> acc -> Int -> (acc, [a]) 451 | accumL f = go 452 | where 453 | go acc n | n <= 0 = (acc, []) 454 | | (acc, x) <- f acc = second (x:) (go acc (n - 1)) 455 | 456 | 457 | instance (Pretty a, Pretty b, Pretty c, Pretty d, 458 | Pretty e, Pretty f, Pretty g, Pretty h, 459 | Pretty i) => Pretty (a, b, c, d, e, f, g, h, i) where 460 | pPrint (a, b, c, d, e, f, g, h, i) 461 | = pPrintTuple [pPrint a, pPrint b, pPrint c, pPrint d, 462 | pPrint e, pPrint f, pPrint g, pPrint h, 463 | pPrint i] 464 | 465 | instance (Pretty a, Pretty b, Pretty c, Pretty d, 466 | Pretty e, Pretty f, Pretty g, Pretty h, 467 | Pretty i, Pretty j) => Pretty (a, b, c, d, e, f, g, h, i, j) where 468 | pPrint (a, b, c, d, e, f, g, h, i, j) 469 | = pPrintTuple [pPrint a, pPrint b, pPrint c, pPrint d, 470 | pPrint e, pPrint f, pPrint g, pPrint h, 471 | pPrint i, pPrint j] 472 | 473 | instance (Pretty a, Pretty b, Pretty c, Pretty d, 474 | Pretty e, Pretty f, Pretty g, Pretty h, 475 | Pretty i, Pretty j, Pretty k) => Pretty (a, b, c, d, e, f, g, h, i, j, k) where 476 | pPrint (a, b, c, d, e, f, g, h, i, j, k) 477 | = pPrintTuple [pPrint a, pPrint b, pPrint c, pPrint d, 478 | pPrint e, pPrint f, pPrint g, pPrint h, 479 | pPrint i, pPrint j, pPrint k] 480 | 481 | instance (Pretty a, Pretty b, Pretty c, Pretty d, 482 | Pretty e, Pretty f, Pretty g, Pretty h, 483 | Pretty i, Pretty j, Pretty k, Pretty l) => Pretty (a, b, c, d, e, f, g, h, i, j, k, l) where 484 | pPrint (a, b, c, d, e, f, g, h, i, j, k, l) 485 | = pPrintTuple [pPrint a, pPrint b, pPrint c, pPrint d, 486 | pPrint e, pPrint f, pPrint g, pPrint h, 487 | pPrint i, pPrint j, pPrint k, pPrint l] 488 | 489 | instance (Pretty a, Pretty b, Pretty c, Pretty d, 490 | Pretty e, Pretty f, Pretty g, Pretty h, 491 | Pretty i, Pretty j, Pretty k, Pretty l, 492 | Pretty m, Pretty n, Pretty o) => Pretty (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where 493 | pPrint (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) 494 | = pPrintTuple [pPrint a, pPrint b, pPrint c, pPrint d, 495 | pPrint e, pPrint f, pPrint g, pPrint h, 496 | pPrint i, pPrint j, pPrint k, pPrint l, 497 | pPrint m, pPrint n, pPrint o] 498 | 499 | pPrintTuple :: [Doc] -> Doc 500 | pPrintTuple ds = parens $ fsep $ punctuate comma ds 501 | 502 | 503 | data SomePretty = forall a. Pretty a => SomePretty a 504 | 505 | instance Pretty SomePretty where 506 | pPrintPrec level prec (SomePretty x) = pPrintPrec level prec x 507 | 508 | 509 | newtype PrettyFunction = PrettyFunction (PrettyLevel -> Rational -> Doc) 510 | 511 | instance Pretty PrettyFunction where 512 | pPrintPrec level prec (PrettyFunction f) = f level prec 513 | 514 | asPrettyFunction :: Pretty a => a -> PrettyFunction 515 | asPrettyFunction = PrettyFunction . pPrintPrec' 516 | 517 | 518 | fst3 :: (a, b, c) -> a 519 | fst3 (a, _, _) = a 520 | 521 | snd3 :: (a, b, c) -> b 522 | snd3 (_, b, _) = b 523 | 524 | thd3 :: (a, b, c) -> c 525 | thd3 (_, _, c) = c 526 | 527 | first3 :: (a -> d) -> (a, b, c) -> (d, b, c) 528 | first3 f (a, b, c) = (f a, b, c) 529 | 530 | second3 :: (b -> d) -> (a, b, c) -> (a, d, c) 531 | second3 f (a, b, c) = (a, f b, c) 532 | 533 | third3 :: (c -> d) -> (a, b, c) -> (a, b, d) 534 | third3 f (a, b, c) = (a, b, f c) 535 | 536 | second4 :: (b -> e) -> (a, b, c, d) -> (a, e, c, d) 537 | second4 f (a, b, c, d) = (a, f b, c, d) 538 | 539 | third4 :: (c -> e) -> (a, b, c, d) -> (a, b, e, d) 540 | third4 f (a, b, c, d) = (a, b, f c, d) 541 | 542 | fourth4 :: (d -> e) -> (a, b, c, d) -> (a, b, c, e) 543 | fourth4 f (a, b, c, d) = (a, b, c, f d) 544 | 545 | secondM :: Monad m => (b -> m c) -> (a, b) -> m (a, c) 546 | secondM f (a, b) = liftM (a,) $ f b 547 | 548 | 549 | uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d 550 | uncurry3 f (a, b, c) = f a b c 551 | 552 | 553 | splitBy :: [b] -> [a] -> ([a], [a]) 554 | splitBy [] xs = ([], xs) 555 | splitBy (_:ys) (x:xs) = first (x:) $ splitBy ys xs 556 | 557 | splitByReverse :: [b] -> [a] -> ([a], [a]) 558 | splitByReverse ys xs = case splitBy ys (reverse xs) of (xs1, xs2) -> (reverse xs2, reverse xs1) 559 | 560 | splitManyBy :: [[b]] -> [a] -> [[a]] 561 | splitManyBy [] xs = [xs] 562 | splitManyBy (ys:yss) xs = case splitBy ys xs of (xs1, xs2) -> xs1 : splitManyBy yss xs2 563 | 564 | dropBy :: [b] -> [a] -> [a] 565 | dropBy bs = snd . splitBy bs 566 | 567 | 568 | dropLastWhile :: (a -> Bool) -> [a] -> [a] 569 | dropLastWhile p = reverse . dropWhile p . reverse 570 | 571 | 572 | orElse :: Maybe a -> a -> a 573 | orElse = flip fromMaybe 574 | 575 | 576 | nTimes :: Int -> (a -> a) -> a -> a 577 | nTimes n f = foldr (.) id (replicate n f) 578 | 579 | 580 | takeFirst :: (a -> Bool) -> [a] -> (Maybe a, [a]) 581 | takeFirst p = takeFirstJust (\x -> guard (p x) >> return x) 582 | 583 | takeFirstJust :: (a -> Maybe b) -> [a] -> (Maybe b, [a]) 584 | takeFirstJust p = go 585 | where 586 | go [] = (Nothing, []) 587 | go (x:xs) 588 | | Just y <- p x = (Just y, xs) 589 | | otherwise = second (x:) $ go xs 590 | 591 | extractJusts :: (a -> Maybe b) -> [a] -> ([b], [a]) 592 | extractJusts p = foldr step ([], []) 593 | where step x rest | Just y <- p x = first (y:) rest 594 | | otherwise = second (x:) rest 595 | 596 | expectJust :: String -> Maybe a -> a 597 | expectJust _ (Just x) = x 598 | expectJust s Nothing = error $ "expectJust: " ++ s 599 | 600 | safeFromLeft :: Either a b -> Maybe a 601 | safeFromLeft (Left x) = Just x 602 | safeFromLeft _ = Nothing 603 | 604 | fmapEither :: (a -> b) -> (c -> d) -> Either a c -> Either b d 605 | fmapEither f g = either (Left . f) (Right . g) 606 | 607 | safeHead :: [a] -> Maybe a 608 | safeHead [] = Nothing 609 | safeHead (x:_) = Just x 610 | 611 | expectHead :: String -> [a] -> a 612 | expectHead s = expectJust s . safeHead 613 | 614 | uncons :: [a] -> Maybe (a, [a]) 615 | uncons [] = Nothing 616 | uncons (x:xs) = Just (x, xs) 617 | 618 | at :: [a] -> Int -> Maybe a 619 | at _ n | n < 0 = error "at: negative argument" 620 | at [] _ = Nothing 621 | at (x:_) 0 = Just x 622 | at (_:xs) n = at xs (n - 1) 623 | 624 | listSelectors :: [[a] -> a] 625 | listSelectors = iterate (\f xs -> f (tail xs)) head 626 | 627 | fixpoint :: Eq a => (a -> a) -> a -> a 628 | fixpoint f x 629 | | x' == x = x 630 | | otherwise = fixpoint f x' 631 | where x' = f x 632 | 633 | zipWithEqualM :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m [c] 634 | zipWithEqualM _ [] [] = return [] 635 | zipWithEqualM f (x:xs) (y:ys) = liftM2 (:) (f x y) (zipWithEqualM f xs ys) 636 | zipWithEqualM _ _ _ = fail "zipWithEqualM" 637 | 638 | zipWithEqualM_ :: Monad m => (a -> b -> m ()) -> [a] -> [b] -> m () 639 | zipWithEqualM_ _ [] [] = return () 640 | zipWithEqualM_ f (x:xs) (y:ys) = f x y >> zipWithEqualM_ f xs ys 641 | zipWithEqualM_ _ _ _ = fail "zipWithEqualM_" 642 | 643 | zipEqual :: [a] -> [b] -> Maybe [(a, b)] 644 | zipEqual = zipWithEqual (,) 645 | 646 | zipWithEqual :: (a -> b -> c) -> [a] -> [b] -> Maybe [c] 647 | zipWithEqual _ [] [] = Just [] 648 | zipWithEqual f (x:xs) (y:ys) = fmap (f x y :) $ zipWithEqual f xs ys 649 | zipWithEqual _ _ _ = fail "zipWithEqual" 650 | 651 | implies :: Bool -> Bool -> Bool 652 | implies cond consq = not cond || consq 653 | 654 | 655 | mapAccumM :: (Traversable.Traversable t, Monoid m) => (a -> (m, b)) -> t a -> (m, t b) 656 | mapAccumM f ta = Traversable.mapAccumL (\m a -> case f a of (m', b) -> (m `mappend` m', b)) mempty ta 657 | 658 | 659 | newtype Identity a = I { unI :: a } 660 | deriving (Functor, Foldable.Foldable, Traversable.Traversable) 661 | 662 | instance Show1 Identity where 663 | showsPrec1 prec (I x) = showParen (prec >= appPrec) (showString "Identity" . showsPrec appPrec x) 664 | 665 | instance Eq1 Identity where 666 | eq1 (I x1) (I x2) = x1 == x2 667 | 668 | instance Ord1 Identity where 669 | compare1 (I x1) (I x2) = x1 `compare` x2 670 | 671 | instance Pretty1 Identity where 672 | pPrintPrec1 level prec (I x) = pPrintPrec level prec x 673 | 674 | instance Copointed Identity where 675 | extract = unI 676 | 677 | instance Monad Identity where 678 | return = I 679 | mx >>= fxmy = fxmy (unI mx) 680 | 681 | 682 | sumMap :: (Foldable.Foldable f, Num b) => (a -> b) -> f a -> b 683 | sumMap f = Foldable.foldr (\x n -> f x + n) 0 684 | 685 | 686 | class (Functor t, Foldable.Foldable t) => Accumulatable t where 687 | mapAccumT :: (acc -> x -> (acc, y)) -> acc -> t x -> (acc, t y) 688 | mapAccumTM :: Monad m => (acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y) 689 | 690 | mapAccumT f acc x = unI (mapAccumTM (\acc' x' -> I (f acc' x')) acc x) 691 | 692 | fmapDefault :: (Accumulatable t) => (a -> b) -> t a -> t b 693 | fmapDefault f = snd . mapAccumT (\() x -> ((), f x)) () 694 | 695 | foldMapDefault :: (Accumulatable t, Monoid m) => (a -> m) -> t a -> m 696 | foldMapDefault f = fst . mapAccumT (\acc x -> (f x `mappend` acc, ())) mempty 697 | 698 | instance Accumulatable [] where 699 | mapAccumT = mapAccumL 700 | mapAccumTM = mapAccumLM 701 | 702 | mapAccumLM :: Monad m => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y]) 703 | mapAccumLM f = go [] 704 | where 705 | go ys acc [] = return (acc, reverse ys) 706 | go ys acc (x:xs) = do 707 | (acc, y) <- f acc x 708 | go (y:ys) acc xs 709 | 710 | concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] 711 | concatMapM f = go 712 | where 713 | go [] = return [] 714 | go (x:xs) = do 715 | ys <- f x 716 | liftM (ys ++) $ go xs 717 | 718 | instance Ord k => Accumulatable (M.Map k) where 719 | mapAccumTM f acc = liftM (second M.fromList) . mapAccumTM (\acc (k, x) -> liftM (second (k,)) (f acc x)) acc . M.toList 720 | 721 | 722 | type Bytes = Integer 723 | 724 | fileSize :: FilePath -> IO Bytes 725 | fileSize file = withFile file ReadMode hFileSize 726 | 727 | 728 | data ListPoint a = ListPoint [a] a [a] 729 | 730 | instance Functor ListPoint where 731 | fmap f (ListPoint xs y zs) = ListPoint (map f xs) (f y) (map f zs) 732 | 733 | locateListPoint :: (a -> Bool) -> [a] -> ListPoint a 734 | locateListPoint p = go [] 735 | where go _ [] = error "locateListPoint: no match" 736 | go left (here:right) 737 | | p here = ListPoint (reverse left) here right 738 | | otherwise = go (here:left) right 739 | --------------------------------------------------------------------------------