packages feed

ivory-bitdata (empty) → 0.2.0.0

raw patch · 16 files changed

+1387/−0 lines, 16 filesdep +basedep +ivorydep +ivory-backend-csetup-changed

Dependencies added: base, ivory, ivory-backend-c, ivory-bitdata, monadLib, parsec, template-haskell

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Galois, Inc.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Galois, Inc. nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Example.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Example where++import Control.Monad++import Ivory.Language+-- import Ivory.Compile.C+import Ivory.Compile.C.CmdlineFrontend++import Ivory.BitData+import ExampleTypes++[bitdata|++ bitdata SPI_CR1 :: Bits 16 = spi_cr1+   { spi_cr1_bidimode :: Bit+   , spi_cr1_bidioe   :: Bit+   , spi_cr1_crcen    :: Bit+   , spi_cr1_crcnext  :: Bit+   , spi_cr1_dff      :: Bit+   , spi_cr1_rxonly   :: Bit+   , spi_cr1_ssm      :: Bit+   , spi_cr1_ssi      :: Bit+   , spi_cr1_lsbfirst :: Bit+   , spi_cr1_spe      :: Bit+   , spi_cr1_br       :: SPIBaud+   , spi_cr1_mstr     :: Bit+   , spi_cr1_cpol     :: Bit+   , spi_cr1_cpha     :: Bit+   }++ -- The "SPI_CR2" register defined using a layout clause.+ bitdata SPI_CR2 :: Bits 16 = spi_cr2+   { spi_cr2_txeie    :: Bit+   , spi_cr2_rxneie   :: Bit+   , spi_cr2_errie    :: Bit+   , spi_cr2_frf      :: Bit+   , spi_cr2_ssoe     :: Bit+   , spi_cr2_txdmaen  :: Bit+   , spi_cr2_rxdmaen  :: Bit+   } as 8b0 # spi_cr2_txeie # spi_cr2_rxneie # spi_cr2_errie # spi_cr2_frf+      # 1b0 # spi_cr2_ssoe # spi_cr2_txdmaen # spi_cr2_rxdmaen++ -- The "SPI_CR2" register defined using the default layout and+ -- padding fields.+ bitdata Alt_SPI_CR2 :: Bits 16 = alt_spi_cr2+   { _                    :: Bits 8+   , alt_spi_cr2_txeie    :: Bit+   , alt_spi_cr2_rxneie   :: Bit+   , alt_spi_cr2_errie    :: Bit+   , alt_spi_cr2_frf      :: Bit+   , _                    :: Bit+   , alt_spi_cr2_ssoe     :: Bit+   , alt_spi_cr2_txdmaen  :: Bit+   , alt_spi_cr2_rxdmaen  :: Bit+   }++ -- The "NVIC_ISER" register is an array of 32 bits.+ --+ -- We will want to access the array both at Ivory run-time using an+ -- "Ix 32" and at code generation time using a Haskell integer.+ bitdata NVIC_ISER :: Bits 32 = nvic_iser+   { nvic_iser_setena :: BitArray 32 Bit+   }++ -- A bit data type with an array of 4-bit integers.+ bitdata ArrayTest :: Bits 32 = array_test+   { at_4bits :: BitArray 8 (Bits 4)+   }+|]++test1 :: Def ('[Uint16] :-> Uint16)+test1 = proc "test1" $ \x -> body $ do+  ret $ withBits x $ do+        clearBit spi_cr1_cpha+        setBit   spi_cr1_cpol+        setField spi_cr1_br spi_baud_div_8++test2 :: Def ('[Uint32] :-> Uint8)+test2 = proc "test2" $ \x -> body $ do+  let d = fromRep x :: NVIC_ISER+  ret $ toRep (d #. nvic_iser_setena #! 0)++-- | Iterate over the elements of a bit array.+forBitArray_ arr f =+  forM_ [0..bitLength arr] $ \i ->+    f (arr #! i)++-- | Test looping over the elements of a bit array:+test3 :: Def ('[Uint32] :-> Uint32)+test3 = proc "test3" $ \x -> body $ do+  let d = fromRep x+  total <- local (ival 0)+  forBitArray_ (d #. at_4bits) $ \i -> do+    x' <- deref total+    let y = safeCast (toRep i)+    store total (x' + y)+  ret =<< deref total++get_baud :: Def ('[Uint16] :-> Uint8)+get_baud = proc "get_baud" $ \x -> body $ do+  let d = fromRep x+  ret (toRep (d #. spi_cr1_br))++cmodule :: Module+cmodule = package "hw" $ do+  incl get_baud+  incl test1+  incl test2+  incl test3++main :: IO ()+main = runCompiler [cmodule] (initialOpts {stdOut = True, constFold = True})
+ examples/ExampleTypes.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module ExampleTypes where++import Ivory.BitData++[bitdata|+ bitdata SPIBaud :: Bits 3+   = spi_baud_div_2   as 0+   | spi_baud_div_4   as 1+   | spi_baud_div_8   as 2+   | spi_baud_div_16  as 3+   | spi_baud_div_32  as 4+   | spi_baud_div_64  as 5+   | spi_baud_div_128 as 6+   | spi_baud_div_256 as 7+|]
+ examples/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import qualified Example as E++main :: IO ()+main = E.main
+ ivory-bitdata.cabal view
@@ -0,0 +1,61 @@+-- Initial ivory-bitdata.cabal generated by cabal init.  For further+-- documentation, see http://haskell.org/cabal/users-guide/++name:                ivory-bitdata+version:             0.2.0.0+-- synopsis:+-- description:+license:             BSD3+license-file:        LICENSE+author:              Galois, Inc.+maintainer:          jamesjb@galois.com+copyright:           2013 Galois, Inc.+category:            Language+build-type:          Simple+cabal-version:       >=1.10+synopsis:            Ivory bit-data support.+description:         See the paper http://yav.github.io/publications/bitdata.pdf+homepage:            http://smaccmpilot.org/languages/ivory-introduction.html+build-type:          Simple+cabal-version:       >= 1.10+license:             BSD3+license-file:        LICENSE+source-repository    this+  type:     git+  location: https://github.com/GaloisInc/ivory+  tag:      hackage-bitdata-0200+++library+  exposed-modules:     Ivory.BitData,+                       Ivory.BitData.Bits,+                       Ivory.BitData.BitData,+                       Ivory.BitData.Array,+                       Ivory.BitData.Monad,+                       Ivory.BitData.Quote+  other-modules:       Ivory.BitData.DefBitRep,+                       Ivory.BitData.AST,+                       Ivory.BitData.TokenParser,+                       Ivory.BitData.Parser,+                       Example,+                       ExampleTypes+  hs-source-dirs:      src, examples+  build-depends:       base >= 4.6 && < 4.7,+                       ivory,+                       ivory-backend-c,+                       monadLib,+                       template-haskell,+                       parsec+  default-language:    Haskell2010+  ghc-options:         -Wall++executable ivory-bitdata-example+  main-is:             Main.hs+  other-modules:       Example,+                       ExampleTypes+  hs-source-dirs:      examples+  default-language:    Haskell2010+  build-depends:       base >= 4.6,+                       ivory-bitdata,+                       ivory,+                       ivory-backend-c
+ src/Ivory/BitData.hs view
@@ -0,0 +1,53 @@+--+-- BitData.hs --- Top-level module for ivory-bitdata.+--+-- Copyright (C) 2013, Galois, Inc.+-- All Rights Reserved.+--++module Ivory.BitData (+  -- * quasiquoter+  bitdata++  -- * bit types+  , Bits(), Bit, BitArray(), BitRep()+  , repToBits, bitsToRep, zeroBits+  , bitLength, bitIx++  -- * bit data+  , BitData(), BitDataField(), BitDataRep++  -- * bit data conversions+  , toBits, fromBits+  , toRep, fromRep++  -- * bit data field operations+  , setBitDataBit, clearBitDataBit, getBitDataField, setBitDataField++  -- * bit data operators+  , (#!) -- access nth element of BitArray+  , (#.) -- flip getBitDataField+  , (#>) -- BitDataField composition (like Control.Category.>>>)++  -- * bit actions+  , BitDataM(), runBits, withBits, withBitsRef+  , clear, setBit, clearBit, setField+  , bitToBool, boolToBit+) where++import Ivory.BitData.Bits+import Ivory.BitData.BitData+import Ivory.BitData.Array+import Ivory.BitData.Quote+import Ivory.BitData.Monad++import Ivory.Language++-- | Convert a single bit bitdata to an Ivory boolean.+bitToBool :: Bit -> IBool+bitToBool b = (toRep b ==? 0) ? (false, true)++-- | Convert an Ivory boolean to a single bit.+boolToBit :: IBool -> Bit+boolToBit b = b ? (fromRep 1, fromRep 0)+
+ src/Ivory/BitData/AST.hs view
@@ -0,0 +1,48 @@+--+-- AST.hs --- HW quasiquoter AST.+--+-- Copyright (C) 2013, Galois, Inc.+-- All Rights Reserved.+--++module Ivory.BitData.AST where++-- | Basic type representation allowed in bit definitions.+data BitTy = TyCon String+           | TyNat Integer+           | TyApp BitTy BitTy+  deriving Show++-- | A bit integer literal with a known or unknown size.+data BitLiteral =+    BitLitKnown   { bitLitLen :: Int , bitLitVal :: Int }+  | BitLitUnknown { bitLitVal :: Int }+ deriving Show++-- | One element of a bit data constructor layout.+data LayoutItem = LayoutConst BitLiteral+                | LayoutField String+  deriving Show++-- | A constructor layout is a list of layout items.+type Layout = [LayoutItem]++-- | A "bitdata" definition.+data Def = Def+  { defName    :: String+  , defType    :: BitTy+  , defConstrs :: [Constr]+  }++-- | A constructor definition within a "bitdata".+data Constr = Constr+  { constrName   :: String+  , constrFields :: [Field]+  , constrLayout :: Layout+  }++-- | A record-like field defined within a "bitdata" constructor.+data Field = Field+  { fieldName :: String+  , fieldType :: BitTy+  }
+ src/Ivory/BitData/Array.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE UndecidableInstances #-}+--+-- Array.hs --- Bit data array types.+--+-- Copyright (C) 2013, Galois, Inc.+-- All Rights Reserved.+--++module Ivory.BitData.Array where++import GHC.TypeLits++import Ivory.Language+import Ivory.BitData.Bits+import Ivory.BitData.BitData++-- NOTE: This type family is used to calculate the total size of a bit+-- array by multiplying "n" by the size of "a" in bits.  Once we have+-- the type-nats solver in place, we should no longer need this.+--+-- The quasiquoter may generate multiple instances of "ArraySize" with+-- the same "n", "a" and result, which is allowed by the type family+-- overlapping rules.  It does seem like a bit of a hack though.+type family ArraySize (n :: Nat) (a :: *) :: Nat++-- | An array of "n" bit data elements of type "a".+data BitArray (n :: Nat) a = BitArray { unArray :: Bits (ArraySize n a) }++-- | Return the number of elements in a "BitArray".+bitLength :: forall a n. SingI n => BitArray n a -> Int+bitLength _ = fromIntegral (fromSing (sing :: Sing n))++instance (SingI n,+          SingI (ArraySize n a),+          BitData a,+          IvoryRep (BitRep (ArraySize n a)))+    => BitData (BitArray n a) where+  type BitType (BitArray n a) = Bits (ArraySize n a)+  toBits = unArray+  fromBits = BitArray++-- | Return the "n"th element of a "BitArray".+(#!) :: forall a n.+        (BitData a,+         SingI n,+         SingI (BitSize a),+         SingI (ArraySize n a),+         BitCast (BitRep (ArraySize n a)) (BitDataRep a),+         IvoryRep (BitRep (ArraySize n a)))+     => BitArray n a -> Int -> a+BitArray bits #! i =+  if (i < 0) || (i >= n')+    then error "bit array index out of bounds"+    else bits #. field+  where+    n'       = fromIntegral (fromSing (sing :: Sing n)) :: Int+    elemSize = fromIntegral (fromSing (sing :: Sing (BitSize a))) :: Int+    field    = BitDataField (i * elemSize) elemSize++-- | Return a "BitDataField" that accesses the "n"th element of a+-- "BitArray".  This can be composed with other field accessors using+-- "#>".+bitIx :: forall a n.+         (BitData a,+          SingI n,+          SingI (BitSize a),+          SingI (ArraySize n a))+      => Int -> BitDataField (BitArray n a) a+bitIx i = BitDataField (i * elemSize) elemSize+  where+    elemSize = fromIntegral (fromSing (sing :: Sing (BitSize a))) :: Int
+ src/Ivory/BitData/BitData.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE UndecidableInstances #-}+--+-- BitData.hs --- Typed bit data types.+--+-- Copyright (C) 2013, Galois, Inc.+-- All Rights Reserved.+--++module Ivory.BitData.BitData where++import GHC.TypeLits+import Ivory.Language++import Ivory.BitData.Bits++-- | Class of bit data types defined by the "bitdata" quasiquoter.+class (SingI (BitSize (BitType a)),+       IvoryRep (BitDataRep a),+       BitType a ~ Bits (BitSize (BitType a))) => BitData a where+  -- | Return the base "(Bits n)" type as defined in the "bitdata"+  -- quasiquoter.+  type BitType a :: *++  -- | Convert a bit data type to its raw bit value.  This is always+  -- well defined and should be exported.+  toBits :: a -> BitType a++  -- | Convert a raw bit value to a bit data type.  All values may not+  -- be well defined with respect to the original set of bit data+  -- constructors.  For now, we allow these "junk" values to be+  -- created, but that may change in the future (perhaps by+  -- implementing a checked, Ivory run-time conversion).+  fromBits :: BitType a -> a++-- | The Ivory type that stores the actual value for a bit data type.+--+-- This is a shorthand to simplify the constraints on functions that+-- take arguments of the "BitData" class.+type BitDataRep a = BitRep (BitSize (BitType a))++-- | Convert a raw Ivory type to a bit data type.  If the input value+-- is too large, the out of range upper bits will be masked off.+fromRep :: BitData a => BitDataRep a -> a+fromRep = fromBits . repToBits++-- XXX do not export---used when unwrapping/rewrapping values when+-- setting fields and the size has obviously not changed.+unsafeFromRep :: BitData a => BitDataRep a -> a+unsafeFromRep = fromBits . unsafeRepToBits++-- | Convert a bit data value to its Ivory representation.+toRep :: BitData a => a -> BitDataRep a+toRep = unBits . toBits++-- | Identity instance of "BitData" for the base "Bits n" type.+instance (SingI n, IvoryRep (BitRep n)) => BitData (Bits n) where+  type BitType (Bits n) = Bits n+  toBits = id+  fromBits = id++-- | Description of a bit field defined by the "bitdata" quasiquoter.+-- Each field defined in the record syntax will generate a top-level+-- definition of "BitDataField".+--+-- This constructor must remain unexported so that only fields checked+-- by the quasiquoter are created.+data BitDataField a b = BitDataField+  { bitDataFieldPos :: Int+  , bitDataFieldLen :: Int+  } deriving Show++-- | Bit data field composition.  (like Control.Category.>>>)+(#>) :: BitDataField a b -> BitDataField b c -> BitDataField a c+(BitDataField p1 _) #> (BitDataField p2 l2) = BitDataField pos len+  where+    pos = p1 + p2+    len = l2++-- | Extract a field from a bit data definition.  Returns the value as+-- the type defined on the right hand side of the field definition in+-- the "bitdata" quasiquoter.+getBitDataField :: (BitData a, BitData b,+                    BitCast (BitDataRep a) (BitDataRep b))+                => BitDataField a b -> a -> b+getBitDataField f x = unsafeFromRep (bitCast ((toRep x `iShiftR` pos) .& mask))+  where pos  = fromIntegral (bitDataFieldPos f)+        mask = fromIntegral ((2 ^ bitDataFieldLen f) - 1 :: Integer)++-- | Infix operator to read a bit data field.  (like Data.Lens.^.)+(#.) :: (BitData a, BitData b,+         BitCast (BitDataRep a) (BitDataRep b))+     => a -> BitDataField a b -> b+(#.) = flip getBitDataField++-- | Set a field from a bit data definition.+setBitDataField :: (BitData a, BitData b,+                    SafeCast (BitDataRep b) (BitDataRep a))+                => BitDataField a b -> a -> b -> a+setBitDataField f x y = unsafeFromRep ((toRep x .& mask) .| val)+  where val  = safeCast (toRep y) `iShiftL` pos+        pos  = fromIntegral (bitDataFieldPos f)+        fmax = fromIntegral ((2 ^ bitDataFieldLen f) - 1 :: Integer)+        mask = iComplement (fmax `iShiftL` pos)++-- | Set a single-bit field in a bit data value.+setBitDataBit :: BitData a => BitDataField a Bit -> a -> a+setBitDataBit f x = unsafeFromRep (toRep x .| (1 `iShiftL` pos))+  where pos = fromIntegral (bitDataFieldPos f)++-- | Clear a single-bit field in a bit data value.+clearBitDataBit :: BitData a => BitDataField a Bit -> a -> a+clearBitDataBit f x = unsafeFromRep (toRep x .& (iComplement (1 `iShiftL` pos)))+  where pos = fromIntegral (bitDataFieldPos f)
+ src/Ivory/BitData/Bits.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++--+-- Bits.hs --- Bit-sized unsigned integer types.+--+-- Copyright (C) 2013, Galois, Inc.+-- All Rights Reserved.+--++module Ivory.BitData.Bits where++import GHC.TypeLits+import Ivory.Language++import Ivory.BitData.DefBitRep++----------------------------------------------------------------------+-- Bit Representations++-- | Type function: "BitRep (n :: Nat)" returns an Ivory type given a+-- bit size as a type-level natural.  Instances of this type family+-- for bits [1..64] are generated using Template Haskell.+type family BitRep (n :: Nat) :: *++defBitRep ''BitRep ''Uint8  [1..8]+defBitRep ''BitRep ''Uint16 [9..16]+defBitRep ''BitRep ''Uint32 [17..32]+defBitRep ''BitRep ''Uint64 [33..64]++-- | Set of constraints we require on a bit representation type.+type IvoryRep a = (IvoryBits a, IvoryOrd a, IvoryInit a,+                   IvoryStore a, IvoryType a)++----------------------------------------------------------------------+-- Bit Data Type++-- | A wrapper for an Ivory type that can hold an "n" bit unsigned+-- integer.+newtype Bits (n :: Nat) = Bits { unBits :: BitRep n }++deriving instance (IvoryRep (BitRep n)) => IvoryType (Bits n)+deriving instance (IvoryRep (BitRep n)) => IvoryVar  (Bits n)+deriving instance (IvoryRep (BitRep n)) => IvoryExpr (Bits n)+deriving instance (IvoryRep (BitRep n)) => IvoryEq   (Bits n)++-- | "Bit" is a type alias for "Bits 1".+type Bit = Bits 1++-- | Type function to extract the "n" from a "Bits n" type.+type family BitSize a :: Nat+type instance BitSize (Bits n) = n++-- | Convert a Haskell integer to a bit data value without bounds+-- checking.  This must not be exported, but is used by the+-- quasiquoter when the values are constant at compile-time and+-- already bounds checked.+unsafeIntToBits :: (IvoryRep (BitRep n), Integral a) => a -> Bits n+unsafeIntToBits = Bits . fromIntegral++-- | Return a bit value of all zeros of the given size.+zeroBits :: (IvoryRep (BitRep n)) => Bits n+zeroBits = Bits 0++-- XXX do not export, used when unwrapping/rewrapping values when+-- setting fields and the size has obviously not changed.+unsafeRepToBits :: BitRep n -> Bits n+unsafeRepToBits = Bits++-- | Convert an Ivory value to a bit value.  If the input value+-- contains out of range bits, they will be ignored.+repToBits :: forall n. (SingI n, IvoryRep (BitRep n))+          => BitRep n -> Bits n+repToBits x = Bits (x .& mask)+  where mask = fromIntegral (2 ^ fromSing (sing :: Sing n) - 1 :: Integer)++-- | Convert a bit value to an Ivory value.+bitsToRep :: Bits n -> BitRep n+bitsToRep = unBits
+ src/Ivory/BitData/DefBitRep.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE TemplateHaskell #-}+--+-- DefBitRep.hs --- Template Haskell utilities.+--+-- Copyright (C) 2013, Galois, Inc.+-- All Rights Reserved.+--++module Ivory.BitData.DefBitRep where++import Language.Haskell.TH++-- | Define the type instance:+--+--   type instance <fname> <x> = <rname>+--+-- for each "n" in "xs".+--+-- Used to define the set of representation types for bit lengths.+defBitRep :: Name -> Name -> [Integer] -> DecsQ+defBitRep fname rname xs = return $ map go xs+  where go n = TySynInstD fname [LitT (NumTyLit n)] (ConT rname)
+ src/Ivory/BitData/Monad.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+--+-- Monad.hs --- Bit field modification Monad.+--+-- Copyright (C) 2013, Galois, Inc.+-- All Rights Reserved.+--++module Ivory.BitData.Monad where++import Ivory.Language++import qualified MonadLib.Monads as M++import Ivory.BitData.Bits+import Ivory.BitData.BitData++-- | An action that modifies a bit data value of type "d" and returns+-- a "a" in the "Ivory s r" monad.  Values of this type are passed as+-- the "body" argument to "withBits" etc.+newtype BitDataM d a = BitDataM { runBitDataM :: M.State d a }+  deriving (Functor, Monad)++-- | Clear the value of the current bit data value.+clear :: BitData d => BitDataM d ()+clear = return () -- BitDataM $ M.set 0++-- XXX add getField and getBit?  it might get confusing if they are in+-- the monad.++-- | Set a single bit field in the current bit data value.+setBit :: BitData d => BitDataField d Bit -> BitDataM d ()+setBit f = BitDataM $ M.sets_ (setBitDataBit f)++-- | Clear a single bit.+clearBit :: BitData d => BitDataField d Bit -> BitDataM d ()+clearBit f = BitDataM $ M.sets_ (clearBitDataBit f)++-- | Set a field to a value.+setField :: (BitData d, BitData b,+             SafeCast (BitDataRep b) (BitDataRep d))+         => BitDataField d b -> b -> BitDataM d ()+setField f x = BitDataM $ M.sets_ (\v -> setBitDataField f v x)++-- | Execute a bitdata action given an initial value, returning the+-- new bitdata value and the result of the action.+runBits :: BitData d => BitDataRep d -> BitDataM d a -> (a, BitDataRep d)+runBits rep mf = (result, toRep val)+  where (result, val) = M.runState (fromRep rep) (runBitDataM mf)++-- | Execute a bitdata action given an initial value, returning the+-- new bitdata value.+withBits :: BitData d => BitDataRep d -> BitDataM d () -> BitDataRep d+withBits rep mf = snd (runBits rep mf)++-- | Execute a bit data action given a reference to a value, writing+-- the resulting value back to the reference upon completion and+-- returning the result of the action.+withBitsRef :: BitData d+            => Ref s1 (Stored (BitDataRep d))+            -> BitDataM d a+            -> Ivory eff a+withBitsRef ref mf = do+  rep <- deref ref+  let (result, rep') = runBits rep mf+  store ref rep'+  return result
+ src/Ivory/BitData/Parser.hs view
@@ -0,0 +1,159 @@+--+-- Parser.hs --- HW quasiquoter parser.+--+-- Copyright (C) 2013, Galois, Inc.+-- All Rights Reserved.+--++module Ivory.BitData.Parser (+  parseDefs, parseBitLiteral+) where++import Control.Applicative+import Control.Monad (when)+import Data.Char (isUpper, isLower, toLower, digitToInt)+import Data.Maybe (listToMaybe)+import Numeric (readDec, readHex, readInt)+import Text.Parsec ((<?>), chainl1, many1, sepBy, sepBy1, eof,+                    oneOf, option, digit, hexDigit,+                    unexpected, notFollowedBy, letter, alphaNum)+import Text.Parsec.String (Parser)++import Ivory.BitData.AST+import Ivory.BitData.TokenParser++--+-- Bit Literal Syntax+-- ------------------+--+-- We generalize the C syntax for hexadecimal numbers.+--+-- An n-bit binary natural number literal:+--+--   <n>[bB]{0,1}++--+-- An n-bit decimal natural number literal:+--+--   <n>[dD]{0..9}++--+-- An n-bit hexadecimal natural number literal:+--+--   <n>[xX]{0..9a..fA..F}++--++-- | Convert a "ReadS" style parser to a Parsec parser.+liftReadS :: ReadS a -> String -> Parser a+liftReadS f = maybe (unexpected "no parse") (return . fst) .+              listToMaybe . filter (null . snd) . f++-- | Parse a binary digit.+binDigit :: Parser Char+binDigit = oneOf "01"++-- | Convert a string containing a base 2 number to a number.+readBin :: (Eq a, Num a) => ReadS a+readBin = readInt 2 (`elem` "01") digitToInt++-- | Parse a list of digits given the bit literal base character.+digitParser :: Char -> Parser Int+digitParser 'b' = many1 binDigit >>= liftReadS readBin+digitParser 'd' = many1 digit    >>= liftReadS readDec+digitParser 'x' = many1 hexDigit >>= liftReadS readHex+digitParser _   = fail "invalid bit literal base character"++-- | Parse the start of a bit literal (see description above).+bitLiteral :: Parser BitLiteral+bitLiteral = (lexeme $ do+  size <- many1 digit >>= liftReadS readDec+  (bitLiteralTail size <|> return (BitLitUnknown size))+    <* notFollowedBy alphaNum) <?> "bit literal"++-- | Parse the optional tail of a bit literal.+bitLiteralTail :: Int -> Parser BitLiteral+bitLiteralTail size = do+  -- The use of "letter" rather than "oneOf" here is a little subtle.+  --+  -- We don't want the parser to fail without consuming input if there+  -- is a bad base character, because then the "BitLitUnknown"+  -- alternative in the caller will be used.  We want to make sure we+  -- generate the right error in "digitParser", so accept any letter+  -- even if we know it's wrong at this time.+  baseChar <- toLower <$> letter -- oneOf "bBdDxX"+  value    <- digitParser baseChar+  if size == 0+    then return $ BitLitUnknown value+    else do+      when (value >= 2 ^ size) $+        fail "bit literal out of range"+      return $ BitLitKnown size value++-- | Standalone parser for a bit literal.+parseBitLiteral :: Parser BitLiteral+parseBitLiteral = whiteSpace *> bitLiteral <* eof++-- | Parse a Haskell type or type constructor name.+typeName :: Parser String+typeName = do+  x <- identifier+  if not (isUpper (head x))+    then fail "expecting type or type constructor name"+    else return x++-- | Parse a Haskell value name or "_".+valueName :: Parser String+valueName = valueIdentifier <|> (symbol "_")+  where valueIdentifier = do+          x <- identifier+          if not (isLower (head x))+             then fail "expecting value name"+             else return x++-- | Parse a type (except application).+parseType1 :: Parser BitTy+parseType1 = numTyLit <|> conT <|> parens parseType+  where numTyLit = TyNat <$> natural+        conT     = TyCon <$> typeName++-- | Parse a type that can appear in a bitdata definition.+parseType :: Parser BitTy+parseType = parseType1 `chainl1` (whiteSpace >> return TyApp)++-- | Parse a set of bit data definitions.  This is the top-level+-- parser that is called from the quasiquoter.+parseDefs :: Parser [Def]+parseDefs = whiteSpace *> some parseDef <* eof++-- | Parse a single bit data definition.+parseDef :: Parser Def+parseDef =+  Def <$  symbol "bitdata"+      <*> typeName+      <*  reservedOp "::"+      <*> parseType+      <*  reservedOp "="+      <*> sepBy1 parseConstr (reservedOp "|")++-- | Parse one constructor of a bit data definition.+parseConstr :: Parser Constr+parseConstr =+  Constr <$> valueName+         <*> parseFields+         <*> parseLayout++-- | Parse zero or more fields in a bit data constructor.+parseFields :: Parser [Field]+parseFields = option [] (braces (sepBy parseField comma))++-- | Parse an optional "as" clause for a bit data constructor.+parseLayout :: Parser Layout+parseLayout = option [] (symbol "as" *> body)+  where body = sepBy1 item (reservedOp "#")+        item =  LayoutConst <$> bitLiteral+            <|> LayoutField <$> valueName++-- | Parse one bit data field in a bit data constructor.+parseField :: Parser Field+parseField =+  Field <$> valueName+        <*  reservedOp "::"+        <*> parseType
+ src/Ivory/BitData/Quote.hs view
@@ -0,0 +1,494 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++--+-- Quote.hs --- Bit data quasiquoter.+--+-- Copyright (C) 2013, Galois, Inc.+-- All Rights Reserved.+--++module Ivory.BitData.Quote (bitdata) where++import Control.Monad (MonadPlus, liftM, msum, when, unless, mzero)+import Data.Foldable (find, foldl')+import Data.List (sort)+import Data.Maybe (mapMaybe)+import Data.Traversable (mapAccumL)+import MonadLib (ChoiceT, findOne, lift)+import Text.Parsec (parse, setPosition, getPosition,+                    setSourceLine, setSourceColumn)+import Text.Parsec.String (Parser)++import Language.Haskell.TH+import Language.Haskell.TH.Quote++import Ivory.Language ((.|), iShiftL, safeCast)+import qualified Ivory.Language as I+import Ivory.BitData.AST+import Ivory.BitData.Parser (parseBitLiteral, parseDefs)++import qualified Ivory.BitData.Bits    as B+import qualified Ivory.BitData.BitData as B+import qualified Ivory.BitData.Array   as B++-- | Quasiquoter for defining Ivory bit value and bit data types.+--+-- Only the declaration and expression forms are implemented.+bitdata :: QuasiQuoter+bitdata = QuasiQuoter+       { quoteDec  = bitdataQuoteDec+       , quoteExp  = bitdataQuoteExp+       , quotePat  = error "quotePat not implemented"+       , quoteType = error "quoteType not implemented"+       }++-- | Run a parser on a string, setting the source position information+-- from the location provided by the TH "Q" monad.+qParse :: Parser a -> String -> Q a+qParse parser str = do+  loc <- location+  case parse (body loc) (loc_filename loc) str of+    Right defs -> return defs+    Left err   -> fail (show err)+  where+    body loc = do+      pos <- getPosition+      let (line, col) = loc_start loc+      setPosition (setSourceLine (setSourceColumn pos col) line)+      parser++-- | The 'concatMapM' function generalizes 'concatMap' to arbitrary+-- monads.+concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]+concatMapM f xs = liftM concat (mapM f xs)++-- | Combine a list of items using a "MonadPlus" Monad.  This is used+-- to lift a list of items into a "ChoiceT m a".+anyOf :: MonadPlus m => [a] -> m a+anyOf = msum . map return++----------------------------------------------------------------------+-- Expression Quasiquoter++-- | Parse a bit data literal expression (see the parser module for a+-- description of the syntax).+bitdataQuoteExp :: String -> Q Exp+bitdataQuoteExp str = do+  lit <- qParse parseBitLiteral str+  case lit of+    BitLitKnown len val ->+      let tylen = litT (numTyLit (fromIntegral len)) in+      [| B.unsafeIntToBits (val :: Int) :: B.Bits $tylen |]+    BitLitUnknown val ->+      [| B.repToBits (fromIntegral (val :: Int)) |]++----------------------------------------------------------------------+-- Declaration Quasiquoter++-- | Declaration quasiquoter for "bits".+bitdataQuoteDec :: String -> Q [Dec]+bitdataQuoteDec str = concatMapM mkDef =<< parseDefsQ str++-- | Parse a set of bit data definitions from a string.+parseDefsQ :: String -> Q [Def]+parseDefsQ = qParse parseDefs++----------------------------------------------------------------------+-- AST Annotation++-- | Convert a parser type to a Template Haskell type.+convertType :: BitTy -> Q Type+convertType (TyCon s) = do+  m <- lookupTypeName s+  case m of+    Just ty -> return $ ConT ty+    Nothing -> fail $ "undefined type: " ++ s+convertType (TyNat n) = return $ LitT $ NumTyLit n+convertType (TyApp t1 t2) = do+  t1' <- convertType t1+  t2' <- convertType t2+  return $ AppT t1' t2'++-- | Look up a type and return its size in bits.+getTyBits :: Type -> ChoiceT Q Int+getTyBits ty =+  case ty of+    ConT name+      | name == ''B.Bit -> return 1+      | otherwise       -> tyInsts ''B.BitType ty >>= decBits+    AppT (AppT (ConT name) (LitT (NumTyLit n))) ty2+      | name == ''B.BitArray -> do+         m <- lift $ tyBits ty2+         return (fromIntegral n * m)+    AppT (ConT name) (LitT (NumTyLit n))+      | name == ''B.Bits -> return $ fromIntegral n+      | otherwise        -> mzero+    _ -> mzero+  where+    tyInsts name t = lift (reifyInstances name [t]) >>= anyOf+    decBits (TySynInstD _ _ t) = getTyBits t+    decBits _ = mzero++-- | Return the size in bits of a type that can appear in a bitdata+-- definition.  The allowed forms are "Bit", "Bits n", "Array n t"+-- where "t" is a valid bit data type, or a name defined by "bitdata".+tyBits :: Type -> Q Int+tyBits ty = do+  r <- findOne (getTyBits ty)+  case r of+    Just x  -> return x+    Nothing -> fail "invalid bit value base type"++-- | Deconstruct a bit array type into its size and base type.+-- Returns "Nothing" if the type is not a bit array type.+getArrayType :: Type -> Maybe (Int, Type)+getArrayType (AppT (AppT (ConT name) (LitT (NumTyLit n))) ty)+  | name == ''B.BitArray = Just (fromIntegral n, ty)+getArrayType _ = Nothing++-- | A field definition annotated with its TH name, type, and bit+-- size.+data THField = THField+  { thFieldName :: Name+  , thFieldType :: Type+  , thFieldLen  :: Int+  } deriving Show++-- | Annotate a field definition.+annotateField :: Field -> Q THField+annotateField (Field n t) = do+  ty <- convertType t+  len <- tyBits ty+  return $ THField (mkName n) ty len++-- | A annotated layout item containing a bit literal or a field+-- definition, and the position of the item.+data THLayoutItem =+  THLayoutConst+    { thLayoutValue :: BitLiteral+    , thLayoutPos   :: Int }+  | THLayoutField+    { thLayoutField :: THField+    , thLayoutPos   :: Int }+  deriving Show++-- | A list of annotated layout items.+type THLayout = [THLayoutItem]++-- | Return the default layout given the total bit data size and a+-- list of fields.  If there are no fields, we'll initialize with a+-- zero literal.+defaultLayout :: Int -> [THField] -> THLayout+defaultLayout len [] = [THLayoutConst (BitLitKnown len 0) 0]+defaultLayout _ fs = snd $ mapAccumL go 0 fs+  where+    go pos f+      | thFieldName f == mkName "_"+      , len <- thFieldLen f+        = (pos + len, THLayoutConst (BitLitKnown len 0) pos)+      | otherwise+        = (pos + thFieldLen f, THLayoutField f pos)++-- | Annotate a layout by looking up names in a list of fields and+-- assigning field positions.  If the layout is empty, create a+-- default layout containing all the fields.+--+-- Note that we reverse the fields and layout, since they are in the+-- AST in MSB-first order.  We assign them positions starting from bit+-- 0.+annotateLayout :: Int -> Layout -> [THField] -> THLayout+annotateLayout len [] fs = defaultLayout len (reverse fs)+annotateLayout _ ls fs = snd $ mapAccumL go 0 (reverse ls)+  where+    go pos l =+      case l of+        LayoutConst lit@(BitLitKnown len _)+          -> (pos + len, THLayoutConst lit pos)+        LayoutField name+          | Just f <- find ((== mkName name) . thFieldName) fs+            -> (pos + thFieldLen f, THLayoutField f pos)+        _ -> error "invalid bitdata layout"++-- | Return the size, in bits, of a layout item, given a list of+-- fields with type information.+layoutItemSize :: [THField] -> LayoutItem -> Int+layoutItemSize _ (LayoutConst (BitLitKnown len _)) = len+layoutItemSize _ (LayoutConst (BitLitUnknown _)) = 0+layoutItemSize fs (LayoutField name) =+  case find ((== (mkName name)) . thFieldName) fs of+    Just field -> fromIntegral (thFieldLen field)+    Nothing    -> error "undefined field"++-- | Return the total size of a layout, not including fields with+-- unknown sizes.+layoutSize :: [THField] -> Layout -> Int+layoutSize fs ls = sum (map (layoutItemSize fs) ls)++-- | Return true if a layout item has an unknown size.+hasUnknownSize :: LayoutItem -> Bool+hasUnknownSize (LayoutConst (BitLitUnknown _)) = True+hasUnknownSize _ = False++-- | Update a layout item of unknown size to a known size.+updateSizeL :: Int -> LayoutItem -> LayoutItem+updateSizeL size l =+  case l of+    LayoutConst (BitLitUnknown x) -> LayoutConst (BitLitKnown size x)+    _ -> l++-- | Replace the first layout item with unknown size with the given+-- size.+updateFirstL :: Int -> Layout -> Layout+updateFirstL _ [] = []+updateFirstL size (l:ls)+  | hasUnknownSize l = updateSizeL size l : ls+  | otherwise        = l : updateFirstL size ls++-- | Update bit literals in a constructor' layout, given the size of+-- the bit data definition and the constructor.+--+-- There can be at most a single constant with an unknown size.  If+-- there is more than one, raise an error.  Otherwise, assign it a+-- size if there is one.+updateLiterals :: Int -> [THField] -> Layout -> Q Layout+updateLiterals defLen fs ls = do+  let slop = defLen - layoutSize fs ls+      ls'  = updateFirstL slop ls+  when (any hasUnknownSize ls') $+    fail "multiple unknown size bit fields"+  return ls'++-- | Fold a function over each layout item within a constructor.+foldLayout :: (b -> THLayoutItem -> b) -> b -> THConstr -> b+foldLayout f z c = foldl' f z (thConstrLayout c)++-- | Map a function over each layout item and its position within a+-- constructor.+mapLayout :: (THLayoutItem -> a) -> THConstr -> [a]+mapLayout f c = map f (thConstrLayout c)++-- | Return the size in bits of an annotated layout item.  A constant+-- layout item must be of known size.+thLayoutItemSize :: THLayoutItem -> Int+thLayoutItemSize (THLayoutConst (BitLitKnown len _) _) = len+thLayoutItemSize (THLayoutConst _ _) = error "invalid layout item"+thLayoutItemSize (THLayoutField f _) = thFieldLen f++-- | Return the size of an annotated layout definition.  All constant+-- values must have a known size.+thLayoutSize :: THLayout -> Int+thLayoutSize l = sum $ map thLayoutItemSize l++-- | A constructor definition annotated with TH information.+data THConstr = THConstr+  { thConstrName   :: Name+  , thConstrFields :: [THField]+  , thConstrLayout :: THLayout+  } deriving Show++-- | Return a list of field names defined in a constructor.+constrFieldNames :: THConstr -> [Name]+constrFieldNames c = map thFieldName (thConstrFields c)++-- | Annotate a constructor definition.+annotateConstr :: Int -> Constr -> Q THConstr+annotateConstr len (Constr n fs ls) = do+  fs' <- mapM annotateField fs+  ls' <- updateLiterals len fs' ls+  return $ THConstr (mkName n) fs' (annotateLayout len ls' fs')++-- | A bit data definition annotated with TH information.+data THDef = THDef+  { thDefName    :: Name+  , thDefType    :: Type+  , thDefConstrs :: [THConstr]+  , thDefLen     :: Int+  } deriving Show++-- | Annotate a bitdata definition.+annotateDef :: Def -> Q THDef+annotateDef (Def n t cs) = do+  ty  <- convertType t+  len <- tyBits ty+  cs' <- mapM (annotateConstr len) cs+  return $ THDef (mkName n) ty cs' len++----------------------------------------------------------------------+-- Annotated AST Validation++-- | Validate a bitdata definition.+checkDef :: THDef -> Q ()+checkDef def = do+  mapM_ (checkConstr def) (thDefConstrs def)++-- | Validate a bitdata constructor definition.  Make sure all the+-- layouts are valid for the data size.+checkConstr :: THDef -> THConstr -> Q ()+checkConstr def constr = do+  checkLayout def constr (thConstrLayout constr)++-- | Return the field names mentioned in a layout.+layoutFieldNames :: THLayout -> [Name]+layoutFieldNames = mapMaybe go+  where go (THLayoutField f _) = Just $ thFieldName f+        go _ = Nothing++-- | Validate a constructor layout.  We verify these properties:+--+-- * Each field that is not named "_" is mentioned exactly once in the+--   layout.+--+-- * The total size of the layout does not exceed the size of the+--   enclosing bit data definition.+checkLayout :: THDef -> THConstr -> THLayout -> Q ()+checkLayout def c l = do+  let cnames = filter (/= (mkName "_")) (constrFieldNames c)+      lnames = filter (/= (mkName "_")) (layoutFieldNames l)+  unless (sort cnames == sort lnames) $+    fail "layout does not mention each field exactly once"+  when (thLayoutSize l > thDefLen def) $+    fail "constructor layout is too large"++----------------------------------------------------------------------+-- Code Generation++-- | Process and convert a bit data definition to a Template Haskell+-- declaration to splice in.+mkDef :: Def -> Q [Dec]+mkDef d = do+  def <- annotateDef d+  checkDef def+  sequence $ concat+    [ mkDefNewtype def+    , mkDefInstance def+    , concatMap (mkConstr def) (thDefConstrs def)+    , mkArraySizeTypeInsts def+    ]++-- | Generate a newtype definition for a bit data definition.+mkDefNewtype :: THDef -> [DecQ]+mkDefNewtype def = [newtypeD (cxt []) name []+                    (normalC name [strictType notStrict (return ty)])+                    [''I.IvoryType, ''I.IvoryVar, ''I.IvoryExpr, ''I.IvoryEq]]+  where+    name = thDefName def+    ty   = thDefType def++-- | Generate an instance of the "BitData" type class for a bit data+-- definition.+mkDefInstance :: THDef -> [DecQ]+mkDefInstance def = [instanceD (cxt []) instTy body]+  where+    name    = thDefName def+    baseTy  = thDefType def+    instTy  = [t| B.BitData $(conT (thDefName def)) |]+    body    = [tyDef, toFun, fromFun]+    tyDef   = tySynInstD ''B.BitType [conT name] (return baseTy)+    x       = mkName "x"+    toFun   = funD 'B.toBits [clause [conP name [varP x]]+                              (normalB (varE x)) []]+    fromFun = valD (varP 'B.fromBits) (normalB (conE name)) []++-- | Generate instances of the "ArraySize" type family for any fields+-- with a bit array type.+mkArraySizeTypeInsts :: THDef -> [DecQ]+mkArraySizeTypeInsts def =+ concatMap (uncurry mkArraySizeTypeInst)+           (mapMaybe getArrayType+                     (concatMap constrFieldTypes (thDefConstrs def)))++-- | Generate an instance of the "ArraySize" type family for a bit+-- array type.  We don't check to see if the instance already exists+-- because duplicates are allowed by the overlapping rules when the+-- result type is the same.+mkArraySizeTypeInst :: Int -> Type -> [DecQ]+mkArraySizeTypeInst n ty = [tySynInstD ''B.ArraySize args size]+  where+    size = tyBits ty >>= litT . numTyLit . fromIntegral . (* n)+    args = [litT (numTyLit (fromIntegral n)), return ty]++-- | Return a list of types for each field in a constructor.+constrFieldTypes :: THConstr -> [Type]+constrFieldTypes c = map thFieldType fields+  where fields = filter ((/= (mkName "_")) . thFieldName) (thConstrFields c)++-- | Create a Template Haskell function type for a bit data+-- constructor.+mkConstrType :: THDef -> THConstr -> Type+mkConstrType d c = foldr (AppT . AppT ArrowT) (ConT (thDefName d)) fields+  where fields = constrFieldTypes c++-- | Return the Template Haskell name for the "n"th argument to a bit+-- data constructor.+argName :: Int -> Name+argName n = mkName ("arg" ++ show n)++-- | Create a Template Haskell pattern list for a bit data+-- constructor.+mkConstrArgs :: THConstr -> [PatQ]+mkConstrArgs c = zipWith f [0..] names+  where names = filter (/= (mkName "_")) (constrFieldNames c)+        f x _ = varP (argName x)++-- | Create an expression for a layout item in the constructor.  We+-- maintain a count of the number of fields we've seen so that we can+-- reconstruct the argument name based on the field number.  This+-- isn't the most elegant solution but it will work for now.+--+-- This function can be folded over the layout with "foldLayout" given+-- an initial expression.+constrBodyExpr :: (Int, ExpQ) -> THLayoutItem -> (Int, ExpQ)+constrBodyExpr (n, expr) l =+  case l of+    -- XXX I would love to use an expression quasiquoter here, but+    -- there was a lot of arguing with the quasiquoter typechecker+    -- that seemed unnecessary, so I punted and built the expression+    -- by hand.+    THLayoutField _ pos ->+      (n + 1, infixApp expr (varE '(.|))+               (infixApp (appE (varE 'safeCast) (appE (varE 'B.toRep)+                                                 (varE (argName n))))+                          (varE 'iShiftL) (litE (integerL+                                                 (fromIntegral pos)))))+    THLayoutConst val pos+      | bitLitVal val /= 0 ->+        (n, infixApp expr (varE '(.|))+         (infixApp (litE (integerL (fromIntegral (bitLitVal val))))+          (varE 'iShiftL) (litE (integerL (fromIntegral pos)))))+      -- There's no need to OR in the zero value here:+      | otherwise -> (n, expr)++-- | Generate a value definition for a bit data constructor.+--+-- The generated constructor will take one argument for each field in+-- the constructor.  The body of the constructor will assemble the+-- arguments into a value using the layout.+mkConstr :: THDef -> THConstr -> [DecQ]+mkConstr def constr = [sig, fun] ++ mkConstrFields def constr+  where+    cname = thConstrName constr+    sig   = sigD cname (return (mkConstrType def constr))+    args  = mkConstrArgs constr+    zexpr = litE (integerL 0)+    expr  = snd (foldLayout constrBodyExpr (0, zexpr) constr)+    body  = normalB (appE (varE 'B.unsafeFromRep) expr)+    fun   = funD cname [clause args body []]++-- | Generate fields for a constructor using its layout.+mkConstrFields :: THDef -> THConstr -> [DecQ]+mkConstrFields def c = concat $ mapLayout (mkField def) c++-- | Generate a constructor field definition.+mkField :: THDef -> THLayoutItem -> [DecQ]+mkField def l@(THLayoutField f pos) =+  [ sigD name ty+  , valD (varP name) (normalB [| B.BitDataField $posE $lenE |]) []]+  where+    name = thFieldName f+    lenE = litE (integerL (fromIntegral (thFieldLen f)))+    posE = litE (integerL (fromIntegral pos))+    fty = return (thFieldType f)+    ty  = [t| B.BitDataField $(conT (thDefName def)) $fty |]+mkField _ _ = []
+ src/Ivory/BitData/TokenParser.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+--+-- TokenParser.hs --- HW quasiquoter token parser.+--+-- Copyright (C) 2013, Galois, Inc.+-- All Rights Reserved.+--++module Ivory.BitData.TokenParser where++import Text.Parsec.Language (haskellDef)+import qualified Text.Parsec.Token as T++-- Import all the token parser definitions for our language.+T.TokenParser{..} = T.makeTokenParser haskellDef