├── All.hs ├── Control └── Catchable.hs ├── Data ├── AChar.hs └── Nat.hs ├── Effect ├── Exception.hs ├── File.hs ├── Random.hs ├── Select.hs ├── State.hs └── StdIO.hs ├── Effects.hs ├── README.md ├── Sec211.hs ├── Sec212.hs ├── Sec213.hs ├── Sec225.hs ├── Sec226.hs ├── Sec4.hs └── Util ├── If.hs ├── MkChar.hs └── Singletons.hs /All.hs: -------------------------------------------------------------------------------- 1 | -- One module to rule them all. 2 | 3 | {-# OPTIONS_GHC -Wno-unused-imports #-} 4 | 5 | module All where 6 | 7 | import Sec211 8 | import Sec212 9 | import Sec213 10 | import Sec225 11 | import Sec226 12 | import Sec4 13 | -------------------------------------------------------------------------------- /Control/Catchable.hs: -------------------------------------------------------------------------------- 1 | -- based on implementation in Idris's standard library 2 | 3 | {-# LANGUAGE TypeInType, TypeOperators, MultiParamTypeClasses, 4 | AllowAmbiguousTypes, FlexibleInstances, TypeFamilies #-} 5 | 6 | module Control.Catchable where 7 | 8 | import Data.Singletons 9 | import Data.Kind 10 | import Data.AChar 11 | import Prelude hiding ( String, show ) 12 | import System.IO.Error 13 | 14 | class Catchable (m :: Type -> Type) t where 15 | throw :: (DemoteRep a ~ a, SingKind a) => t -> m a 16 | catch :: m a -> (t -> m a) -> m a 17 | 18 | instance Catchable Maybe () where 19 | catch Nothing h = h () 20 | catch (Just x) _ = Just x 21 | 22 | throw () = Nothing 23 | 24 | instance Catchable (Either a) a where 25 | catch (Left err) h = h err 26 | catch (Right x) _ = Right x 27 | 28 | throw x = Left x 29 | 30 | instance Catchable [] () where 31 | catch [] h = h () 32 | catch xs _ = xs 33 | 34 | throw () = [] 35 | 36 | instance Catchable IO String where 37 | throw s = ioError (userError (toString s)) 38 | catch io k = catchIOError io (\err -> k (show err)) 39 | -------------------------------------------------------------------------------- /Data/AChar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeInType, 2 | TypeFamilies, GADTs, FlexibleInstances, 3 | StandaloneDeriving #-} 4 | 5 | module Data.AChar where 6 | 7 | import Data.Singletons.TH 8 | import qualified Prelude as P 9 | 10 | $(singletons [d| 11 | data Char = CA 12 | | CB 13 | | CC 14 | | CD 15 | | CE 16 | | CF 17 | | CG 18 | | CH 19 | | CI 20 | | CJ 21 | | CK 22 | | CL 23 | | CM 24 | | CN 25 | | CO 26 | | CP 27 | | CQ 28 | | CR 29 | | CS 30 | | CT 31 | | CU 32 | | CV 33 | | CW 34 | | CX 35 | | CY 36 | | CZ 37 | | Ca 38 | | Cb 39 | | Cc 40 | | Cd 41 | | Ce 42 | | Cf 43 | | Cg 44 | | Ch 45 | | Ci 46 | | Cj 47 | | Ck 48 | | Cl 49 | | Cm 50 | | Cn 51 | | Co 52 | | Cp 53 | | Cq 54 | | Cr 55 | | Cs 56 | | Ct 57 | | Cu 58 | | Cv 59 | | Cw 60 | | Cx 61 | | Cy 62 | | Cz 63 | | C0 64 | | C1 65 | | C2 66 | | C3 67 | | C4 68 | | C5 69 | | C6 70 | | C7 71 | | C8 72 | | C9 73 | | C_ 74 | | Cspace 75 | | Cnewline 76 | | Ccolon 77 | | Cperiod 78 | | Ccomma 79 | | Cbang 80 | | Cquestion 81 | | Cbracko 82 | | Cbrackc |]) 83 | 84 | deriving instance P.Eq Char 85 | 86 | toChar :: Char -> P.Char 87 | toChar CA = 'A' 88 | toChar CB = 'B' 89 | toChar CC = 'C' 90 | toChar CD = 'D' 91 | toChar CE = 'E' 92 | toChar CF = 'F' 93 | toChar CG = 'G' 94 | toChar CH = 'H' 95 | toChar CI = 'I' 96 | toChar CJ = 'J' 97 | toChar CK = 'K' 98 | toChar CL = 'L' 99 | toChar CM = 'M' 100 | toChar CN = 'N' 101 | toChar CO = 'O' 102 | toChar CP = 'P' 103 | toChar CQ = 'Q' 104 | toChar CR = 'R' 105 | toChar CS = 'S' 106 | toChar CT = 'T' 107 | toChar CU = 'U' 108 | toChar CV = 'V' 109 | toChar CW = 'W' 110 | toChar CX = 'X' 111 | toChar CY = 'Y' 112 | toChar CZ = 'Z' 113 | toChar Ca = 'a' 114 | toChar Cb = 'b' 115 | toChar Cc = 'c' 116 | toChar Cd = 'd' 117 | toChar Ce = 'e' 118 | toChar Cf = 'f' 119 | toChar Cg = 'g' 120 | toChar Ch = 'h' 121 | toChar Ci = 'i' 122 | toChar Cj = 'j' 123 | toChar Ck = 'k' 124 | toChar Cl = 'l' 125 | toChar Cm = 'm' 126 | toChar Cn = 'n' 127 | toChar Co = 'o' 128 | toChar Cp = 'p' 129 | toChar Cq = 'q' 130 | toChar Cr = 'r' 131 | toChar Cs = 's' 132 | toChar Ct = 't' 133 | toChar Cu = 'u' 134 | toChar Cv = 'v' 135 | toChar Cw = 'w' 136 | toChar Cx = 'x' 137 | toChar Cy = 'y' 138 | toChar Cz = 'z' 139 | toChar C0 = '0' 140 | toChar C1 = '1' 141 | toChar C2 = '2' 142 | toChar C3 = '3' 143 | toChar C4 = '4' 144 | toChar C5 = '5' 145 | toChar C6 = '6' 146 | toChar C7 = '7' 147 | toChar C8 = '8' 148 | toChar C9 = '9' 149 | toChar C_ = '_' 150 | toChar Cspace = ' ' 151 | toChar Cnewline = '\n' 152 | toChar Ccolon = ':' 153 | toChar Cperiod = '.' 154 | toChar Ccomma = ',' 155 | toChar Cbang = '!' 156 | toChar Cquestion = '?' 157 | toChar Cbracko = '[' 158 | toChar Cbrackc = ']' 159 | 160 | fromChar :: P.Char -> Char 161 | fromChar 'A' = CA 162 | fromChar 'B' = CB 163 | fromChar 'C' = CC 164 | fromChar 'D' = CD 165 | fromChar 'E' = CE 166 | fromChar 'F' = CF 167 | fromChar 'G' = CG 168 | fromChar 'H' = CH 169 | fromChar 'I' = CI 170 | fromChar 'J' = CJ 171 | fromChar 'K' = CK 172 | fromChar 'L' = CL 173 | fromChar 'M' = CM 174 | fromChar 'N' = CN 175 | fromChar 'O' = CO 176 | fromChar 'P' = CP 177 | fromChar 'Q' = CQ 178 | fromChar 'R' = CR 179 | fromChar 'S' = CS 180 | fromChar 'T' = CT 181 | fromChar 'U' = CU 182 | fromChar 'V' = CV 183 | fromChar 'W' = CW 184 | fromChar 'X' = CX 185 | fromChar 'Y' = CY 186 | fromChar 'Z' = CZ 187 | fromChar 'a' = Ca 188 | fromChar 'b' = Cb 189 | fromChar 'c' = Cc 190 | fromChar 'd' = Cd 191 | fromChar 'e' = Ce 192 | fromChar 'f' = Cf 193 | fromChar 'g' = Cg 194 | fromChar 'h' = Ch 195 | fromChar 'i' = Ci 196 | fromChar 'j' = Cj 197 | fromChar 'k' = Ck 198 | fromChar 'l' = Cl 199 | fromChar 'm' = Cm 200 | fromChar 'n' = Cn 201 | fromChar 'o' = Co 202 | fromChar 'p' = Cp 203 | fromChar 'q' = Cq 204 | fromChar 'r' = Cr 205 | fromChar 's' = Cs 206 | fromChar 't' = Ct 207 | fromChar 'u' = Cu 208 | fromChar 'v' = Cv 209 | fromChar 'w' = Cw 210 | fromChar 'x' = Cx 211 | fromChar 'y' = Cy 212 | fromChar 'z' = Cz 213 | fromChar '0' = C0 214 | fromChar '1' = C1 215 | fromChar '2' = C2 216 | fromChar '3' = C3 217 | fromChar '4' = C4 218 | fromChar '5' = C5 219 | fromChar '6' = C6 220 | fromChar '7' = C7 221 | fromChar '8' = C8 222 | fromChar '9' = C9 223 | fromChar '_' = C_ 224 | fromChar ' ' = Cspace 225 | fromChar '\n' = Cnewline 226 | fromChar ':' = Ccolon 227 | fromChar '.' = Cperiod 228 | fromChar ',' = Ccomma 229 | fromChar '!' = Cbang 230 | fromChar '?' = Cquestion 231 | fromChar '[' = Cbracko 232 | fromChar ']' = Cbrackc 233 | fromChar c = P.error ("character not supported: " P.++ [c]) 234 | 235 | type String = [Char] 236 | 237 | fromString :: P.String -> String 238 | fromString = P.map fromChar 239 | 240 | toString :: String -> P.String 241 | toString = P.map toChar 242 | 243 | show :: P.Show a => a -> String 244 | show = fromString P.. P.show 245 | 246 | read :: P.Read a => String -> a 247 | read = P.read P.. toString 248 | 249 | instance P.Show Char where 250 | show x = [toChar x] 251 | showList xs = P.showString (toString xs) 252 | -------------------------------------------------------------------------------- /Data/Nat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, TypeInType, TypeFamilies, ScopedTypeVariables, 2 | GADTs, UndecidableInstances, InstanceSigs, TypeOperators #-} 3 | {-# OPTIONS_GHC -Wno-redundant-constraints -Wno-unticked-promoted-constructors #-} 4 | 5 | module Data.Nat where 6 | 7 | import qualified Prelude as P 8 | import Prelude ( (.), ($) ) 9 | import Data.Singletons.TH 10 | import Data.Singletons.Prelude 11 | import qualified GHC.TypeLits as TL 12 | import Control.Arrow ( first, second ) 13 | import qualified System.Random as R 14 | 15 | $(singletons [d| data Nat = Z | S Nat deriving (P.Eq, P.Ord) |]) 16 | 17 | fromInteger :: P.Integer -> Nat 18 | fromInteger 0 = Z 19 | fromInteger n = S (fromInteger (n P.- 1)) 20 | 21 | (+) :: Nat -> Nat -> Nat 22 | Z + m = m 23 | S n + m = S (n + m) 24 | 25 | (-) :: Nat -> Nat -> Nat 26 | n - Z = n 27 | Z - _ = P.error "negative nat" 28 | S n - S m = n - m 29 | 30 | (*) :: Nat -> Nat -> Nat 31 | Z * _ = Z 32 | S n * m = m + (n * m) 33 | 34 | mod :: Nat -> Nat -> Nat 35 | n `mod` m 36 | | n P.< m = n 37 | | P.otherwise = (n - m) `mod` m 38 | 39 | toInteger :: Nat -> P.Integer 40 | toInteger Z = 0 41 | toInteger (S n) = 1 P.+ toInteger n 42 | 43 | instance P.Show Nat where 44 | show = P.show . toInteger 45 | 46 | instance P.Read Nat where 47 | readsPrec p = P.map (first fromInteger) . P.readsPrec p 48 | 49 | instance P.Enum Nat where 50 | toEnum = fromInteger . P.fromIntegral 51 | fromEnum = P.fromInteger . toInteger 52 | 53 | type family U n where 54 | U 0 = Z 55 | U n = S (U (n TL.- 1)) 56 | 57 | instance P.Num Nat where 58 | -- These are not as silly as they look, due to scoping rules around 59 | -- method definitions for a qualified-imported class. Oh, Haskell. 60 | (+) = (+) 61 | (-) = (-) 62 | (*) = (*) 63 | abs n = n 64 | signum n = n 65 | fromInteger = fromInteger 66 | 67 | instance P.Real Nat where 68 | toRational = P.toRational . toInteger 69 | 70 | instance P.Integral Nat where 71 | a `quotRem` b = first fromInteger $ second fromInteger $ 72 | toInteger a `P.quotRem` toInteger b 73 | toInteger = toInteger 74 | 75 | instance R.Random Nat where 76 | randomR (a, b) = first fromInteger . R.randomR (toInteger a, toInteger b) 77 | random = first fromInteger . R.random 78 | -------------------------------------------------------------------------------- /Effect/Exception.hs: -------------------------------------------------------------------------------- 1 | -- Adapted from Brady's ICFP '13 paper. 2 | 3 | {-# LANGUAGE TypeInType, GADTs, FlexibleInstances, MultiParamTypeClasses, 4 | TypeFamilies, ScopedTypeVariables, AllowAmbiguousTypes, 5 | TypeApplications, FlexibleContexts, UndecidableInstances #-} 6 | {-# OPTIONS_GHC -Wno-unticked-promoted-constructors 7 | -Wno-orphans #-} 8 | module Effect.Exception where 9 | 10 | import Effects 11 | import Data.Kind 12 | import Data.Singletons 13 | import Control.Catchable 14 | 15 | data Exception :: Type -> Effect where 16 | Raise :: a -> Exception a () () b 17 | 18 | data instance Sing (e :: Exception a b c d) where 19 | SRaise :: Sing x -> Sing (Raise x) 20 | 21 | instance (Good a, Good b, Good c, Good d) => SingKind (Exception a b c d) where 22 | type DemoteRep (Exception a b c d) = Exception a b c d 23 | 24 | fromSing (SRaise x) = Raise (fromSing x) 25 | 26 | toSing (Raise x) = case toSing x of SomeSing x' -> SomeSing (SRaise x') 27 | 28 | instance Handler (Exception a) Maybe where 29 | handle (Raise _) _ _ = Nothing 30 | 31 | instance Show a => Handler (Exception a) IO where 32 | handle (Raise e) _ _ = ioError (userError (show e)) 33 | 34 | instance Handler (Exception a) (Either a) where 35 | handle (Raise e) _ _ = Left e 36 | 37 | type EXCEPTION t = MkEff () (Exception t) 38 | 39 | raise_ :: (Good a, Good b) => a -> Eff m '[EXCEPTION a] b 40 | raise_ x = case toSing x of SomeSing x' -> Effect SHere (SRaise x') 41 | 42 | raise :: forall a xs prf b m. 43 | (SingI (prf :: SubList '[EXCEPTION a] xs), Good a, Good b) 44 | => a -> EffM m xs (UpdateWith '[EXCEPTION a] xs prf) b 45 | raise x = lift @_ @_ @prf (raise_ x) 46 | 47 | instance ( Good s 48 | , Catchable m s 49 | , SFindableSubList '[EXCEPTION s] xs 50 | , xs' ~ UpdateWith '[EXCEPTION s] xs (SubListProof :: SubList '[EXCEPTION s] xs)) 51 | => Catchable (EffM m xs xs') s where 52 | throw t = raise t 53 | catch e k = Catch e k 54 | -------------------------------------------------------------------------------- /Effect/File.hs: -------------------------------------------------------------------------------- 1 | -- Based on Idris's algebraic effects library 2 | 3 | {-# LANGUAGE TypeInType, GADTs, FlexibleInstances, MultiParamTypeClasses, 4 | TemplateHaskell, ScopedTypeVariables, TypeFamilies, 5 | FlexibleContexts, TypeApplications, AllowAmbiguousTypes #-} 6 | {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} 7 | 8 | module Effect.File where 9 | 10 | import Effects 11 | import System.IO 12 | import System.IO.Error 13 | import Data.Kind 14 | import Data.Singletons.Prelude 15 | import Data.Singletons.TH 16 | import Data.AChar 17 | import Prelude ( Either(..), Bool(..), IO ) 18 | 19 | $(singletons [d| data Mode = Read | Write |]) 20 | 21 | toIOMode :: Mode -> IOMode 22 | toIOMode Read = ReadMode 23 | toIOMode Write = WriteMode 24 | 25 | data OpenFile :: Mode -> Type where 26 | FH :: Handle -> OpenFile m 27 | 28 | data FileIO :: Type -> Type -> Type -> Type where 29 | OpenRead :: String -> FileIO () (Either () (OpenFile Read)) Bool 30 | OpenWrite :: String -> FileIO () (Either () (OpenFile Write)) Bool 31 | Close :: FileIO (OpenFile m) () () 32 | ReadLine :: FileIO (OpenFile Read) (OpenFile Read) String 33 | WriteLine :: String -> FileIO (OpenFile Write) (OpenFile Write) () 34 | EOF :: FileIO (OpenFile Read) (OpenFile Read) Bool 35 | 36 | data instance Sing (x :: FileIO a b c) where 37 | SOpenRead :: Sing s -> Sing (OpenRead s) 38 | SOpenWrite :: Sing s -> Sing (OpenWrite s) 39 | SClose :: Sing Close 40 | SReadLine :: Sing ReadLine 41 | SWriteLine :: Sing s -> Sing (WriteLine s) 42 | SEOF :: Sing EOF 43 | 44 | instance SingKind (FileIO a b c) where 45 | type DemoteRep (FileIO a b c) = FileIO a b c 46 | 47 | fromSing (SOpenRead s) = OpenRead (fromSing s) 48 | fromSing (SOpenWrite s) = OpenWrite (fromSing s) 49 | fromSing SClose = Close 50 | fromSing SReadLine = ReadLine 51 | fromSing (SWriteLine s) = WriteLine (fromSing s) 52 | fromSing SEOF = EOF 53 | 54 | toSing (OpenRead s) = case toSing s of SomeSing s' -> SomeSing (SOpenRead s') 55 | toSing (OpenWrite s) = case toSing s of SomeSing s' -> SomeSing (SOpenWrite s') 56 | toSing Close = SomeSing SClose 57 | toSing ReadLine = SomeSing SReadLine 58 | toSing (WriteLine s) = case toSing s of SomeSing s' -> SomeSing (SWriteLine s') 59 | toSing EOF = SomeSing SEOF 60 | 61 | handleOpen :: FilePath -> Sing (m :: Mode) 62 | -> (Either () (OpenFile m) -> Bool -> IO r) 63 | -> IO r 64 | handleOpen fname mode k = do e_h <- tryIOError (openFile fname (toIOMode (fromSing mode))) 65 | case e_h of 66 | Left _err -> k (Left ()) False 67 | Right h -> k (Right (FH h)) True 68 | 69 | instance Handler FileIO IO where 70 | handle (OpenRead s) () k = handleOpen (toString s) SRead k 71 | handle (OpenWrite s) () k = handleOpen (toString s) SWrite k 72 | 73 | handle Close (FH h) k = do hClose h 74 | k () () 75 | handle ReadLine (FH h) k = do str <- hGetLine h 76 | k (FH h) (fromString str) 77 | handle (WriteLine str) (FH h) k = do hPutStrLn h (toString str) 78 | k (FH h) () 79 | handle EOF (FH h) k = do b <- hIsEOF h 80 | k (FH h) b 81 | 82 | type FILE_IO t = MkEff t FileIO 83 | 84 | open_ :: String -> Sing (m :: Mode) 85 | -> EffM e '[FILE_IO ()] '[FILE_IO (Either () (OpenFile m))] Bool 86 | open_ f SRead = case toSing f of SomeSing f' -> Effect SHere (SOpenRead f') 87 | open_ f SWrite = case toSing f of SomeSing f' -> Effect SHere (SOpenWrite f') 88 | 89 | open :: forall xs prf m e. 90 | (SingI (prf :: SubList '[FILE_IO ()] xs)) 91 | => String -> Sing (m :: Mode) 92 | -> EffM e xs (UpdateWith '[FILE_IO (Either () (OpenFile m))] xs prf) Bool 93 | open s m = lift @_ @_ @prf (open_ s m) 94 | 95 | close_ :: EffM e '[FILE_IO (OpenFile m)] '[FILE_IO ()] () 96 | close_ = Effect SHere SClose 97 | 98 | close :: forall m xs prf e. 99 | SingI (prf :: SubList '[FILE_IO (OpenFile m)] xs) 100 | => EffM e xs (UpdateWith '[FILE_IO ()] xs prf) () 101 | close = lift @_ @_ @prf close_ 102 | 103 | readLine_ :: Eff e '[FILE_IO (OpenFile Read)] String 104 | readLine_ = Effect SHere SReadLine 105 | 106 | readLine :: forall xs prf e. 107 | SingI (prf :: SubList '[FILE_IO (OpenFile Read)] xs) 108 | => EffM e xs (UpdateWith '[FILE_IO (OpenFile Read)] xs prf) String 109 | readLine = lift @_ @_ @prf readLine_ 110 | 111 | writeLine_ :: String -> Eff e '[FILE_IO (OpenFile Write)] () 112 | writeLine_ s = case toSing s of SomeSing s' -> Effect SHere (SWriteLine s') 113 | 114 | writeLine :: forall xs prf e. 115 | SingI (prf :: SubList '[FILE_IO (OpenFile Write)] xs) 116 | => String 117 | -> EffM e xs (UpdateWith '[FILE_IO (OpenFile Write)] xs prf) () 118 | writeLine s = lift @_ @_ @prf (writeLine_ s) 119 | 120 | eof_ :: Eff e '[FILE_IO (OpenFile Read)] Bool 121 | eof_ = Effect SHere SEOF 122 | 123 | eof :: forall xs prf e. 124 | SingI (prf :: SubList '[FILE_IO (OpenFile Read)] xs) 125 | => EffM e xs (UpdateWith '[FILE_IO (OpenFile Read)] xs prf) Bool 126 | eof = lift @_ @_ @prf eof_ 127 | -------------------------------------------------------------------------------- /Effect/Random.hs: -------------------------------------------------------------------------------- 1 | -- Adapted from Idris's algebraic effects library 2 | 3 | {-# LANGUAGE TypeInType, RebindableSyntax, GADTs, FlexibleInstances, 4 | MultiParamTypeClasses, TypeFamilies, ScopedTypeVariables, 5 | TypeApplications, AllowAmbiguousTypes #-} 6 | {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} 7 | 8 | module Effect.Random where 9 | 10 | import qualified Prelude as P 11 | import Data.Nat 12 | import Effects 13 | import Data.Singletons 14 | import qualified System.Random as R 15 | 16 | data Random :: Effect where 17 | GetRandom :: Random Nat Nat Nat 18 | SetSeed :: Nat -> Random Nat Nat () 19 | 20 | data instance Sing (x :: Random a b c) where 21 | SGetRandom :: Sing GetRandom 22 | SSetSeed :: Sing n -> Sing (SetSeed n) 23 | 24 | instance (Good a, Good b, Good c) => SingKind (Random a b c) where 25 | type DemoteRep (Random a b c) = Random a b c 26 | 27 | fromSing SGetRandom = GetRandom 28 | fromSing (SSetSeed x) = SetSeed (fromSing x) 29 | 30 | toSing GetRandom = SomeSing SGetRandom 31 | toSing (SetSeed x) = case toSing x of SomeSing x' -> SomeSing (SSetSeed x') 32 | 33 | -- top-level definition so that it is computed only once 34 | modulus :: P.Int 35 | modulus = P.fromIntegral 1007 36 | 37 | instance Handler Random m where 38 | handle GetRandom seed k 39 | = let gen = R.mkStdGen (P.fromIntegral seed) 40 | (n, _) = R.random @P.Int gen 41 | seed' = fromInteger (P.fromIntegral (n `P.mod` modulus)) in 42 | k seed' seed' 43 | handle (SetSeed n) _ k = k n () 44 | 45 | type RND = MkEff Nat Random 46 | 47 | rndNat_ :: Nat -> Nat -> Eff m '[RND] Nat 48 | rndNat_ lower upper = do v <- Effect SHere SGetRandom 49 | return (v `mod` (upper - lower) + lower) 50 | 51 | rndNat :: forall xs prf m. 52 | SingI (prf :: SubList '[RND] xs) 53 | => Nat -> Nat -> EffM m xs (UpdateWith '[RND] xs prf) Nat 54 | rndNat lower upper = lift @_ @_ @prf (rndNat_ lower upper) 55 | 56 | srand_ :: Nat -> Eff m '[RND] () 57 | srand_ n = case toSing n of SomeSing n' -> Effect SHere (SSetSeed n') 58 | 59 | srand :: forall xs prf m. 60 | SingI (prf :: SubList '[RND] xs) 61 | => Nat -> EffM m xs (UpdateWith '[RND] xs prf) () 62 | srand n = lift @_ @_ @prf (srand_ n) 63 | -------------------------------------------------------------------------------- /Effect/Select.hs: -------------------------------------------------------------------------------- 1 | -- adapted from Idris's algebraic effects library 2 | 3 | {-# LANGUAGE TypeInType, GADTs, TypeFamilies, FlexibleInstances, 4 | MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, 5 | AllowAmbiguousTypes #-} 6 | {-# OPTIONS_GHC -Wno-unticked-promoted-constructors 7 | -Wno-name-shadowing #-} 8 | 9 | module Effect.Select where 10 | 11 | import Effects 12 | import Data.Singletons 13 | 14 | data Selection :: Effect where 15 | Select :: [a] -> Selection () () a 16 | 17 | data instance Sing (x :: Selection a b c) where 18 | SSelect :: Sing xs -> Sing (Select xs) 19 | 20 | instance (Good a, Good b, Good c) => SingKind (Selection a b c) where 21 | type DemoteRep (Selection a b c) = Selection a b c 22 | 23 | fromSing (SSelect xs) = Select (fromSing xs) 24 | 25 | toSing (Select xs) = case toSing xs of SomeSing xs' -> SomeSing (SSelect xs') 26 | 27 | instance Handler Selection Maybe where 28 | handle (Select xs) _ k = tryAll xs where 29 | tryAll [] = Nothing 30 | tryAll (x : xs) = case k () x of 31 | Nothing -> tryAll xs 32 | Just v -> Just v 33 | 34 | instance Handler Selection [] where 35 | handle (Select xs) r k = concatMap (k r) xs 36 | 37 | type SELECT = MkEff () Selection 38 | 39 | select_ :: Good a => [a] -> Eff m '[SELECT] a 40 | select_ xs = case toSing xs of SomeSing xs' -> Effect SHere (SSelect xs') 41 | 42 | select :: forall xs prf a m. 43 | (SingI (prf :: SubList '[SELECT] xs), Good a) 44 | => [a] -> EffM m xs (UpdateWith '[SELECT] xs prf) a 45 | select xs = lift @_ @_ @prf (select_ xs) 46 | -------------------------------------------------------------------------------- /Effect/State.hs: -------------------------------------------------------------------------------- 1 | -- adapted from Idris's algebraic effects library 2 | 3 | {-# LANGUAGE TypeInType, TypeOperators, GADTs, FlexibleInstances, 4 | MultiParamTypeClasses, TypeFamilies, ScopedTypeVariables, 5 | InstanceSigs, TypeApplications, RebindableSyntax, 6 | AllowAmbiguousTypes, FlexibleContexts #-} 7 | {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} 8 | 9 | module Effect.State where 10 | 11 | import Effects 12 | import Data.Singletons 13 | 14 | data State :: Effect where 15 | Get :: State a a a 16 | Put :: b -> State a b () 17 | 18 | data instance Sing (e :: State a b c) where 19 | SGet :: Sing Get 20 | SPut :: Sing x -> Sing (Put x) 21 | 22 | instance (Good a, Good b, Good c) => SingKind (State a b c) where 23 | type DemoteRep (State a b c) = State a b c 24 | 25 | fromSing SGet = Get 26 | fromSing (SPut x) = Put (fromSing x) 27 | 28 | toSing Get = SomeSing SGet 29 | toSing (Put x) = case toSing x of SomeSing x' -> SomeSing (SPut x') 30 | 31 | instance Handler State m where 32 | handle Get st k = k st st 33 | handle (Put n) _ k = k n () 34 | 35 | type STATE t = MkEff t State 36 | 37 | get_ :: forall m x. Good x => Eff m '[STATE x] x 38 | get_ = Effect SHere SGet 39 | 40 | get :: forall x xs prf m. 41 | (SingI (prf :: SubList '[STATE x] xs), Good x) 42 | => EffM m xs (UpdateWith '[STATE x] xs prf) x 43 | get = lift @_ @_ @prf get_ 44 | 45 | put_ :: forall x m. Good x => x -> Eff m '[STATE x] () 46 | put_ v = case toSing v of 47 | SomeSing v' -> Effect SHere (SPut v') 48 | 49 | put :: forall x xs prf m. 50 | (SingI (prf :: SubList '[STATE x] xs), Good x) 51 | => x -> EffM m xs (UpdateWith '[STATE x] xs prf) () 52 | put v = lift @_ @_ @prf (put_ v) 53 | 54 | putM_ :: forall x y m. (Good x, Good y) => y -> EffM m '[STATE x] '[STATE y] () 55 | putM_ val = case toSing val of 56 | SomeSing val' -> Effect SHere (SPut val') 57 | 58 | putM :: forall x xs prf y m. 59 | (SingI (prf :: SubList '[STATE x] xs), Good x, Good y) 60 | => y -> EffM m xs (UpdateWith '[STATE y] xs prf) () 61 | putM y = lift @_ @_ @prf (putM_ y) 62 | 63 | update_ :: Good x => (x -> x) -> Eff m '[STATE x] () 64 | update_ f = do x <- get 65 | put_ (f x) 66 | 67 | update :: forall x xs prf m. 68 | (SingI (prf :: SubList '[STATE x] xs), Good x) 69 | => (x -> x) -> EffM m xs (UpdateWith '[STATE x] xs prf) () 70 | update f = lift @_ @_ @prf (update_ f) 71 | 72 | updateM_ :: (Good x, Good y) => (x -> y) -> EffM m '[STATE x] '[STATE y] () 73 | updateM_ f = do x <- get 74 | putM_ (f x) 75 | 76 | updateM :: forall x xs prf y m. 77 | (SingI (prf :: SubList '[STATE x] xs), Good x, Good y) 78 | => (x -> y) -> EffM m xs (UpdateWith '[STATE y] xs prf) () 79 | updateM f = lift @_ @_ @prf (updateM_ f) 80 | 81 | locally_ :: (Good x, Good y) => x -> Eff m '[STATE x] t -> Eff m '[STATE y] t 82 | locally_ newst prog = do st <- get_ 83 | putM_ newst 84 | val <- prog 85 | putM_ st 86 | return val 87 | 88 | locally :: forall y xs prf x m t. 89 | (SingI (prf :: SubList '[STATE y] xs), Good x, Good y) 90 | => x -> Eff m '[STATE x] t -> EffM m xs (UpdateWith '[STATE y] xs prf) t 91 | locally newst prog = lift @_ @_ @prf (locally_ newst prog) 92 | -------------------------------------------------------------------------------- /Effect/StdIO.hs: -------------------------------------------------------------------------------- 1 | -- Adapted from Brady's implementation in Idris 2 | 3 | {-# LANGUAGE TypeInType, RebindableSyntax, GADTs, TypeFamilies, 4 | FlexibleInstances, MultiParamTypeClasses, 5 | LambdaCase, OverloadedStrings, ScopedTypeVariables, 6 | InstanceSigs, FlexibleContexts, TypeApplications, 7 | AllowAmbiguousTypes #-} 8 | {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} 9 | 10 | module Effect.StdIO where 11 | 12 | import Data.AChar 13 | import qualified Prelude as P 14 | import Data.Singletons 15 | import Effects 16 | 17 | data StdIO :: Effect where 18 | PutStr :: String -> StdIO () () () 19 | GetStr :: StdIO () () String 20 | 21 | data instance Sing (x :: StdIO a b c) where 22 | SPutStr :: Sing s -> Sing (PutStr s) 23 | SGetStr :: Sing GetStr 24 | 25 | instance (Good a, Good b, Good c) => SingKind (StdIO a b c) where 26 | type DemoteRep (StdIO a b c) = StdIO a b c 27 | 28 | fromSing (SPutStr s) = PutStr (fromSing s) 29 | fromSing SGetStr = GetStr 30 | 31 | toSing (PutStr s) = case toSing s of SomeSing s' -> SomeSing (SPutStr s') 32 | toSing GetStr = SomeSing SGetStr 33 | 34 | instance Handler StdIO P.IO where 35 | handle (PutStr s) () k = P.putStr (toString s) P.>> 36 | k () () 37 | handle GetStr () k = P.getLine P.>>= \ s -> 38 | k () (fromString s) 39 | 40 | data IOStream a = MkStream ([String] -> (a, [String])) 41 | 42 | instance Handler StdIO IOStream where 43 | handle (PutStr s) () k 44 | = MkStream (\x -> case k () () of 45 | MkStream f -> let (res, str) = f x in 46 | (res, s : str)) 47 | handle GetStr () k 48 | = MkStream (\case [] -> cont "" [] 49 | t : ts -> cont t ts) 50 | where 51 | cont t ts = case k () t of 52 | MkStream f -> f ts 53 | 54 | type STDIO = MkEff () StdIO 55 | 56 | putStr_ :: String -> Eff e '[STDIO] () 57 | putStr_ s = case toSing s of SomeSing s' -> Effect SHere (SPutStr s') 58 | 59 | putStr :: forall xs prf e. 60 | SingI (prf :: SubList '[STDIO] xs) 61 | => String -> EffM e xs (UpdateWith '[STDIO] xs prf) () 62 | putStr s = lift @_ @_ @prf (putStr_ s) 63 | 64 | putStrLn_ :: String -> Eff e '[STDIO] () 65 | putStrLn_ s = case toSing (s P.++ [Cnewline]) of 66 | SomeSing s' -> Effect SHere (SPutStr s') 67 | 68 | putStrLn :: forall xs prf e. 69 | SingI (prf :: SubList '[STDIO] xs) 70 | => String -> EffM e xs (UpdateWith '[STDIO] xs prf) () 71 | putStrLn s = lift @_ @_ @prf (putStrLn_ s) 72 | 73 | getStr_ :: Eff e '[STDIO] String 74 | getStr_ = Effect SHere SGetStr 75 | 76 | getStr :: forall xs prf e. 77 | SingI (prf :: SubList '[STDIO] xs) 78 | => EffM e xs (UpdateWith '[STDIO] xs prf) String 79 | getStr = lift @_ @_ @prf getStr_ 80 | 81 | mkStrFn :: forall a xs. 82 | Env IOStream xs 83 | -> Eff IOStream xs a 84 | -> [String] -> (a, [String]) 85 | mkStrFn env p input = case mkStrFn' of MkStream f -> f input 86 | where 87 | injStream :: a -> IOStream a 88 | injStream v = MkStream (\_ -> (v, [])) 89 | 90 | mkStrFn' :: IOStream a 91 | mkStrFn' = runWith injStream env p 92 | -------------------------------------------------------------------------------- /Effects.hs: -------------------------------------------------------------------------------- 1 | -- Based on https://github.com/idris-lang/Idris-dev/blob/v0.9.10/libs/effects/Effects.idr 2 | 3 | {-# LANGUAGE TypeOperators, TypeInType, GADTs, MultiParamTypeClasses, 4 | AllowAmbiguousTypes, TypeFamilies, ScopedTypeVariables, 5 | RebindableSyntax, ConstraintKinds, 6 | FlexibleContexts, LambdaCase, EmptyCase, FlexibleInstances #-} 7 | {-# OPTIONS_GHC -Wno-unticked-promoted-constructors 8 | -Wno-name-shadowing #-} 9 | 10 | module Effects where 11 | 12 | import Data.Kind 13 | import Data.Singletons.Prelude 14 | import qualified Prelude as P 15 | import Prelude ( Either(..), error, 16 | Applicative(..), Functor(..), (<$>), Bool(..), ($) 17 | ) 18 | import Control.Catchable 19 | import Data.Functor.Identity 20 | 21 | type Good x = (DemoteRep x ~ x, SingKind x) 22 | 23 | type Effect = Type -> Type -> Type -> Type 24 | 25 | data EFFECT :: Type where 26 | MkEff :: Type -> Effect -> EFFECT 27 | 28 | data instance Sing (x :: EFFECT) where 29 | SMkEff :: Sing t -> Sing e -> Sing (MkEff t e) 30 | 31 | class Handler (e :: Effect) (m :: Type -> Type) where 32 | handle :: forall a res res' t. 33 | e res res' t -> res -> (res' -> t -> m a) -> m a 34 | 35 | data SubList :: [a] -> [a] -> Type where 36 | SubNil :: SubList '[] '[] 37 | Keep :: SubList xs ys -> SubList (x ': xs) (x ': ys) 38 | Drop :: SubList xs ys -> SubList xs (x ': ys) 39 | 40 | data instance Sing (x :: SubList ys xs) where 41 | SSubNil :: Sing SubNil 42 | SKeep :: Sing x -> Sing (Keep x) 43 | SDrop :: Sing x -> Sing (Drop x) 44 | 45 | type SSubList = (Sing :: SubList (ys :: [a]) (xs :: [a]) -> Type) 46 | 47 | instance SingKind (SubList ys xs) where 48 | type DemoteRep (SubList ys xs) = SubList ys xs 49 | 50 | fromSing SSubNil = SubNil 51 | fromSing (SKeep p) = Keep (fromSing p) 52 | fromSing (SDrop p) = Drop (fromSing p) 53 | 54 | toSing SubNil = SomeSing SSubNil 55 | toSing (Keep p) = case toSing p of SomeSing p' -> SomeSing (SKeep p') 56 | toSing (Drop p) = case toSing p of SomeSing p' -> SomeSing (SDrop p') 57 | 58 | class FindableSubList xs ys where 59 | subListProof :: SubList xs ys 60 | 61 | instance FindableSubList '[] '[] where 62 | subListProof = SubNil 63 | instance FindableSubList xs ys => FindableSubList (x ': xs) (x ': ys) where 64 | subListProof = Keep subListProof 65 | instance FindableSubList xs ys => FindableSubList xs (x ': ys) where 66 | subListProof = Drop subListProof 67 | 68 | type family SubListProof :: SubList (xs :: [a]) (ys :: [a]) where 69 | SubListProof = SubNil 70 | SubListProof = Keep SubListProof 71 | SubListProof = Drop SubListProof 72 | 73 | class SFindableSubList xs ys where 74 | sSubListProof :: Sing (SubListProof :: SubList xs ys) 75 | 76 | instance SFindableSubList '[] '[] where 77 | sSubListProof = SSubNil 78 | instance {-# OVERLAPPING #-} 79 | SFindableSubList xs ys => SFindableSubList (x ': xs) (x ': ys) where 80 | sSubListProof = SKeep sSubListProof 81 | instance ( (SubListProof :: SubList xs (x ': ys)) ~ Drop SubListProof 82 | , SFindableSubList xs ys ) 83 | => SFindableSubList xs (x ': ys) where 84 | sSubListProof = SDrop sSubListProof 85 | 86 | instance (SFindableSubList xs ys, prf ~ SubListProof) 87 | => SingI (prf :: SubList xs ys) where 88 | sing = sSubListProof 89 | 90 | subListId :: Sing xs -> SubList xs xs 91 | subListId SNil = SubNil 92 | subListId (_ `SCons` xs) = Keep (subListId xs) 93 | 94 | data Env :: (Type -> Type) -> [EFFECT] -> Type where 95 | Empty :: Env m '[] 96 | (:>) :: Handler eff m => a -> Env m xs -> Env m (MkEff a eff ': xs) 97 | infixr 4 :> 98 | 99 | data EffElem :: Effect -> Type -> [EFFECT] -> Type where 100 | Here :: EffElem x a (MkEff a x ': xs) 101 | There :: EffElem x a xs -> EffElem x a (y ': xs) 102 | 103 | data instance Sing (elem :: EffElem x a xs) where 104 | SHere :: Sing Here 105 | SThere :: Sing z -> Sing (There z) 106 | 107 | instance SingKind (EffElem x a xs) where 108 | type DemoteRep (EffElem x a xs) = EffElem x a xs 109 | 110 | fromSing SHere = Here 111 | fromSing (SThere p) = There (fromSing p) 112 | 113 | toSing Here = SomeSing SHere 114 | toSing (There p) = case toSing p of 115 | SomeSing p' -> SomeSing (SThere p') 116 | 117 | class FindableElem x a xs where 118 | elemProof :: EffElem x a xs 119 | 120 | instance FindableElem x a (MkEff a x ': xs) where 121 | elemProof = Here 122 | instance FindableElem x a xs => FindableElem x a (y ': xs) where 123 | elemProof = There elemProof 124 | 125 | type family ElemProof :: EffElem x a xs where 126 | ElemProof = Here 127 | ElemProof = There ElemProof 128 | 129 | class SFindableElem x a xs where 130 | sElemProof :: Sing (ElemProof :: EffElem x a xs) 131 | 132 | instance SFindableElem x a (MkEff a x ': xs) where 133 | sElemProof = SHere 134 | instance {-# OVERLAPPABLE #-} ((ElemProof :: EffElem x a (y ': xs)) ~ There (ElemProof :: EffElem x a xs), SFindableElem x a xs) => SFindableElem x a (y ': xs) where 135 | sElemProof = SThere sElemProof 136 | 137 | instance (SFindableElem x a xs, prf ~ ElemProof) 138 | => SingI (prf :: EffElem x a xs) where 139 | sing = sElemProof 140 | 141 | nothingInEmpty :: EffElem x a '[] -> anything 142 | -- nothingInEmpty Here = undefined 143 | -- nothingInEmpty (There _) = undefined 144 | nothingInEmpty = \case {} 145 | 146 | dropEnv :: Env m ys -> SubList xs ys -> Env m xs 147 | dropEnv Empty SubNil = Empty 148 | dropEnv (v :> vs) (Keep rest) = v :> dropEnv vs rest 149 | dropEnv (_ :> vs) (Drop rest) = dropEnv vs rest 150 | 151 | updateWith :: Good a => [a] -> SList (xs :: [a]) -> SubList ys xs -> [a] 152 | updateWith (y : ys) (_ `SCons` xs) (Keep rest) = y : updateWith ys xs rest 153 | updateWith ys (x `SCons` xs) (Drop rest) = fromSing x : updateWith ys xs rest 154 | updateWith [] SNil SubNil = [] 155 | updateWith (y : ys) SNil SubNil = y : ys 156 | updateWith [] (_ `SCons` _) (Keep _) = [] 157 | 158 | type family UpdateWith (ys' :: [a]) (xs :: [a]) (pf :: SubList ys xs) :: [a] where 159 | UpdateWith (y ': ys) (_ ': xs) (Keep rest) = y ': UpdateWith ys xs rest 160 | UpdateWith ys (x ': xs) (Drop rest) = x ': UpdateWith ys xs rest 161 | UpdateWith '[] '[] SubNil = '[] 162 | UpdateWith (y ': ys) '[] SubNil = y ': ys 163 | UpdateWith '[] (_ ': _) (Keep _) = '[] 164 | 165 | rebuildEnv :: Env m ys' -> SSubList (prf :: SubList ys xs) -> Env m xs -> Env m (UpdateWith ys' xs prf) 166 | rebuildEnv Empty SSubNil env = env 167 | rebuildEnv (x :> xs) (SKeep rest) (_ :> env) = x :> rebuildEnv xs rest env 168 | rebuildEnv xs (SDrop rest) (y :> env) = y :> rebuildEnv xs rest env 169 | rebuildEnv (x :> xs) SSubNil Empty = x :> xs 170 | rebuildEnv Empty (SKeep _) _ = Empty 171 | 172 | type family UpdateResTy b t (xs :: [EFFECT]) (elem :: EffElem e a xs) 173 | (thing :: e a b t) :: [EFFECT] where 174 | UpdateResTy b _ (MkEff a e ': xs) Here n = MkEff b e ': xs 175 | UpdateResTy b t (x ': xs) (There p) n = x ': UpdateResTy b t xs p n 176 | 177 | type family UpdateResTyImm (xs :: [EFFECT]) (elem :: EffElem e a xs) 178 | (t :: Type) :: [EFFECT] where 179 | UpdateResTyImm (MkEff a e ': xs) Here b = MkEff b e ': xs 180 | UpdateResTyImm (x ': xs) (There p) b = x ': UpdateResTyImm xs p b 181 | 182 | infix 5 :::, := , :- 183 | 184 | data LRes :: forall lbl. lbl -> Type -> Type where 185 | (:=) :: Sing (x :: lbl) -> res -> LRes x res 186 | 187 | type family (x :: lbl) ::: (e :: EFFECT) :: EFFECT where 188 | x ::: MkEff r eff = MkEff (LRes x r) eff 189 | 190 | unlabel :: Env m '[l ::: MkEff a eff] -> Env m '[MkEff a eff] 191 | unlabel ((_ := v) :> Empty) = (v :> Empty) 192 | 193 | relabel :: Sing (l :: ty) -> Env m '[MkEff a eff] -> Env m '[l ::: MkEff a eff] 194 | relabel l (v :> Empty) = ((l := v) :> Empty) 195 | 196 | data EffM :: (Type -> Type) -> [EFFECT] -> [EFFECT] -> Type -> Type where 197 | Value :: a -> EffM m xs xs a 198 | Ebind :: EffM m xs xs' a -> (a -> EffM m xs' xs'' b) -> EffM m xs xs'' b 199 | Effect :: Good (e a b t) 200 | => Sing (prf :: EffElem e a xs) 201 | -> Sing (eff :: e a b t) 202 | -> EffM m xs (UpdateResTy b t xs prf eff) t 203 | Lift :: Sing (prf :: SubList ys xs) 204 | -> EffM m ys ys' t -> EffM m xs (UpdateWith ys' xs prf) t 205 | New :: Handler e m 206 | => res -> EffM m (MkEff res e ': xs) (MkEff res' e ': xs') a 207 | -> EffM m xs xs' a 208 | Test :: Sing (prf :: EffElem e (Either l r) xs) 209 | -> EffM m (UpdateResTyImm xs prf l) xs' t 210 | -> EffM m (UpdateResTyImm xs prf r) xs' t 211 | -> EffM m xs xs' t 212 | Test_lbl :: forall lbl (x :: lbl) e l r xs prf xs' t m. 213 | SingI x 214 | => Sing (prf :: EffElem e (LRes x (Either l r)) xs) 215 | -> EffM m (UpdateResTyImm xs prf (LRes x l)) xs' t 216 | -> EffM m (UpdateResTyImm xs prf (LRes x r)) xs' t 217 | -> EffM m xs xs' t 218 | Catch :: Catchable m err 219 | => EffM m xs xs' a 220 | -> (err -> EffM m xs xs' a) 221 | -> EffM m xs xs' a 222 | (:-) :: Sing (l :: ty) 223 | -> EffM m '[MkEff ex ax] '[MkEff ey ay] t 224 | -> EffM m '[l ::: MkEff ex ax] '[l ::: MkEff ey ay] t 225 | 226 | lift :: forall ys xs prf ys' m t. 227 | SingI (prf :: SubList ys xs) 228 | => EffM m ys ys' t -> EffM m xs (UpdateWith ys' xs prf) t 229 | lift e = Lift (sing :: Sing prf) e 230 | 231 | (|-) :: forall ty l ex ax xs prf m ey ay t. 232 | SingI (prf :: SubList '[l ::: MkEff ex ax] xs) 233 | => Sing (l :: ty) 234 | -> EffM m '[MkEff ex ax] '[MkEff ey ay] t 235 | -> EffM m xs (UpdateWith '[l ::: MkEff ey ay] xs prf) t 236 | l |- e = Lift (sing :: Sing prf) (l :- e) 237 | 238 | test :: forall e l r prf m xs' t. 239 | SingI (prf :: EffElem e (Either l r) xs) 240 | => EffM m (UpdateResTyImm xs prf l) xs' t 241 | -> EffM m (UpdateResTyImm xs prf r) xs' t 242 | -> EffM m xs xs' t 243 | test = Test (sing :: Sing prf) 244 | 245 | return :: a -> EffM m xs xs a 246 | return x = Value x 247 | 248 | (>>) :: EffM m xs xs' a -> EffM m xs' xs'' b -> EffM m xs xs'' b 249 | a >> b = a >>= \_ -> b 250 | 251 | (>>=) :: EffM m xs xs' a -> (a -> EffM m xs' xs'' b) -> EffM m xs xs'' b 252 | (>>=) = Ebind 253 | 254 | fail :: P.String -> EffM m xs ys a 255 | fail = error 256 | 257 | instance Functor (EffM m xs xs) where 258 | fn `fmap` v = do arg <- v 259 | return (fn arg) 260 | 261 | instance Applicative (EffM m xs xs) where 262 | pure = Value 263 | prog <*> v = do fn <- prog 264 | arg <- v 265 | return (fn arg) 266 | 267 | execEff :: Good (e res b a) 268 | => Env m xs 269 | -> Sing (p :: EffElem e res xs) 270 | -> Sing (eff :: e res b a) 271 | -> (Env m (UpdateResTy b a xs p eff) -> a -> m t) 272 | -> m t 273 | execEff (val :> env) SHere eff' k 274 | = handle (fromSing eff') val (\ res v -> k (res :> env) v) 275 | execEff (val :> env) (SThere p) eff k 276 | = execEff env p eff (\ env' v -> k (val :> env') v) 277 | execEff Empty p _ _ = nothingInEmpty (fromSing p) 278 | 279 | testEff :: Sing (p :: EffElem e (Either l r) xs) 280 | -> Env m xs 281 | -> (Env m (UpdateResTyImm xs p l) -> m b) 282 | -> (Env m (UpdateResTyImm xs p r) -> m b) 283 | -> m b 284 | testEff SHere (Left err :> env) lk _rk = lk (err :> env) 285 | testEff SHere (Right ok :> env) _lk rk = rk (ok :> env) 286 | testEff (SThere p) (val :> env) lk rk 287 | = testEff p env (\envk -> lk (val :> envk)) 288 | (\envk -> rk (val :> envk)) 289 | 290 | testEffLbl :: SingI (x :: lbl) 291 | => Sing (p :: EffElem e (LRes x (Either l r)) xs) 292 | -> Env m xs 293 | -> (Env m (UpdateResTyImm xs p (LRes x l)) -> m b) 294 | -> (Env m (UpdateResTyImm xs p (LRes x r)) -> m b) 295 | -> m b 296 | testEffLbl SHere ((lbl := Left err) :> env) lk _rk = lk ((lbl := err) :> env) 297 | testEffLbl SHere ((lbl := Right ok) :> env) _lk rk = rk ((lbl := ok) :> env) 298 | testEffLbl (SThere p) (val :> env) lk rk 299 | = testEffLbl p env (\ envk -> lk (val :> envk)) 300 | (\ envk -> rk (val :> envk)) 301 | 302 | eff :: Env m xs -> EffM m xs xs' a -> (Env m xs' -> a -> m b) -> m b 303 | eff env (Value x) k = k env x 304 | eff env (prog `Ebind` c) k 305 | = eff env prog (\ env' p' -> eff env' (c p') k) 306 | eff env (Effect prf effP) k 307 | = execEff env prf effP k 308 | eff env (Lift prf effP) k 309 | = let env' = dropEnv env (fromSing prf) in 310 | eff env' effP (\ envk p' -> k (rebuildEnv envk prf env) p') 311 | eff env (New r prog) k 312 | = let env' = r :> env in 313 | eff env' prog (\ (_ :> envk) p' -> k envk p') 314 | eff env (Test prf l r) k 315 | = testEff prf env (\ envk -> eff envk l k) 316 | (\ envk -> eff envk r k) 317 | eff env (Test_lbl prf l r) k 318 | = testEffLbl prf env (\ envk -> eff envk l k) 319 | (\ envk -> eff envk r k) 320 | eff env (Catch prog handler) k 321 | = catch (eff env prog k) (\e -> eff env (handler e) k) 322 | eff env (l :- prog) k 323 | = let env' = unlabel env in 324 | eff env' prog (\ envk p' -> k (relabel l envk) p') 325 | 326 | run :: forall xs xs' m a. Applicative m => Env m xs -> EffM m xs xs' a -> m a 327 | run env prog = eff env prog (\ _env r -> P.pure r) 328 | 329 | runEnv :: Applicative m 330 | => Env m xs 331 | -> EffM m xs xs' a 332 | -> m (Env m xs', a) 333 | runEnv env prog = eff env prog (\env r -> P.pure (env, r)) 334 | 335 | runPure :: Env Identity xs -> EffM Identity xs xs' a -> a 336 | runPure env prog = runIdentity $ eff env prog (\_env r -> Identity r) 337 | 338 | runPureEnv :: Env Identity xs -> EffM Identity xs xs' a -> (Env Identity xs', a) 339 | runPureEnv env prog 340 | = runIdentity $ 341 | eff env prog (\env r -> Identity (env, r)) 342 | 343 | runWith :: (a -> m a) -> Env m xs -> EffM m xs xs' a -> m a 344 | runWith inj env prog = eff env prog (\ _env r -> inj r) 345 | 346 | type Eff m xs = EffM m xs xs 347 | 348 | -- Section 2.3 from the paper: 349 | mapE :: Applicative m => (a -> Eff m xs b) -> [a] -> Eff m xs [b] 350 | mapE _ [] = pure [] 351 | mapE f (x : xs) = (:) <$> f x <*> mapE f xs 352 | 353 | when :: Bool -> Eff m xs () -> Eff m xs () 354 | when True e = e 355 | when False _ = pure () 356 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Haskell translation of Idris's Algebraic Effects Library 2 | -------------------------------------------------------- 3 | 4 | This directory contains a translation of the algebraic effects 5 | library originally written in Idris for Brady's ICFP 2013 paper, 6 | "Programming and Reasoning with Algebraic Effects and Dependent Types". 7 | It compiles with a version of GHC 8 that has GHC bug [#12442][] fixed. 8 | This fix is in HEAD, as of this writing. 9 | 10 | [#12442]: https://ghc.haskell.org/trac/ghc/ticket/12442 11 | 12 | Files beginning with `Sec` in this directory correspond to sections 13 | in Brady's original paper. 14 | 15 | This implementation of algebraic effects is based on the version 16 | described in the paper and available [here][]. Note that this version 17 | is several years old. Newer versions of this library use higher-rank 18 | types in a way not yet available in GHC, though the use case is 19 | encompassed by my design for Dependent Haskell. 20 | 21 | [here]: https://github.com/idris-lang/Idris-dev/tree/v0.9.10/libs/effects 22 | -------------------------------------------------------------------------------- /Sec211.hs: -------------------------------------------------------------------------------- 1 | -- Adapted from Brady's ICFP '13 paper. 2 | 3 | {-# LANGUAGE TypeInType, RebindableSyntax #-} 4 | 5 | module Sec211 where 6 | 7 | import Effects 8 | import Effect.State 9 | import Data.Nat 10 | import Prelude ( Show, Ord(..), otherwise, foldl, flip ) 11 | 12 | data Tree a = Leaf 13 | | Node (Tree a) a (Tree a) 14 | deriving Show 15 | 16 | tag :: Tree a -> Eff m '[STATE Nat] (Tree (Nat, a)) 17 | tag Leaf = return Leaf 18 | tag (Node l x r) 19 | = do l' <- tag l 20 | lbl <- get 21 | put (lbl + 1) 22 | r' <- tag r 23 | return (Node l' (lbl, x) r') 24 | 25 | tagFrom :: Nat -> Tree a -> Tree (Nat, a) 26 | tagFrom x t = runPure (x :> Empty) (tag t) 27 | 28 | insert :: Ord a => a -> Tree a -> Tree a 29 | insert x Leaf = Node Leaf x Leaf 30 | insert x (Node l x' r) 31 | | x < x' = Node (insert x l) x' r 32 | | otherwise = Node l x' (insert x r) 33 | 34 | inserts :: Ord a => [a] -> Tree a -> Tree a 35 | inserts xs t = foldl (flip insert) t xs 36 | 37 | tree :: Tree Nat 38 | tree = inserts [4, 3, 8, 0, 2, 6, 7] Leaf 39 | 40 | taggedTree :: Tree (Nat, Nat) 41 | taggedTree = tagFrom 0 tree 42 | -------------------------------------------------------------------------------- /Sec212.hs: -------------------------------------------------------------------------------- 1 | -- Adapted from Brady's ICFP '13 paper. 2 | 3 | {-# LANGUAGE TypeInType, RebindableSyntax, TypeOperators, 4 | TemplateHaskell, ScopedTypeVariables, TypeFamilies, 5 | GADTs #-} 6 | {-# OPTIONS_GHC -Wno-unticked-promoted-constructors 7 | -Wno-name-shadowing #-} 8 | 9 | module Sec212 where 10 | 11 | import Sec211 12 | import Effects 13 | import Effect.State 14 | import Data.Nat 15 | import Data.Singletons.TH 16 | 17 | $(singletons [d| data Vars = Count | Tag |]) 18 | 19 | tagCount :: Tree a -> Eff m '[ Tag ::: STATE Nat 20 | , Count ::: STATE Nat ] (Tree (Nat, a)) 21 | tagCount Leaf 22 | = do SCount |- update_ (+1) 23 | return Leaf 24 | tagCount (Node l x r) 25 | = do l' <- tagCount l 26 | lbl <- STag |- get_ 27 | STag |- put_ (lbl + 1) 28 | r' <- tagCount r 29 | return (Node l' (lbl, x) r') 30 | 31 | tagCountFrom :: Nat -> Tree a -> (Nat, Tree (Nat, a)) 32 | tagCountFrom x t 33 | = let (_ :> SCount := leaves :> Empty, tree) = 34 | runPureEnv (STag := x :> SCount := 0 :> Empty) (tagCount t) 35 | in 36 | (leaves, tree) 37 | -------------------------------------------------------------------------------- /Sec213.hs: -------------------------------------------------------------------------------- 1 | -- Adapted from Brady's ICFP '13 paper. 2 | 3 | {-# LANGUAGE TypeInType, RebindableSyntax, OverloadedStrings, 4 | FlexibleContexts #-} 5 | 6 | module Sec213 where 7 | 8 | import qualified Prelude as P 9 | import Data.AChar 10 | import Data.Nat 11 | import Effect.State 12 | import Effect.Exception 13 | import Effect.Random 14 | import Effect.StdIO 15 | import Effects 16 | import Prelude ( Maybe(..), (++), lookup, (<$>), (<*>) ) 17 | 18 | type Vars = [(String, Nat)] 19 | 20 | data Expr = Val Nat | Add Expr Expr | Var String | Random Nat 21 | 22 | eval :: Expr -> Eff m '[EXCEPTION String, RND, STATE Vars] Nat 23 | eval (Val x) = return x 24 | eval (Var x) = do vs <- get 25 | case lookup x vs of 26 | Nothing -> raise ("Unknown var: " ++ x) 27 | Just val -> return val 28 | eval (Add l r) = (+) <$> eval l <*> eval r 29 | eval (Random upper) = rndNat 0 upper 30 | 31 | eval' :: Handler StdIO e 32 | => Expr -> Eff e '[EXCEPTION String, STDIO, RND, STATE Vars] Nat 33 | eval' (Val x) = return x 34 | eval' (Var x) = do vs <- get 35 | case lookup x vs of 36 | Nothing -> raise ("Unknown var: " ++ x) 37 | Just val -> return val 38 | eval' (Add l r) = (+) <$> eval' l <*> eval' r 39 | eval' (Random upper) = do num <- rndNat 0 upper 40 | putStrLn ("Random value: " ++ show num) 41 | return num 42 | 43 | runEval :: Vars -> Expr -> Maybe Nat 44 | runEval env expr = run (() :> 123 :> env :> Empty) (eval expr) 45 | 46 | runEval' :: Vars -> Expr -> P.IO Nat 47 | runEval' env expr = run (() :> () :> 123 :> env :> Empty) (eval' expr) 48 | 49 | vars :: Vars 50 | vars = [("x", 13), ("y", 5)] 51 | 52 | go :: Expr -> Maybe Nat 53 | go = runEval vars 54 | 55 | go' :: Expr -> P.IO Nat 56 | go' = runEval' vars 57 | 58 | expr1 :: Expr 59 | expr1 = Val 42 60 | 61 | expr2 :: Expr 62 | expr2 = Val 2 `Add` Val 5 63 | 64 | expr3 :: Expr 65 | expr3 = Var "x" 66 | 67 | expr4 :: Expr 68 | expr4 = Var "z" 69 | 70 | expr5 :: Expr 71 | expr5 = Random 10 72 | 73 | expr6 :: Expr 74 | expr6 = Val 100 `Add` Random 10 `Add` Random 10 75 | -------------------------------------------------------------------------------- /Sec225.hs: -------------------------------------------------------------------------------- 1 | -- Adapted from Brady's ICFP 2013 paper 2 | 3 | {-# LANGUAGE TypeInType, RebindableSyntax, FlexibleContexts, 4 | OverloadedStrings, ScopedTypeVariables, TypeApplications, 5 | AllowAmbiguousTypes, TypeFamilies #-} 6 | {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} 7 | 8 | module Sec225 where 9 | 10 | import Effects 11 | import Effect.File 12 | import Effect.StdIO 13 | import Effect.Exception 14 | import Control.Catchable 15 | import qualified Prelude as P 16 | import Prelude ( IO, not, reverse, (++), ($), FilePath 17 | , mapM_, map, length ) 18 | import Data.AChar 19 | import Data.Singletons 20 | import Util.If 21 | 22 | readLines_ :: Eff IO '[FILE_IO (OpenFile Read)] [String] 23 | readLines_ = readAcc [] 24 | where 25 | -- readAcc :: [String] -> Eff IO '[FILE_IO (OpenFile Read)] [String] 26 | -- Haskell doesn't need this signature. :) 27 | readAcc acc = do e <- eof 28 | if (not e) 29 | then do str <- readLine 30 | readAcc (str : acc) 31 | else return (reverse acc) 32 | 33 | readLines :: forall xs prf. 34 | SingI (prf :: SubList '[FILE_IO (OpenFile Read)] xs) 35 | => EffM IO xs (UpdateWith '[FILE_IO (OpenFile Read)] xs prf) [String] 36 | readLines = lift @_ @_ @prf readLines_ 37 | 38 | readFile :: String -> Eff IO '[FILE_IO (), STDIO, EXCEPTION String] [String] 39 | readFile path = catch (do _ <- open path SRead 40 | Test SHere (raise ("Cannot open file: " ++ path)) $ 41 | do lines <- readLines 42 | close @Read 43 | putStrLn (show (length lines)) 44 | return lines) 45 | (\ err -> do putStrLn ("Failed: " ++ err) 46 | return []) 47 | 48 | printFile :: FilePath -> IO () 49 | printFile filepath 50 | = run (() :> () :> () :> Empty) (readFile (fromString filepath)) P.>>= \ls -> 51 | mapM_ P.putStrLn (map toString ls) 52 | -------------------------------------------------------------------------------- /Sec226.hs: -------------------------------------------------------------------------------- 1 | -- Adapted from Brady's ICFP 2013 paper. 2 | 3 | {-# LANGUAGE TypeInType, RebindableSyntax #-} 4 | 5 | module Sec226 where 6 | 7 | import Effects 8 | import Effect.Select 9 | import qualified Prelude as P 10 | import Data.Nat 11 | import Prelude ( Bool(..), abs, (&&), (/=), all, (==), Maybe(..) ) 12 | 13 | no_attack :: (Nat, Nat) -> (Nat, Nat) -> Bool 14 | no_attack (x, y) (x', y') 15 | = x /= x' && y /= y' && abs (xi P.- xi') /= abs (yi P.- yi') 16 | where 17 | xi = toInteger x 18 | xi' = toInteger x' 19 | yi = toInteger y 20 | yi' = toInteger y' 21 | 22 | rowsIn :: Nat -> [(Nat, Nat)] -> [Nat] 23 | rowsIn col qs 24 | = [ x | x <- [1..8], all (no_attack (x, col)) qs ] 25 | 26 | addQueens :: Nat -> [(Nat, Nat)] -> Eff m '[SELECT] [(Nat, Nat)] 27 | addQueens 0 qs = return qs 28 | addQueens col qs 29 | = do row <- select (rowsIn col qs) 30 | addQueens (col - 1) ((row, col) : qs) 31 | 32 | getQueens :: Maybe [(Nat, Nat)] 33 | getQueens = run (() :> Empty) (addQueens 8 []) 34 | 35 | allQueens :: [[(Nat, Nat)]] 36 | allQueens = run (() :> Empty) (addQueens 8 []) 37 | -------------------------------------------------------------------------------- /Sec4.hs: -------------------------------------------------------------------------------- 1 | -- adapted from Brady's ICFP 2013 paper 2 | 3 | {-# LANGUAGE TypeInType, RebindableSyntax, TypeFamilies, GADTs, 4 | TypeOperators, ScopedTypeVariables, UndecidableInstances, 5 | TypeFamilyDependencies, FlexibleContexts, 6 | ConstraintKinds, TypeApplications #-} 7 | {-# OPTIONS_GHC -Wno-unticked-promoted-constructors 8 | -Wno-name-shadowing #-} 9 | 10 | module Sec4 where 11 | 12 | import Data.Kind 13 | import Data.Nat 14 | import Prelude ( Bool(..), (<$>), (<*>), IO, ($), (==) ) 15 | import Effects 16 | import Effect.Random 17 | import Effect.State 18 | import Data.Singletons.Prelude 19 | import Effect.StdIO 20 | import Data.AChar 21 | 22 | data Ty = TyNat | TyBool | TyUnit 23 | 24 | type family InterpTy (t :: Ty) = (r :: Type) | r -> t where 25 | InterpTy TyNat = Nat 26 | InterpTy TyBool = Bool 27 | InterpTy TyUnit = () 28 | 29 | data Vect :: Type -> Nat -> Type where 30 | Nil :: Vect a Z 31 | (:&) :: a -> Vect a n -> Vect a (S n) 32 | infixr 5 :& 33 | 34 | type GoodTy t = Good (InterpTy t) 35 | 36 | type family GoodCtx (g :: Vect Ty n) :: Constraint where 37 | GoodCtx Nil = () 38 | GoodCtx (ty :& rest) = (GoodTy ty, GoodCtx rest) 39 | 40 | data HasType :: forall n. Nat -> Vect Ty n -> Ty -> Type where 41 | HTZ :: HasType (U 0) (ty :& g) ty 42 | HTS :: HasType n g ty -> HasType (S n) (ty' :& g) ty 43 | 44 | data Expr :: Vect Ty n -> Ty -> Type where 45 | Val :: InterpTy a -> Expr g a 46 | Var :: HasType i g t -> Expr g t 47 | Rnd :: Nat -> Expr g TyNat 48 | Op :: (InterpTy a -> InterpTy b -> InterpTy c) 49 | -> Expr g a -> Expr g b -> Expr g c 50 | 51 | data Vars :: forall n. Vect Ty n -> Type where 52 | VNil :: Vars Nil 53 | (:^) :: InterpTy a -> Vars g -> Vars (a :& g) 54 | infixr 5 :^ 55 | 56 | data instance Sing (x :: Vars y) where 57 | SVNil :: Sing VNil 58 | SVCons :: Sing a -> Sing b -> Sing (a :^ b) 59 | 60 | instance GoodCtx g => SingKind (Vars g) where 61 | type DemoteRep (Vars g) = Vars g 62 | 63 | fromSing SVNil = VNil 64 | fromSing (a `SVCons` b) = fromSing a :^ fromSing b 65 | 66 | toSing VNil = SomeSing SVNil 67 | toSing (a :^ b) 68 | = case toSing a of 69 | SomeSing a' -> case toSing b of 70 | SomeSing b' -> SomeSing (SVCons a' b') 71 | 72 | lookup :: HasType i g t -> Vars g -> InterpTy t 73 | lookup HTZ (x :^ _) = x 74 | lookup (HTS i) (_ :^ g) = lookup i g 75 | 76 | eval :: GoodCtx g 77 | => Expr g t 78 | -> Eff m '[RND, STATE (Vars g)] (InterpTy t) 79 | eval (Val x) = return x 80 | eval (Var i) = do vars <- get 81 | return (lookup i vars) 82 | eval (Rnd upper) = rndNat 0 upper 83 | eval (Op op x y) = op <$> eval x <*> eval y 84 | 85 | data Imp :: forall n. Vect Ty n -> Ty -> Type where 86 | Let :: GoodTy t => Expr g t -> Imp (t :& g) u -> Imp g u 87 | (::=) :: HasType i g t -> Expr g t -> Imp g t 88 | Print :: Expr g TyNat -> Imp g TyUnit 89 | (:>>=) :: GoodTy a => Imp g a -> (InterpTy a -> Imp g b) -> Imp g b 90 | Return :: Expr g t -> Imp g t 91 | 92 | (>>>) :: GoodTy a => Imp g a -> Imp g b -> Imp g b 93 | p1 >>> p2 = p1 :>>= \_ -> p2 94 | 95 | updateVar :: HasType i g t -> Vars g -> InterpTy t -> Vars g 96 | updateVar HTZ (_ :^ vars) x = x :^ vars 97 | updateVar (HTS i) (a :^ vars) x = a :^ updateVar i vars x 98 | 99 | interp :: forall g t. (GoodCtx g, GoodTy t) 100 | => Imp g t 101 | -> Eff IO '[STDIO, RND, STATE (Vars g)] (InterpTy t) 102 | interp (Let (e :: Expr g t') sc) 103 | = do e' <- lift (eval e) 104 | vars <- get @(Vars g) 105 | putM @(Vars g) (e' :^ vars) 106 | res <- interp sc 107 | (_ :^ vars') <- get @(Vars (t' :& g)) 108 | putM @(Vars (t' :& g)) vars' 109 | return res 110 | interp (v ::= val) 111 | = do val' <- lift (eval val) 112 | update (\vars -> updateVar v vars val') 113 | return val' 114 | interp (Print x) 115 | = do e <- lift (eval x) 116 | putStrLn (show e) 117 | interp (prog :>>= k) 118 | = do x <- interp prog 119 | interp (k x) 120 | interp (Return e) 121 | = lift (eval e) 122 | 123 | prog :: Imp Nil TyUnit 124 | prog = Let (Val 3) $ 125 | Let (Val True) $ 126 | Print (Var (HTS HTZ)) >>> 127 | (HTS HTZ ::= Op (+) (Var (HTS HTZ)) (Val 5)) >>> 128 | Print (Var (HTS HTZ)) >>> 129 | Print (Op (\() -> boolean) (Val ()) (Var HTZ)) >>> 130 | (HTS HTZ ::= Rnd 10) >>> 131 | Print (Var (HTS HTZ)) >>> 132 | Print (Var (HTS HTZ)) >>> 133 | (HTS HTZ ::= Rnd 9) >>> 134 | Print (Var (HTS HTZ)) >>> 135 | (HTZ ::= Op (\() -> isZero) (Val ()) (Var (HTS HTZ))) >>> 136 | Print (Op (\() -> boolean) (Val ()) (Var HTZ)) 137 | where 138 | boolean :: Bool -> Nat 139 | boolean False = 0 140 | boolean True = 1 141 | 142 | isZero 0 = True 143 | isZero _ = False 144 | 145 | main :: IO () 146 | main = run (() :> 31 :> VNil :> Empty) (interp prog) 147 | -------------------------------------------------------------------------------- /Util/If.hs: -------------------------------------------------------------------------------- 1 | module Util.If where 2 | 3 | ifThenElse :: Bool -> a -> a -> a 4 | ifThenElse b t f = if b then t else f 5 | -------------------------------------------------------------------------------- /Util/MkChar.hs: -------------------------------------------------------------------------------- 1 | -- produces the source code to paste into Data.AChar 2 | 3 | module Util.MkChar where 4 | 5 | import Control.Monad 6 | 7 | allChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ ['_'] 8 | 9 | mkCon :: Char -> IO () 10 | mkCon c = putStrLn ("| C" ++ [c]) 11 | 12 | mkCons :: IO () 13 | mkCons = mapM_ mkCon allChars 14 | 15 | mkToChar :: IO () 16 | mkToChar = 17 | forM_ allChars $ \c -> putStrLn ("toChar C" ++ c : " = '" ++ c : "'") 18 | 19 | mkFromChar :: IO () 20 | mkFromChar = 21 | forM_ allChars $ \c -> putStrLn ("fromChar '" ++ c : "' = C" ++ [c]) 22 | -------------------------------------------------------------------------------- /Util/Singletons.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms, ViewPatterns, TypeInType, TypeFamilies, 2 | GADTs #-} 3 | 4 | module Util.Singletons where 5 | 6 | import Data.Singletons 7 | 8 | pattern TheSing :: SingKind k => Sing (a :: k) -> DemoteRep k 9 | pattern TheSing x <- (toSing -> SomeSing x) where 10 | TheSing x = fromSing x 11 | --------------------------------------------------------------------------------