Take it easy: Dynamic typed and Untyped Haskell using GHC

name: inverse
layout: true
class: center, middle, inverse
---
.left.large2.handwrite[Take it easy:]
#Dynamic typed
#and Untyped
#Haskell using GHC
.large2.handwrite.normal[CindyLinz]

2014.7.3

---
layout: false
class: center, middle, inverse

# .red[<span style=font-family:sans-serif>WARNING</span>]
### THE FOLLOWING MATERIAL IS PROBABLY
### THE MOST DIRTY PART OF HASKELL.

---
layout: false

class: center

```
This is like looking at a finely chiseled sculpture
made from beautiful and purely white wood.
Then you realize in horror that the material is actually human bone.
-- apfelmus @ reddit --
```
```
這就像是看著純淨精美的木頭的雕刻
驚懼地發現這材料其實都是死人骨頭
```

---
layout: true

## 使用方法示範 .smaller[(Dynamic)]

---
```haskell
{-# LANGUAGE DeriveDataTypeable #-}
module Main
  where

import Control.Monad
import Data.Dynamic

whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust target act = case target of
  Nothing -> return ()
  Just a -> act a
```

---

```haskell
data Height = Height Int deriving (Typeable)
data Weight = Weight Double deriving (Typeable)
data Name = Name String deriving (Typeable)

props :: [Dynamic]
props = [toDyn (Name "who I am"), toDyn (Height 170), toDyn (Weight 45.1)]

main =
  forM_ props $ \prop -> do
    whenJust (fromDynamic prop)
      (\(Height h) ->
        putStrLn $ "height " ++ show h ++ " cm")
    whenJust (fromDynamic prop)
      (\(Weight w) ->
        putStrLn $ "weight " ++ show w ++ " kg")
    whenJust (fromDynamic prop)
      (\(Name n) ->
        putStrLn $ "I am " ++ n)
```

---

Output..
```html
I am who I am
height 170 cm
weight 45.1 kg
```

---
layout: true

## 使用方法示範 .smaller[(unsafeCoerce)]

---

```haskell
module Main where

import Data.Array.IO
import Unsafe.Coerce
import GHC.Prim

main = do
  memory <- newListArray (0, length code - 1) code
  process memory

data Op
  = OpAdd -- addr1 addr2 addr_result
  | OpNegative -- addr addr_result
  | OpPrint -- addr
  | OpJump -- addr_next
  | OpEnd
```

---
layout: false

```haskell
code =
  [ unsafeCoerce OpJump -- 0
  , unsafeCoerce (4 :: Int) -- 1
  , unsafeCoerce (16 :: Int) -- 2
  , unsafeCoerce (2 :: Int) -- 3
  , unsafeCoerce OpNegative -- 4 *
  , unsafeCoerce (3 :: Int) -- 5
  , unsafeCoerce (3 :: Int) -- 6
  , unsafeCoerce OpAdd -- 7
  , unsafeCoerce (2 :: Int) -- 8
  , unsafeCoerce (3 :: Int) -- 9
  , unsafeCoerce (1 :: Int) -- 10
  , unsafeCoerce OpJump -- 11
  , unsafeCoerce (0 :: Int) -- 12
  , unsafeCoerce (8 :: Int) -- 13
  , unsafeCoerce OpPrint -- 14 *
  , unsafeCoerce (1 :: Int) -- 15
  , unsafeCoerce OpAdd -- 16
  , unsafeCoerce (1 :: Int) -- 17
  , unsafeCoerce (13 :: Int) -- 18
  , unsafeCoerce (1 :: Int) -- 19
  , unsafeCoerce OpJump -- 20
  , unsafeCoerce (0 :: Int) -- 21
  , unsafeCoerce OpEnd -- 22 *
  ]

```

---

