-XOverloadedLabels


bit.ly/haskell-labels
 

Artyom Kazak (@neongreen)

-XCPP
(C preprocessor)

Copypaste

instance MonadBaseControl IO IO where
    type StM IO a = a
    liftBaseWith f = f id
    restoreM = return
    {-# INLINABLE liftBaseWith #-}
    {-# INLINABLE restoreM #-}
instance MonadBaseControl Maybe Maybe where
    type StM Maybe a = a
    liftBaseWith f = f id
    restoreM = return
    {-# INLINABLE liftBaseWith #-}
    {-# INLINABLE restoreM #-}
instance MonadBaseControl [] [] where
    type StM [] a = a
    liftBaseWith f = f id
    restoreM = return
    {-# INLINABLE liftBaseWith #-}
    {-# INLINABLE restoreM #-}
instance MonadBaseControl STM STM where
    type StM STM a = a
    liftBaseWith f = f id
    restoreM = return
    {-# INLINABLE liftBaseWith #-}
    {-# INLINABLE restoreM #-}
instance MonadBaseControl (Either e) (Either e) where
    type StM (Either e) a = a
    liftBaseWith f = f id
    restoreM = return
    {-# INLINABLE liftBaseWith #-}
    {-# INLINABLE restoreM #-}

-XCPP




instance MonadBaseControl IO IO where
    type StM IO a = a
    liftBaseWith f = f id
    restoreM = return
    {-# INLINABLE liftBaseWith #-}
    {-# INLINABLE restoreM #-}
{-# LANGUAGE CPP #-}

#define BASE(M)                           \
instance MonadBaseControl (M) (M) where { \
    type StM (M) a = a;                   \
    liftBaseWith f = f id;                \
    restoreM = return;                    \
    {-# INLINABLE liftBaseWith #-};       \
    {-# INLINABLE restoreM #-}}

Raw Haskell

With a #define

Instance generation

BASE(IO)
BASE(Maybe)
BASE(Either e)
BASE([])
BASE((->) r)
BASE(Identity)
BASE(STM)

#if MIN_VERSION_base(4,4,0)
BASE(Strict.ST s)
BASE(       ST s)
#endif

#undef BASE

monad-control source code

Aelve Guide – the “CPP” section

Template Haskell

A simple example

fst  (x,_)     = x
fst3 (x,_,_)   = x
fst4 (x,_,_,_) = x

print $ fst3 ("hello world", 1, 2)
print $ fst4 ("hello world", 1, 2, 3)
{-# LANGUAGE TemplateHaskell #-}

print $ $(fstN 3) ("hello world", 1, 2)
print $ $(fstN 4) ("hello world", 1, 2, 3)
import Language.Haskell.TH

fstN :: Int -> Q Exp
fstN n = do
   x <- newName "x"
   pure $ LamE [TupP $ VarP x : replicate (n - 1) WildP]
               (VarE x)

A simple example

ghci> import Language.Haskell.TH
ghci> :set -XTemplateHaskell

ghci> runQ [| \(x, _, _) -> x |]
LamE [TupP [VarP x_1,WildP,WildP]] (VarE x_1)

GHC can parse code for us: 

VarP :: Name -> Pat
VarE :: Name -> Exp

mkName :: String -> Name
fst3 :: Q Exp
fst3 = do
    let x = mkName "x"
    pure $ LamE [TupP [VarP x, WildP, WildP]] (VarE x)
    --     \    (x, _, _)                     -> x

Haskell AST

data Exp
  = VarE Name                          -- x
  | ConE Name                          -- Just
  | LitE Lit                           -- 5, 'c', "string"
  | AppE Exp Exp                       -- f x
  | AppTypeE Exp Type                  -- f @Int
  | InfixE (Maybe Exp) Exp (Maybe Exp) -- x+y, (x+), (+x)
  | LamE [Pat] Exp                     -- \a b c -> ...
  | TupE [Exp]                         -- (a, b, c)
  | CondE Exp Exp Exp                  -- if p then A else B
  | ...
data Pat  = ...
data Type = ...
data Dec  = ...

A simple example

fst3 :: Q Exp
fst3 = do
    let x = mkName "x"
    pure $ LamE [TupP [VarP x, WildP, WildP]] (VarE x)
fst3 :: Q Exp
fst3 = do
    x <- newName "x"
    lamE [tupP [varP x, wildP, wildP]] (varE x)
varP :: Name -> Q Pat
varE :: Name -> Q Exp

newName :: String -> Q Name

A simple example

fst3 is a macro. Use $(fst3) to expand it. $(...) is called a splice.

ghci> :set -XTemplateHaskell

ghci> :t $(fst3)
$(fst3) :: (t2, t1, t) -> t2

ghci> $(fst3) ("hello", 10, True)
"hello"

ghci> $fst3 ("hello", 10, True)
"hello"

A simple example

fst4 :: Q Exp
fst4 = do
    x <- newName "x"
    lamE [tupP [varP x, wildP, wildP, wildP]] (varE x)
fstN :: Int     -- ^ Tuple length
     -> Q Exp
fstN n = do
    x <- newName "x"
    lamE [tupP $ varP x : replicate (n - 1) wildP] (varE x)
fst5 :: Q Exp
fst5 = do
    x <- newName "x"
    lamE [tupP [varP x, wildP, wildP, wildP, wildP]] (varE x)

Stage restriction

GHC stage restriction: 'fst3'
  is used in a top-level splice or annotation,
  and must be imported, not defined locally
eval :: Exp -> Int
eval expr = $(pure expr)
fst3 :: Q Exp
fst3 = do
    x <- newName "x"
    lamE [tupP [varP x, wildP, wildP]] (varE x)

main = print ($fst3 (1,2,3))

Declaration order matters :(

import Control.Lens

data Point = Point { _x, _y :: Double }





makeLenses ''Point

import Control.Lens

data Point = Point { _x, _y :: Double }

isNull :: Point -> Bool
isNull p = p ^. x == 0                    -- (8)
        && p ^. y == 0                    -- (9)

makeLenses ''Point                        -- (11)

8:17: error: …
    • Variable not in scope: x :: Getting Integer Point Integer
    • ‘x’ (splice on line 11) is not in scope before line 11
9:17: error: …
    • Variable not in scope: y :: Getting Integer Point Integer
    • ‘y’ (splice on line 11) is not in scope before line 11

Quasiquotation

ghci> :set -XQuasiQuotes 
ghci> import Language.Haskell.TH (runQ)

ghci> runQ [| \x -> x |]
LamE [VarP x_0] (VarE x_0)
ghci> runQ [| data A = B Int |]
<interactive>:1:9: error: parse error on input ‘data’
ghci> runQ [d| data A = B Int |]
[ DataD [] A_1 [] Nothing 
    [ NormalC B_2 
        [ ( Bang NoSourceUnpackedness NoSourceStrictness
          , ConT GHC.Types.Int ) 
        ]
    ] []
]

Four types of quasiquotes

Expression quotes

[| \x -> x + 1 |] :: Q Exp

Type quotes

[t| Int -> Int |] :: Q Type

Pattern quotes

[p| xs@(x:r) |] :: Q Pat

Declaration quotes

[d| data Pair a = Pair a a |] :: Q [Dec]

I lied

Hackage: neat-interpolation

{-# LANGUAGE QuasiQuotes #-}

import Data.Text (Text, pack)
import NeatInterpolation (text)

greet :: Text -> Text
greet name = [text|Hello $name! How's life going?|]
                        -- ^
                        -- will be substituted

Defining quasiquoters

data QuasiQuoter = QuasiQuoter {
    quoteExp  :: String -> Q Exp,
    quotePat  :: String -> Q Pat,
    quoteType :: String -> Q Type,
    quoteDec  :: String -> Q [Dec]
    }

Data validation

Hackage: path (well-typed paths)

absdir :: QuasiQuoter

homeDir :: Path Abs Dir
homeDir = [absdir|/home/chris/|]

Hackage: modern-uri (well-typed URIs)

uri :: QuasiQuoter

google :: URI
google = [uri|https://google.com|]

Templating

Hackage: interpolatedstring-perl6 (fancier string interpolation)

bar :: String
bar = [qc| Well {"hello" ++ " there"} {6 * 7} |]

Yesod (shakespearean templates)

[hamlet|
  $doctype 5
  <html>
      <head>
          <title>#{pageTitle} - My Site
          <link rel=stylesheet href=@{Stylesheet}>
      <body>
          <h1 .page-title>#{pageTitle}
          ...
|]

Code generation

Nikita Volkov's “record” library

connect :: [r| {host :: ByteString,
                port :: Int,
                user :: ByteString,
                password :: ByteString} ]
        -> IO Connection

persistent

mkPersist sqlSettings [persistLowerCase|
Person
    name String
    age Int
    deriving Show
|]

More code generation

{-# LANGUAGE TemplateHaskell #-}

module Stub where

import Language.Haskell.TH

showStub :: Name -> Q [Dec]
showStub name = [d|instance Show $(conT name) where 
                     show _ = "<unshowable>"|]
{-# LANGUAGE TemplateHaskell #-}

import Stub

data MyData = MyData
     { foo :: String
     , bar :: Int }

showStub ''MyData

More code generation

...code...

do inst1 <- showStub ''A
   inst2 <- showStub ''B
   inst3 <- showStub ''C
   pure (inst1 ++ inst2 ++ inst3)
...code...

concat <$> mapM showStub [''A, ''B, ''C]

Datatype inspection

listFields :: Name -> Q [Dec]
listFields name = do
  TyConI (DataD _ _ _ _ [RecC _ fields] _) <- reify name

  let fieldNames = map (\(field, _bang, _type) -> field) fields

  let showFields :: Q Exp
      showFields = listE $ map showField fieldNames

  [d|instance Show $(conT name) where
       show x = intercalate ", " (map ($ x) $showFields)|]

showField :: Name -> Q Exp
showField field =
  let fieldName = nameBase field
  in  [| \record -> fieldName ++ " = " ++ 
                    show ($(varE field) record) |]

data MyData = MyData
     { foo :: String
     , bar :: Int }

listFields ''MyData
foo = "bar", bar = 5

Datatype inspection

-- For any field "foo", generates
--
--    \record -> "foo" ++ " = " ++ show (foo record)
--
showField :: Name -> Q Exp
showField field =
  let fieldName = nameBase field
  in  [| \record -> fieldName ++ " = " ++ 
                    show ($(varE field) record) |]

Datatype inspection

listFields :: Name -> Q [Dec]
listFields name = do
  TyConI (DataD _ _ _ _ [RecC _ fields] _) <- reify name

  let fieldNames = map (\(field, _bang, _type) -> field) fields

DataD
  Cxt
  Name
  [TyVarBndr]
  (Maybe Kind)
  [Con]
  [DerivClause]
data

  X
    a b c

  where X {..}
  deriving ...
RecC
  Name
  [( Name
   , Bang
   , Type)]
|
  X {
    foo ::
      !
      Int
    }

Datatype inspection II

data BlockVersion = BlockVersion
    { bvMajor :: !Word16
    , bvMinor :: !Word16
    , bvAlt   :: !Word8
    }


deriveSimpleBi ''BlockVersion [
    Cons 'BlockVersion [
        Field [| bvMajor :: Word16 |],
        Field [| bvMinor :: Word16 |],
        Field [| bvAlt   :: Word8  |]
    ]]

Launching missiles

{-# LANGUAGE TemplateHaskell #-}

import qualified Language.C.Inline as C    -- inline-c

C.include "<stdio.h>"

main :: IO ()
main = do
  x <- [C.block| 
      int {
          // Read and sum 5 integers
          int i, sum = 0, tmp;
          for (i = 0; i < 5; i++) {
              scanf("%d", &tmp);
              sum += tmp;
          }
          return sum;
      } |]
  print x

Template Haskell


bit.ly/green-th
 

Artyom Kazak (@neongreen)
Dmitry Kovanikov (@chshersh)

talk
slides

-XOverloadedLabels

By Artyom Kazak

Made with Slides.com

-XOverloadedLabels

  • 331

More from Artyom Kazak