never executed always true always false
    1 {-|
    2 Module: Flaw.Build
    3 Description: Basic definitions for build.
    4 License: MIT
    5 -}
    6 
    7 {-# LANGUAGE TemplateHaskell #-}
    8 
    9 module Flaw.Build
   10   ( loadFile
   11   , Embed(..)
   12   , EmbedIO(..)
   13   , embedStringExp
   14   , fileExp
   15   , packList
   16   , packVector
   17   , unpackVector
   18   , embedCStringExp
   19   , genEmbed
   20   ) where
   21 
   22 import Control.Monad
   23 import qualified Data.ByteString as B
   24 import qualified Data.ByteString.Unsafe as B
   25 import qualified Data.ByteString.Lazy as BL
   26 import qualified Data.Text as T
   27 import qualified Data.Text.Encoding as T
   28 import qualified Data.Vector as V
   29 import qualified Data.Vector.Generic as VG
   30 import qualified Data.Vector.Storable as VS
   31 import Foreign.C.Types
   32 import Foreign.Marshal.Array
   33 import Foreign.Ptr
   34 import Foreign.Storable
   35 import qualified GHC.Ptr as GHC
   36 import Language.Haskell.TH
   37 import Language.Haskell.TH.Syntax(addDependentFile)
   38 import System.IO.Unsafe
   39 
   40 -- | Load file and add it as a dependency.
   41 loadFile :: FilePath -> Q BL.ByteString
   42 loadFile filePath = do
   43   fileData <- runIO $ BL.readFile filePath
   44   addDependentFile filePath
   45   return fileData
   46 
   47 -- | Class of pure data may be embedded.
   48 -- An embedded expression is of type a.
   49 class Embed a where
   50   embedExp :: a -> Q Exp
   51 
   52 instance Embed Int where
   53   embedExp n = litE $ integerL $ fromIntegral n
   54 
   55 instance Embed Float where
   56   embedExp n = litE $ rationalL $ toRational n
   57 
   58 instance Embed Double where
   59   embedExp n = litE $ rationalL $ toRational n
   60 
   61 instance Embed Bool where
   62   embedExp b = conE $ if b then 'True else 'False
   63 
   64 instance Embed T.Text where
   65   embedExp t = [| T.pack $(litE $ stringL $ T.unpack t) |]
   66 
   67 instance Embed Name where
   68   embedExp n = [| mkName $(litE $ stringL $ maybe "" (++ ".") (nameModule n) ++ nameBase n) |]
   69 
   70 instance Embed B.ByteString where
   71   embedExp bytes = [| unsafePerformIO $(embedIOExp bytes) |]
   72 
   73 instance Embed BL.ByteString where
   74   embedExp bytes = [| unsafePerformIO $(embedIOExp bytes) |]
   75 
   76 instance Embed a => Embed (V.Vector a) where
   77   embedExp v = [| V.fromList $(embedExp $ V.toList v) |]
   78 
   79 instance Embed a => Embed [a] where
   80   embedExp a = listE $ map embedExp a
   81 
   82 instance (Embed a, Embed b) => Embed (a, b) where
   83   embedExp (a, b) = [| ($(embedExp a), $(embedExp b)) |]
   84 
   85 instance (Embed a, Embed b, Embed c) => Embed (a, b, c) where
   86   embedExp (a, b, c) = [| ($(embedExp a), $(embedExp b), $(embedExp c)) |]
   87 
   88 instance (Embed a, Embed b, Embed c, Embed d) => Embed (a, b, c, d) where
   89   embedExp (a, b, c, d) = [| ($(embedExp a), $(embedExp b), $(embedExp c), $(embedExp d)) |]
   90 
   91 -- | Class of data may be embedded.
   92 -- An embedded expression is of type IO a.
   93 class EmbedIO a where
   94   -- | Construct an expression for the data (of type 'IO a').
   95   embedIOExp :: a -> Q Exp
   96 
   97 instance EmbedIO Int where
   98   embedIOExp n = [| return $(embedExp n) |]
   99 
  100 instance EmbedIO Bool where
  101   embedIOExp b = [| return $(embedExp b) |]
  102 
  103 instance EmbedIO B.ByteString where
  104   embedIOExp bytes = do
  105     let len = B.length bytes
  106     [| B.unsafePackAddressLen len $(litE $ stringPrimL $ B.unpack bytes) |]
  107 
  108 instance EmbedIO BL.ByteString where
  109   embedIOExp bytes = do
  110     let len = BL.length bytes
  111     [| BL.fromStrict <$> B.unsafePackAddressLen len $(litE $ stringPrimL $ BL.unpack bytes) |]
  112 
  113 instance EmbedIO a => EmbedIO [a] where
  114   embedIOExp a = [| sequence $(listE $ map embedIOExp a) |]
  115 
  116 instance (EmbedIO a, EmbedIO b) => EmbedIO (a, b) where
  117   embedIOExp (a, b) = [| do
  118     av <- $(embedIOExp a)
  119     bv <- $(embedIOExp b)
  120     return (av, bv)
  121     |]
  122 
  123 instance (EmbedIO a, EmbedIO b, EmbedIO c) => EmbedIO (a, b, c) where
  124   embedIOExp (a, b, c) = [| do
  125     av <- $(embedIOExp a)
  126     bv <- $(embedIOExp b)
  127     cv <- $(embedIOExp c)
  128     return (av, bv, cv)
  129     |]
  130 
  131 instance (EmbedIO a, EmbedIO b, EmbedIO c, EmbedIO d) => EmbedIO (a, b, c, d) where
  132   embedIOExp (a, b, c, d) = [| do
  133     av <- $(embedIOExp a)
  134     bv <- $(embedIOExp b)
  135     cv <- $(embedIOExp c)
  136     dv <- $(embedIOExp d)
  137     return (av, bv, cv, dv)
  138     |]
  139 
  140 -- | Embed string as an expression.
  141 embedStringExp :: String -> Q Exp
  142 embedStringExp s = litE $ stringL s
  143 
  144 -- | EmbedIO file data as an expression.
  145 fileExp :: FilePath -> Q Exp
  146 fileExp filePath = embedIOExp =<< loadFile filePath
  147 
  148 -- | Pack storable list to bytestring.
  149 packList :: Storable a => [a] -> B.ByteString
  150 packList vs = unsafePerformIO $ do
  151   let len = length vs
  152   bytesPtr <- mallocArray len
  153   pokeArray bytesPtr vs
  154   B.unsafePackMallocCStringLen (castPtr bytesPtr, len * sizeOf (head vs))
  155 
  156 -- | Pack storable vector to bytestring.
  157 packVector :: (Storable a, VG.Vector v a) => v a -> B.ByteString
  158 packVector v = unsafePerformIO $ do
  159   let len = VG.length v
  160   bytesPtr <- mallocArray len
  161   VS.unsafeWith (VG.convert v) $ \vecPtr -> copyArray bytesPtr vecPtr len
  162   B.unsafePackMallocCStringLen (castPtr bytesPtr, len * sizeOf (VG.head v))
  163 
  164 -- | Unpack storable vector from bytestring.
  165 unpackVector :: (Storable a, VG.Vector v a) => B.ByteString -> v a
  166 unpackVector bytes = unsafePerformIO $ wu $ \u -> B.unsafeUseAsCStringLen bytes $ \(ptr, len) -> VG.generateM (len `quot` sizeOf u) $ peekElemOff $ castPtr ptr
  167   where
  168     wu :: (a -> IO (v a)) -> IO (v a)
  169     wu m = m undefined
  170 
  171 -- | Null-terminated string literal (of type Ptr CChar).
  172 embedCStringExp :: String -> Q Exp
  173 embedCStringExp str = [| GHC.Ptr $(litE $ stringPrimL $ B.unpack (T.encodeUtf8 $ T.pack str) ++ [0]) :: Ptr CChar |]
  174 
  175 -- | Generate Embed instance for ADT.
  176 {- Example:
  177 
  178 data A a => T a
  179   = T1 a
  180   | T2 { f1 :: a, f2 :: a }
  181   | a :* a
  182 
  183 genEmbed ''T:
  184 
  185 instance A a => Embed (T a) where
  186   embedExp x = case x of
  187     T1 x1 -> appE (conE (mkName "T1")) (embedExp x1)
  188     T2 { f1 = x1, f2 = x2 } -> do
  189       e1 <- embedExp x1
  190       e2 <- embedExp x2
  191       recConE (mkName "T2")
  192         [ return (mkName "f1", e1)
  193         , return (mkName "f2", e2)
  194         ]
  195     x1 :* x2 -> uInfixE (embedExp x1) (varE (mkName ":*")) (embedExp x2)
  196 
  197 -}
  198 genEmbed :: Name -> Q [Dec]
  199 genEmbed dn = do
  200   info <- reify dn
  201   case info of
  202     TyConI (DataD dataContext dataName tvbs _mkind cons _derivings) -> process dataContext dataName tvbs cons
  203     TyConI (NewtypeD dataContext dataName tvbs _mkind con _derivings) -> process dataContext dataName tvbs [con]
  204     _ -> fail $ show ("unsupported declaration for embedding", info)
  205   where
  206   process dataContext dataName tvbs cons = do
  207     let
  208       tvns = [case tvb of
  209         PlainTV n -> n
  210         KindedTV n _k -> n
  211         | tvb <- tvbs]
  212       embedMatch con = case con of
  213         NormalC conName sts -> do
  214           xs <- mapM (newName . snd) $ zip sts ["x" ++ show (n :: Int) | n <- [1..]]
  215           let
  216             body = normalB $ foldl
  217               (\a b -> [| appE $a $b |])
  218               [| conE $(embedExp conName) |]
  219               (map (\v -> [| embedExp $(varE v) |]) xs)
  220           match (conP conName $ map varP xs) body []
  221         RecC conName vsts -> do
  222           xs <- forM [n | (n, _s, _t) <- vsts] $ \n -> do
  223             xn <- newName $ nameBase n
  224             en <- newName $ "e" ++ nameBase n
  225             return (n, xn, en)
  226           let
  227             enStmt (_n, xn, en) = bindS (varP en) [| embedExp $(varE xn) |]
  228             fExp (n, _xn, en) = [| return ($(embedExp n), $(varE en)) |]
  229             body = normalB $ doE $ map enStmt xs ++
  230               [noBindS [| recConE $(embedExp conName) $(listE $ map fExp xs) |]]
  231           match (recP conName [return (n, VarP xn) | (n, xn, _en) <- xs]) body []
  232         InfixC _st1 conName _st2 -> do
  233           x1 <- newName "x1"
  234           x2 <- newName "x2"
  235           let
  236             body = normalB [| uInfixE (embedExp $(varE x1)) (conE $(embedExp conName)) (embedExp $(varE x2)) |]
  237           match (infixP (varP x1) conName (varP x2)) body []
  238         ForallC _tvbs _cxt c -> embedMatch c
  239     x <- newName "x"
  240     sequence
  241       [ instanceD (return dataContext) (appT (conT ''Embed) $ foldl (\a b -> appT a (varT b)) (conT dataName) tvns)
  242         [ funD 'embedExp
  243           [ clause [varP x] (normalB $ caseE (varE x) $ map embedMatch cons) []
  244           ]
  245         ]
  246       ]