```haskell
process :: IOArray Int Any -> IO ()
process memory = go 0 where
  r addr = fmap unsafeCoerce $ readArray memory addr
  w value addr = writeArray memory addr (unsafeCoerce value)
  go ip = do
    op <- r ip
    case op of
      OpAdd -> do
        arg1 <- r (ip+1) >>= r
        arg2 <- r (ip+2) >>= r
        r (ip+3) >>= w (arg1 + arg2)
        go (ip+4)
      OpNegative -> do
        arg <- r (ip+1) >>= r
        r (ip+2) >>= w (-arg)
        go (ip+3)
      OpPrint -> do
        arg <- r (ip+1) >>= r
        putStrLn $ show (arg :: Int)
        go (ip+2)
      OpJump -> do
        newIP <- r (ip+1)
        go newIP
      OpEnd ->
        return ()
```

---
layout: true

## GHC 的實作

---

Dynamic 的資料格式

```haskell
module Data.Dynamic where

data Dynamic = Dynamic TypeRep Any
```

```haskell
module Data.Typeable where

data TypeRep = TypeRep Fingerprint TyCon [TypeRep]

data TyCon = TyCon
 { tyConHash    :: Fingerprint
 , tyConPackage :: String
 , tyConModule  :: String
 , tyConName    :: String
 }
```

---

剛剛用到的 Dynamic 相關函數

```haskell
module Data.Dynamic where

toDyn :: Typeable a => a -> Dynamic
toDyn v = Dynamic (typeOf v) (unsafeCoerce v)

fromDynamic :: Typeable a => Dynamic -> Maybe a
fromDynamic (Dynamic t v) =
  case unsafeCoerce v of 
    r | t == typeOf r -> Just r
      | otherwise     -> Nothing
```
註: typeOf 不會 evaluate 參數的 value, 只依 type 決定結果

---

任意 type 無條件「當成」任意 type

```haskell
module Unsafe.Coerce where

unsafeCoerce :: a -> b
```

.red.bold[(後果自負)]

GHC 推荐用來給 unsafeCoerce 之後裝任意 type 的 type

```haskell
module GHC.Prim where

data Any k
```

我不知道為什麼這邊是 Any k, 但在 Dynamic 裡面是 Any

我自己寫也是用 Any

---

目前主流 GHC 7.6 版本 (及以前) 的作法

```haskell
module Data.Typeable where

class Typeable a where
  typeOf :: a -> TypeRep
instance Typeable Int where -- ...

class Typeable1 t where
  typeOf1 :: t a -> TypeRep
instance Typeable1 Maybe where -- ...
instance (Typeable1 s, Typeable a) => Typeable (s a) -- ...

class Typeable2 t where
  typeOf2 :: t a b -> TypeRep
instance Typeable2 Either where -- ...
-- ...
cast :: (Typeable a, Typeable b) => a -> Maybe b
cast x = r where
  r = if typeOf x == typeOf (fromJust r)
    then Just $ unsafeCoerce x
    else Nothing
```
註: typeOf 不會真的去 evaluate 傳給它的 value, 純依 type 決定結果

---

目前主流 GHC 7.6 版本 (及以前) 的作法

```haskell
module Data.Typeable where

class Typeable a where
  typeOf :: a -> TypeRep
instance Typeable Int where -- ...

class Typeable1 t where
  typeOf1 :: t a -> TypeRep
instance Typeable1 Maybe where -- ...
instance (Typeable1 s, Typeable a) => Typeable (s a) -- ...

class Typeable2 t where
  typeOf2 :: t a b -> TypeRep
instance Typeable2 Either where -- ...
-- ...
```

GHC 7.8 用 Poly Kind 的方式解決這個一整排 Typeable 的問題 (我還不會)

