llvm-dsl 0.1 → 0.1.1

raw patch · 3 files changed

+150/−2 lines, 3 filesdep ~llvm-extradep ~llvm-tf

Dependency ranges changed: llvm-extra, llvm-tf

Files

• llvm-dsl.cabal +4/−2
• src/LLVM/DSL/Render/Argument.hs +74/−0
• src/LLVM/DSL/Render/Run.hs +72/−0

@@ -1,6 +1,6 @@ Cabal-Version:  2.2 Name:           llvm-dsl-Version:        0.1+Version:        0.1.1 License:        BSD-3-Clause License-File:   LICENSE Author:         Henning Thielemann <haskell@henning-thielemann.de>@@ -33,7 +33,7 @@   Location: https://hub.darcs.net/thielema/llvm-dsl/  Source-Repository this-  Tag:      0.1+  Tag:      0.1.1   Type:     darcs   Location: https://hub.darcs.net/thielema/llvm-dsl/ @@ -72,6 +72,8 @@     LLVM.DSL.Value     LLVM.DSL.Parameter     LLVM.DSL.Execution+    LLVM.DSL.Render.Run+    LLVM.DSL.Render.Argument     LLVM.DSL.Debug.Counter     LLVM.DSL.Debug.StablePtr     LLVM.DSL.Debug.Marshal

@@ -0,0 +1,74 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ExistentialQuantification #-}+module LLVM.DSL.Render.Argument (+   T(Cons),+   Creator,+   unit,+   primitive,+   pair,+   triple,+   newDispose,+   ) where++import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Multi.Value.Marshal as Marshal++import Data.Tuple.Strict (mapPair, mapTriple)++import Prelude2010+import Prelude ()++++type Creator p = IO (p, IO ())+++{- |+Transfer 'a' to 'adsl' with 'al' as transit stop.+-}+data T a adsl =+   forall al. Marshal.C al =>+   Cons (Exp al -> adsl) (a -> Creator al)+++primitiveCreator :: a -> Creator a+primitiveCreator a = return (a, return ())++unit :: T () ()+unit = Cons (\ _unit -> ()) primitiveCreator++primitive :: (Marshal.C a) => T a (Exp a)+primitive = Cons id primitiveCreator+++pair :: T a ad -> T b bd -> T (a,b) (ad,bd)+pair (Cons passA createA) (Cons passB createB) =+   Cons+      (mapPair (passA,passB) . Expr.unzip)+      (\(a,b) -> do+         (pa,finalA) <- createA a+         (pb,finalB) <- createB b+         return ((pa,pb), finalB>>finalA))++triple :: T a ad -> T b bd -> T c cd -> T (a,b,c) (ad,bd,cd)+triple (Cons passA createA) (Cons passB createB) (Cons passC createC) =+   Cons+      (mapTriple (passA,passB,passC) . Expr.unzip3)+      (\(a,b,c) -> do+         (pa,finalA) <- createA a+         (pb,finalB) <- createB b+         (pc,finalC) <- createC c+         return ((pa,pb,pc), finalC>>finalB>>finalA))+++newDispose ::+   (Marshal.C handle) =>+   (a -> IO handle) -> (handle -> IO ()) ->+   (Exp handle -> ad) -> T a ad+newDispose new dispose fetch =+   Cons fetch+      (\x -> do+         it <- new x+         return (it, dispose it))

@@ -0,0 +1,72 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Rank2Types #-}+{- |+Apply operations on symbolic arrays to physical ones.++This is an approach with no pre-defined direction of type dependencies.+-}+module LLVM.DSL.Render.Run (+   T(Cons, decons),+   postmapPlain,+   premapDSL,+   Creator,+   run,+   (*->),+   ) where++import qualified LLVM.DSL.Render.Argument as Arg+import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Render.Argument (Creator)+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Multi.Value.Marshal as Marshal++import Prelude2010+import Prelude ()++++{-+Type order of 'f' and 'fdsl' is consistent with 'run',+but inconsistent with 'Arg.T'.+-}+newtype T m p fdsl f =+   Cons {decons :: (Exp p -> fdsl) -> m (Creator p -> f)}++{-+We could turn this into an 'Functor'/'fmap' instance,+however this is less descriptive and+would require to keep the current type parameter order.+-}+postmapPlain :: Functor m => (f -> g) -> T m p fdsl f -> T m p fdsl g+postmapPlain f build = Cons $ fmap (f .) . decons build++premapDSL :: (gdsl -> fdsl) -> T m p fdsl f -> T m p gdsl f+premapDSL f build = Cons $ decons build . fmap f+++-- ToDo: duplicate of Argument+primitiveCreator :: a -> Creator a+primitiveCreator a = return (a, return ())++run :: (Functor m) => T m () fdsl f -> fdsl -> m f+run (Cons build) f = fmap ($ primitiveCreator ()) $ build $ const f+++-- precedence like Applicative.<*>, but different associativity+infixr 4 *->++(*->) ::+   (Functor m) =>+   Arg.T a adsl ->+   (forall al. Marshal.C al => T m (p, al) fdsl f) ->+   T m p (adsl -> fdsl) (a -> f)+(*->) arg build = Cons $ \f ->+   case arg of+      Arg.Cons pass createA ->+         fmap+            (\g createP av ->+               g (do (p,finalP) <- createP+                     (pa,finalA) <- createA av+                     return ((p,pa), finalA >> finalP)))+            (decons build (Expr.uncurry $ \p -> f p . pass))