不過我們應該都會用 deriving Typeable 而不是直接手動定義 (?

---
layout: true

## 正經的應用 .smaller[(Typeable)]
### An Extensible Dynamically-Typed Hierarchy of Exceptions
#### .right[by Simon Marlow, 2006]

---

```haskell
catch :: Exception e => IO a -> (e -> IO a) -> IO a
```

```haskell
catch
  (putStrLn $ show (3 `div` 0))
  (\e -> putStrLn $ "Error: " ++ show (e :: ArithException))
```

```haskell
{-# LANGUAGE ScopedTypeVariables #-}

catch
  (putStrLn $ show (3 `div` 0))
  (\(e :: ArithException) -> putStrLn $ "Error: " ++ show e)
```

---

Output..

```html
Error: divide by zero
```

---
layout: true

## 正經的應用 .smaller[(Typeable)]

---

```haskell
class (Typeable e, Show e) => Exception e where
  toException   :: e -> SomeException
  fromException :: SomeException -> Maybe e

toException = SomeException
  fromException (SomeException e) = cast e
```

```haskell
data SomeException = forall e . Exception e => SomeException e
  deriving Typeable
instance Show SomeException where -- ...
instance Exception SomeException where
  toException se = se
  fromException = Just
```

---

```haskell
data ArithException = -- ...
  deriving (Eq, Ord, Typeable)

instance Show ArithException where -- ..

instance Exception ArithException
  -- toException = SomeException
  -- fromException (SomeException e) = cast e
```

---

多層次 Exception

```haskell
data SomeCompilerException = forall e . Exception e => SomeCompilerException e
  deriving Typeable

data SomeFrontendException = forall e . Exception e => SomeFrontendException e
  deriving Typeable

data MismatchedParentheses = MismatchedParentheses
  deriving (Typeable, Show)

instance Show SomeCompilerException where
  show (SomeCompilerException e) = show e
instance Show SomeFrontendException where
  show (SomeFrontendException e) = show e

```

---

toException 的部分..

```haskell
compilerExceptionToException :: Exception e => e -> SomeException
compilerExceptionToException = toException . SomeCompilerException

frontendExceptionToException :: Exception e => e -> SomeException
frontendExceptionToException = toException . SomeFrontendException

instance Exception SomeCompilerException
  -- toException = SomeException
instance Exception SomeFrontendException where
  toException = compilerExceptionToException
instance Exception MismatchedParentheses where
  toException = frontendExceptionToException

-- mismatchedParentheses =
--   SomeException (SomeCompilerException
--     (SomeFrontendException MismatchedParentheses))
```

---

fromException 的部分..

```haskell
compilerExceptionFromException :: Exception e => SomeException -> Maybe e
compilerExceptionFromException x = do
  SomeCompilerException a <- fromException x
  cast a
frontendExceptionFromException :: Exception e => SomeException -> Maybe e
frontendExceptionFromException x = do
  SomeFrontendException a <- fromException x
  cast a
instance Exception SomeCompilerException
  -- fromException (SomeException e) = cast e
instance Exception SomeFrontendException where
  fromException = compilerExceptionFromException
instance Exception MismatchedParentheses where
  fromException = frontendExceptionFromException
-- mismatchedParentheses = SomeException (SomeCompilerException
--     (SomeFrontendException MismatchedParentheses))
```

---
layout: false

## 正經的應用 .smaller[(Typeable)]
### XMonad Window Message

仿 Exception 模式 User-extensible messages (單層次 only)

```haskell
data SomeMessage = forall a . Message a => SomeMessage a

class Typeable a => Message a where -- (空的)

fromMessage :: Message m => SomeMessage -> Maybe m
```

---
layout: true

## 正經的應用 .smaller[(unsafeCoerce)]
### Runtime interpreted Haskell

---

from [blog of parenz](http://parenz.wordpress.com/2013/08/17/ghc-api-interpreted-compiled-and-package-modules/) ...
```haskell
import Control.Applicative
import DynFlags
import GHC
import GHC.Paths
import GhcMonad            (liftIO) -- from ghc7.7 and up you can use the usual
    -- liftIO from Control.Monad.IO.Class
import Unsafe.Coerce
```

---

```haskell
main = defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
    runGhc (Just libdir) $ do
        dflags <- getSessionDynFlags
        setSessionDynFlags $ dflags { hscTarget = HscInterpreted
                                    , ghcLink   = LinkInMemory
                                    }
        setTargets =<< sequence [guessTarget "test.hs" Nothing]
        load LoadAllTargets
        setContext [IIModule $ mkModuleName "Test"]

act <- unsafeCoerce <$> compileExpr "print test"
        liftIO act
```

---

前一陣子做的 [HasPerl](https://github.com/CindyLinz/Haskell-HasPerl)

動態剪貼生成 Haskell 程式, 由 GHC API interpret 並與現有程式互動

我們可以預知動態程式碼的 type, 但 GHC 在實際 interpret 它以前不知道

---
layout: true

## 猙獰的應用 .smaller[(unsafeCoerce)]

---

from [gist of bitonic](https://gist.github.com/bitonic/1934179) ...

```haskell
{-# LANGUAGE StandaloneDeriving, FlexibleContexts, UndecidableInstances #-}
-- Laungh ghci with -fobject-code to make the Fix/Tree trick work (thanks edwardk).

-- courtesy of hpc on #haskell
import Unsafe.Coerce
import Control.Monad.ST

toInteger :: Int -> Integer
isJust :: Maybe a -> Bool
null :: [a] -> Bool
id :: a -> a
```

```haskell
toInteger = unsafeCoerce
isJust = unsafeCoerce
null = not . unsafeCoerce
id = unsafeCoerce
```
.right[Continue...]

---

```haskell
newtype Fix f = Fix (f (Fix f))
deriving instance (Show (Fix f), Show (f (Fix f))) => Show (Fix f)

data Tree a = Leaf a | Branch (Tree a) (Tree a)
deriving (Eq, Ord, Show, Read)
```

```haskell
treeToLists :: Tree a -> Fix []
treeToLists = unsafeCoerce
```

```haskell
unsafeSTToIO :: ST s a -> IO a
unsafeSTToIO = unsafeCoerce

undefined :: a
undefined = unsafeCoerce unsafeCoerce
```

---

網友心得:

```
it's a deficient implementation, the whole thing is a joke really.
                                                         -- rostayob @ reddit
```
```
This makes me uncomfortable.
                                                         -- hotoatmeal @ reddit
```
```
Hello segfaults.
                                                         -- brinchj @ reddit
```

---

edwark 的心得
```
gergoerdi: My point is, I don't think the order of constructor definitions
  is in any way an API with any stability guarantees, so just don't do this.
edwark: The order actually gets used by Typeable,Data and the default Ord,
  Enum and Ix instances, and so it is generally considered to be part of the API.
```

---

```
dmwit: In what sense is treeToLists the right function?
edwark: Tree a is a Cofree [] a not Mu [a]. The Tree ADT only has one constructor
  so everything unsafeCoerces to the first constructor of [a], which is [].
rostayob: Mu [a] wouldn't typecheck. Also, Tree has two constructors.
  And why would Tree be Cofree [] a?
edwark: *Mu [] and the Tree I was referring to was the one that was used
  when this topic came up on #haskell the other data, which is from Data.Tree
edwark: This appears to be an interaction between the way the bytecode
  interpreter deals with tag bits and the way the rest of the system does.
  If you put the code for those tests in the module and run ghci
  with -fobject-code you get the result you'd expect.
  Also you can use

{-# LANGUAGE StandaloneDeriving, FlexibleContexts, UndecidableInstances #-}

to permit the standalone deriving definition of

deriving instance (Show (Fix f), Show (f (Fix f))) => Show (Fix f)

to avoid having to make up another type.
  In general this kind of thing is why its 'unsafe'-Coerce =)
```

---

* au: edwardk 真是完全繼承了 -Ofun 精神 (他自己說的 (但是我同意))

( -Ofun : a compiler should be optimized for fun )

* au: 最喜歡各種 unsafe* 了 \o/   -- irc.freenode.net #haskell.tw

* unsafeCoerce, unsafePerformIO, unsafeInterleaveIO, unsafeFreeze, trace...

看起來真不錯... ww

---

layout: false

## 結尾垃圾話

.handwrite[天堂在哪裡~]

* .handwrite[在地獄裡，和寫 Haskell 的 CindyLinz 在一起] ♥

.handwrite[地獄在哪裡~]

* .handwrite[在 Haskell 天堂裡, 一閃一閃亮晶晶, 滿天都是 unsafeCoerce] 💔

.handwrite[看到 CindyLinz 在 Haskell 裡寫滿 unsafeCoerce...]

* .handwrite[你一定是看錯了...]