hardware-edsl (empty) → 0.1.0.0
raw patch · 19 files changed
+2777/−0 lines, 19 filesdep +arraydep +basedep +bytestringsetup-changed
Dependencies added: array, base, bytestring, constraints, containers, language-vhdl, mtl, operational-alacarte, pretty, syntactic
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- hardware-edsl.cabal +72/−0
- src/Language/Embedded/Hardware.hs +10/−0
- src/Language/Embedded/Hardware/Command.hs +39/−0
- src/Language/Embedded/Hardware/Command/Backend/VHDL.hs +295/−0
- src/Language/Embedded/Hardware/Command/CMD.hs +211/−0
- src/Language/Embedded/Hardware/Command/Frontend.hs +199/−0
- src/Language/Embedded/Hardware/Expression.hs +9/−0
- src/Language/Embedded/Hardware/Expression/Backend/VHDL.hs +159/−0
- src/Language/Embedded/Hardware/Expression/Frontend.hs +139/−0
- src/Language/Embedded/Hardware/Expression/Hoist.hs +145/−0
- src/Language/Embedded/Hardware/Expression/Represent.hs +141/−0
- src/Language/Embedded/Hardware/Expression/Syntax.hs +375/−0
- src/Language/Embedded/Hardware/Interface.hs +38/−0
- src/Language/Embedded/VHDL.hs +12/−0
- src/Language/Embedded/VHDL/Monad.hs +674/−0
- src/Language/Embedded/VHDL/Monad/Expression.hs +167/−0
- src/Language/Embedded/VHDL/Monad/Type.hs +60/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Markus Aronsson++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 Markus Aronsson 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
+ hardware-edsl.cabal view
@@ -0,0 +1,72 @@+name: hardware-edsl+version: 0.1.0.0+synopsis: Deep embedding of hardware descriptions with code generation.+description: Deep embedding of hardware descriptions with code generation.+license: BSD3+license-file: LICENSE+author: Markus Aronsson <mararon@chalmers.se>+maintainer: mararon@chalmers.se+-- copyright:+homepage: https://github.com/markus-git/hardware-edsl+category: Language+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10++source-repository head+ type: git+ location: git://github.com/markus-git/hardware-edsl++library+ exposed-modules:+ Language.Embedded.Hardware,+ Language.Embedded.Hardware.Expression,+ Language.Embedded.Hardware.Expression.Syntax,+ Language.Embedded.Hardware.Expression.Represent,+ Language.Embedded.Hardware.Expression.Frontend,+ Language.Embedded.Hardware.Command,+ Language.Embedded.Hardware.Command.CMD,+ Language.Embedded.Hardware.Command.Frontend,+ Language.Embedded.Hardware.Interface+ Language.Embedded.VHDL,+ Language.Embedded.VHDL.Monad,+ Language.Embedded.VHDL.Monad.Type,+ Language.Embedded.VHDL.Monad.Expression++ other-modules:+ Language.Embedded.Hardware.Expression.Hoist,+ Language.Embedded.Hardware.Expression.Backend.VHDL,+ Language.Embedded.Hardware.Command.Backend.VHDL+ + other-extensions:+ GADTs,+ KindSignatures,+ TypeFamilies,+ TypeOperators,+ FlexibleContexts,+ FlexibleInstances,+ MultiParamTypeClasses,+ ScopedTypeVariables,+ GeneralizedNewtypeDeriving,+ ConstraintKinds,+ Rank2Types,+ StandaloneDeriving,+ UndecidableInstances+ + build-depends:+ base >=4.8 && <4.9,+ mtl >=2.2 && <2.3,+ array >=0.5 && <0.6,+ containers >=0.5 && <0.6,+ pretty >=1.1 && <1.2,+ bytestring >=0.10 && <0.11,+ constraints >=0.6,+ syntactic >=3.2,+ operational-alacarte >=0.1.1,+ language-vhdl >=0.1.2.5+ + hs-source-dirs:+ src+ + default-language:+ Haskell2010
+ src/Language/Embedded/Hardware.hs view
@@ -0,0 +1,10 @@+module Language.Embedded.Hardware+ ( module Language.Embedded.Hardware.Expression+ , module Language.Embedded.Hardware.Command+ , module Language.Embedded.Hardware.Interface+ ) where++import Language.Embedded.Hardware.Expression+import Language.Embedded.Hardware.Command+import Language.Embedded.Hardware.Interface+
+ src/Language/Embedded/Hardware/Command.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE FlexibleContexts #-}++module Language.Embedded.Hardware.Command+ ( compile+ , icompile+ , runIO++ , module CMD+ , module Language.Embedded.Hardware.Command.CMD+ , module Language.Embedded.Hardware.Command.Frontend+ , module Language.Embedded.Hardware.Command.Backend.VHDL+ ) where++import Language.Embedded.Hardware.Command.CMD as CMD (Signal, Variable, Array)+import Language.Embedded.Hardware.Command.CMD hiding (Signal, Variable, Array)+import Language.Embedded.Hardware.Command.Frontend+import Language.Embedded.Hardware.Command.Backend.VHDL++import Language.Embedded.VHDL (VHDL, prettyVHDL)++import Control.Monad.Operational.Higher++--------------------------------------------------------------------------------+-- * Compilation and evaluation.+--------------------------------------------------------------------------------++-- | Compile a program to VHDL code represented as a string.+compile :: (Interp instr VHDL, HFunctor instr) => Program instr a -> String+compile = show . prettyVHDL . interpret++-- | Compile a program to VHDL code and print it on the screen.+icompile :: (Interp instr VHDL, HFunctor instr) => Program instr a -> IO ()+icompile = putStrLn . compile++-- | Run a program in 'IO'.+runIO :: (Interp instr IO, HFunctor instr) => Program instr a -> IO a+runIO = interpret++--------------------------------------------------------------------------------
+ src/Language/Embedded/Hardware/Command/Backend/VHDL.hs view
@@ -0,0 +1,295 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Language.Embedded.Hardware.Command.Backend.VHDL () where++import Control.Monad.Operational.Higher++import Language.Embedded.Hardware.Interface+import Language.Embedded.Hardware.Expression.Hoist+import Language.Embedded.Hardware.Command.CMD++import Language.Embedded.VHDL (VHDL)+import qualified Language.VHDL as V+import qualified Language.Embedded.VHDL as V++import qualified Data.IORef as IR+import qualified Data.Array.IO as IA++--------------------------------------------------------------------------------+-- * Translation of hardware commands into VHDL.+--------------------------------------------------------------------------------++class ToIdent a+ where+ toIdent :: a -> V.Identifier++instance ToIdent String where toIdent = V.Ident+instance ToIdent (Signal a) where toIdent (SignalC i) = V.Ident $ 's' : show i+instance ToIdent (Variable a) where toIdent (VariableC i) = V.Ident $ 'v' : show i+instance ToIdent (Array i a) where toIdent (ArrayC i) = V.Ident $ 'a' : show i++compEM :: forall exp a. (PredicateExp exp a, CompileExp exp) => Maybe (exp a) -> VHDL (Maybe V.Expression)+compEM e = maybe (return Nothing) (>>= return . Just) $ fmap compE e++compTM :: forall exp a. (PredicateExp exp a, CompileExp exp) => Maybe (exp a) -> VHDL V.Type+compTM _ = compT (undefined :: exp a)++evalEM :: forall exp a. (PredicateExp exp a, EvaluateExp exp) => Maybe (exp a) -> a+evalEM e = maybe (error "empty value") (id) $ fmap evalE e++freshVar :: forall exp a. (CompileExp exp, PredicateExp exp a) => VHDL (exp a, V.Identifier)+freshVar = do+ i <- varE <$> V.freshUnique :: VHDL (exp a)+ n <- dig <$> compE i+ t <- compT (undefined :: exp a)+ V.addLocal $ V.declareVariable n t Nothing+ return (i, n)+ where+ -- diggity dig!+ dig :: V.Expression -> V.Identifier+ dig (V.ENand (V.Relation (V.ShiftExpression (V.SimpleExpression _ (V.Term (V.FacPrim (V.PrimName (V.NSimple i)) _)_)_)_)_)_) = i++--------------------------------------------------------------------------------+-- ** Signals.++instance CompileExp exp => Interp (SignalCMD exp) VHDL+ where+ interp = compileSignal++instance EvaluateExp exp => Interp (SignalCMD exp) IO+ where+ interp = runSignal++compileSignal :: forall exp a. CompileExp exp => SignalCMD exp VHDL a -> VHDL a+compileSignal (NewSignal clause scope mode exp) =+ do v <- compEM exp+ t <- compTM exp+ i <- SignalC <$> V.freshUnique+ let block = V.declareSignal (toIdent i) t v+ interface = V.interfaceSignal (toIdent i) mode t v+ case scope of+ SProcess -> V.addLocal block+ SArchitecture -> V.addGlobal block+ SEntity -> case clause of+ Port -> V.addPort interface+ Generic -> V.addGeneric interface+ return i+compileSignal (GetSignal s) =+ do (v, i) <- freshVar :: VHDL (a, V.Identifier)+ e <- compE v+ V.addSequential $ V.assignVariable i (lift $ V.PrimName $ V.NSimple $ toIdent s)+ return v+compileSignal (SetSignal s exp) =+ do V.addSequential =<< V.assignSignalS (toIdent s) <$> compE exp+compileSignal (UnsafeFreezeSignal (SignalC s)) =+ do return $ varE s++runSignal :: forall exp prog a. EvaluateExp exp => SignalCMD exp prog a -> IO a+runSignal (NewSignal _ _ _ exp) = fmap SignalE $ IR.newIORef $ evalEM exp+runSignal (GetSignal (SignalE r)) = fmap litE $ IR.readIORef r+runSignal (SetSignal (SignalE r) exp) = IR.writeIORef r $ evalE exp+runSignal (UnsafeFreezeSignal r) = runSignal (GetSignal r)++--------------------------------------------------------------------------------+-- ** Variables.++instance CompileExp exp => Interp (VariableCMD exp) VHDL+ where+ interp = compileVariable++instance EvaluateExp exp => Interp (VariableCMD exp) IO+ where+ interp = runVariable++compileVariable :: forall exp a. CompileExp exp => VariableCMD exp VHDL a -> VHDL a+compileVariable (NewVariable exp) =+ do v <- compEM exp+ t <- compTM exp+ i <- VariableC <$> V.freshUnique+ V.addLocal $ V.declareVariable (toIdent i) t v+ return i+compileVariable (GetVariable var) =+ do (v, i) <- freshVar :: VHDL (a, V.Identifier)+ e <- compE v+ V.addSequential $ V.assignVariable i (lift $ V.PrimName $ V.NSimple $ toIdent var)+ return v+compileVariable (SetVariable var exp) =+ do V.addSequential =<< V.assignVariable (toIdent var) <$> compE exp+compileVariable (UnsafeFreezeVariable (VariableC v)) =+ do return $ varE v++runVariable :: forall exp prog a. EvaluateExp exp => VariableCMD exp prog a -> IO a+runVariable (NewVariable exp) = fmap VariableE $ IR.newIORef $ evalEM exp+runVariable (GetVariable (VariableE v)) = fmap litE $ IR.readIORef v+runVariable (SetVariable (VariableE v) exp) = IR.writeIORef v $ evalE exp+runVariable (UnsafeFreezeVariable v) = runVariable (GetVariable v)++--------------------------------------------------------------------------------+-- ** Arrays.++instance (CompileExp exp, EvaluateExp exp, CompArrayIx exp) => Interp (ArrayCMD exp) VHDL+ where+ interp = compileArray++instance EvaluateExp exp => Interp (ArrayCMD exp) IO+ where+ interp = runArray++-- *** Signal commands can be both sequential and parallel and I shouldn't+-- depend on them always being sequential.+compileArray :: forall exp a. (CompileExp exp, EvaluateExp exp, CompArrayIx exp) => ArrayCMD exp VHDL a -> VHDL a+compileArray (NewArray len) =+ do n <- compE len+ t <- compTA len (undefined :: a)+ a <- freshA+ i <- ArrayC <$> V.freshUnique+ let range = V.range (lift n) V.downto zero+ array = V.constrainedArray a t range+ V.addType array+ V.addLocal $ V.declareVariable (toIdent i) (typed array) Nothing+ return i+compileArray (InitArray is) =+ do t <- compTA (undefined :: exp i) (undefined :: a)+ a <- freshA+ i <- ArrayC <$> V.freshUnique+ x <- sequence [compE (litE a :: exp b) | (a :: b) <- is]+ let len = V.lit (length is)+ range = V.range (lift len) V.downto zero+ array = V.constrainedArray a t range+ V.addType array+ V.addLocal $ V.declareVariable (toIdent i) (typed array) (Just $ lift $ V.aggregate x)+ return i+compileArray (GetArray ix arr) =+ do (v, i) <- freshVar :: VHDL (a, V.Identifier)+ e <- compE ix+ V.addSequential $ V.assignVariable i (lift $ V.PrimName $ V.indexed (toIdent arr) e)+ return v+compileArray (SetArray i e arr) =+ do i' <- compE i+ e' <- compE e+ -- this could be concurrent as well.+ V.addSequential $ V.assignArray (V.indexed (toIdent arr) i') e'+compileArray (UnsafeGetArray ix arr) =+ case compArrayIx ix arr of+ Just e -> return e+ Nothing -> do+ (v, i) <- freshVar :: VHDL (a, V.Identifier)+ e <- compE ix+ V.addSequential $ V.assignVariable i (lift $ V.PrimName $ V.indexed (toIdent arr) e)+ return v++runArray :: forall exp prog a. EvaluateExp exp => ArrayCMD exp prog a -> IO a+runArray (NewArray len) = fmap ArrayE $ IA.newArray_ $ (,) 0 $ evalE len+runArray (InitArray is) = fmap ArrayE $ IA.newListArray (0, fromIntegral $ length is) is+runArray (GetArray i (ArrayE a)) = fmap litE $ IA.readArray a $ evalE i+runArray (SetArray i e (ArrayE a)) = IA.writeArray a (evalE i) (evalE e)+runArray (UnsafeGetArray i a) = runArray (GetArray i a)++--------------------------------------------------------------------------------++-- | Fresh array type identifier+freshA :: VHDL V.Identifier+freshA = toIdent . ('t' :) . show <$> V.freshUnique++-- | Compile type of array.+compTA :: forall exp i a. (PredicateExp exp a, CompileExp exp) => exp i -> Array i a -> VHDL V.Type+compTA _ _ = compT (undefined :: exp a)++zero :: V.SimpleExpression+zero = lift (V.lit 0)++typed :: V.TypeDeclaration -> V.SubtypeIndication+typed (V.TDFull (V.FullTypeDeclaration i _)) = named i+typed (V.TDPartial (V.IncompleteTypeDeclaration i)) = named i++named :: V.Identifier -> V.SubtypeIndication+named i = V.SubtypeIndication Nothing (V.TMType (V.NSimple i)) Nothing++--------------------------------------------------------------------------------+-- ** Loops.++instance CompileExp exp => Interp (LoopCMD exp) VHDL+ where+ interp = compileLoop++instance EvaluateExp exp => Interp (LoopCMD exp) IO+ where+ interp = runLoop++compileLoop :: forall exp a. CompileExp exp => LoopCMD exp VHDL a -> VHDL a+compileLoop (For r step) =+ do hi <- compE r+ (v, i) <- freshVar+ loop <- V.inFor i (V.range zero V.to (lift hi)) (step v)+ V.addSequential $ V.SLoop $ loop+compileLoop (While b step) =+ do error "todo: compile while loops"++runLoop :: forall exp prog a. EvaluateExp exp => LoopCMD exp IO a -> IO a+runLoop (For r step) = loop (evalE r)+ where+ loop i | i > 0 = step (litE i) >> loop (i - 1)+ | otherwise = return ()+runLoop (While b step) = loop+ where+ loop = b >>= flip when (step >> loop) . evalE++--------------------------------------------------------------------------------+-- ** Conditional.++instance CompileExp exp => Interp (ConditionalCMD exp) VHDL+ where+ interp = compileConditional++instance EvaluateExp exp => Interp (ConditionalCMD exp) IO+ where+ interp = runConditional++compileConditional :: forall exp a. CompileExp exp => ConditionalCMD exp VHDL a -> VHDL a+compileConditional (If (a, b) cs em) =+ do let (es, ds) = unzip cs+ el = maybe (return ()) id em+ ae <- compE a+ ese <- mapM compE es+ s <- V.inConditional (ae, b) (zip ese ds) el+ V.addSequential $ V.SIf s++runConditional :: forall exp a. EvaluateExp exp => ConditionalCMD exp IO a -> IO a+runConditional (If (a, b) cs em) = if (evalE a) then b else loop cs+ where+ loop [] = maybe (return ()) id em+ loop ((c, p):xs) = if (evalE c) then p else (loop xs)++--------------------------------------------------------------------------------+-- ** Structural.++instance CompileExp exp => Interp (StructuralCMD exp) VHDL+ where+ interp = compileStructural++instance EvaluateExp exp => Interp (StructuralCMD exp) IO+ where+ interp = runStructural++compileStructural :: forall exp a. CompileExp exp => StructuralCMD exp VHDL a -> VHDL a+compileStructural (Entity e prog) = V.entity (toIdent e) prog+compileStructural (Architecture e a prog) = V.architecture (toIdent e) (toIdent a) prog+compileStructural (Process xs prog) =+ do label <- V.newLabel+ (a, c) <- V.inProcess label (fmap reveal xs) prog+ V.addConcurrent (V.ConProcess c)+ return a+ where+ reveal :: SignalX -> V.Identifier+ reveal (SignalX s) = toIdent s++runStructural :: forall exp a. EvaluateExp exp => StructuralCMD exp IO a -> IO a+runStructural (Entity _ prog) = prog+runStructural (Architecture _ _ prog) = prog+runStructural (Process xs prog) = error "todo: run process"++--------------------------------------------------------------------------------
+ src/Language/Embedded/Hardware/Command/CMD.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Language.Embedded.Hardware.Command.CMD where++import Language.Embedded.VHDL (Mode)+import Language.Embedded.Hardware.Interface (PredicateExp)++import Control.Monad.Operational.Higher++import Data.Ix (Ix)+import Data.IORef (IORef)+import Data.Array.IO (IOArray)++--------------------------------------------------------------------------------+-- * Hardware commands.+--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+-- ** Signals.++-- | If a signal is declared with a scope of 'Entity' its classified as either a+-- port or generic signal.+data Clause = Port | Generic+ deriving (Show)++-- | Scope of a signal.+data Scope = SProcess | SArchitecture | SEntity+ deriving (Show)++-- | Signal representation.+data Signal a = SignalC Integer | SignalE (IORef a)++-- | Commands for signals.+data SignalCMD (exp :: * -> *) (prog :: * -> *) a+ where+ -- ^ Create a new signal.+ NewSignal :: PredicateExp exp a => Clause -> Scope -> Mode -> Maybe (exp a) -> SignalCMD exp prog (Signal a)+ -- ^ Fetch the contents of a signal.+ GetSignal :: PredicateExp exp a => Signal a -> SignalCMD exp prog (exp a)+ -- ^ Write the value to a signal.+ SetSignal :: PredicateExp exp a => Signal a -> exp a -> SignalCMD exp prog ()+ -- ^ Unsafe version of fetching a signal.+ UnsafeFreezeSignal :: PredicateExp exp a => Signal a -> SignalCMD exp prog (exp a)++type instance IExp (SignalCMD e) = e+type instance IExp (SignalCMD e :+: i) = e++instance HFunctor (SignalCMD exp)+ where+ hfmap _ (NewSignal c s m e) = NewSignal c s m e+ hfmap _ (GetSignal s) = GetSignal s+ hfmap _ (SetSignal s e) = SetSignal s e++--------------------------------------------------------------------------------+-- ** Variables.++-- | Variable representation.+data Variable a = VariableC Integer | VariableE (IORef a)++-- | Commands for variables.+data VariableCMD (exp :: * -> *) (prog :: * -> *) a+ where+ -- ^ Create a new variable.+ NewVariable :: PredicateExp exp a => Maybe (exp a) -> VariableCMD exp prog (Variable a)+ -- ^ Fetch the contents of a variable.+ GetVariable :: PredicateExp exp a => Variable a -> VariableCMD exp prog (exp a)+ -- ^ Write the value to a variable.+ SetVariable :: PredicateExp exp a => Variable a -> exp a -> VariableCMD exp prog ()+ -- ^ Unsafe version of fetching a variable.+ UnsafeFreezeVariable :: PredicateExp exp a => Variable a -> VariableCMD exp prog (exp a)++type instance IExp (VariableCMD e) = e+type instance IExp (VariableCMD e :+: i) = e++instance HFunctor (VariableCMD exp)+ where+ hfmap _ (NewVariable e) = NewVariable e+ hfmap _ (GetVariable s) = GetVariable s+ hfmap _ (SetVariable s e) = SetVariable s e++--------------------------------------------------------------------------------+-- ** Arrays.++-- | Expression types that support compilation of array indexing+class CompArrayIx exp+ where+ -- | Generate code for an array indexing operation+ compArrayIx :: PredicateExp exp a => exp i -> Array i a -> Maybe (exp a)+ compArrayIx _ _ = Nothing++-- | Array reprensentation.+data Array i a = ArrayC Integer | ArrayE (IOArray i a)++-- | Commands for arrays.+data ArrayCMD (exp :: * -> *) (prog :: * -> *) a+ where+ -- ^ Creates an array of given length.+ NewArray+ :: ( PredicateExp exp a+ , PredicateExp exp i+ , Integral i+ , Ix i )+ => exp i -> ArrayCMD exp prog (Array i a)+ -- ^ Creates an array from the given list of elements.+ InitArray+ :: ( PredicateExp exp a+ , PredicateExp exp i+ , Integral i+ , Ix i )+ => [a] -> ArrayCMD exp prog (Array i a)+ -- ^ Fetches the array's value at a specified index.+ GetArray+ :: ( PredicateExp exp a+ , PredicateExp exp i+ , Integral i+ , Ix i )+ => exp i -> Array i a -> ArrayCMD exp prog (exp a)+ -- ^ Writes a value to an array at some specified index.+ SetArray+ :: ( PredicateExp exp a+ , PredicateExp exp i+ , Integral i+ , Ix i )+ => exp i -> exp a -> Array i a -> ArrayCMD exp prog ()+ -- ^ Unsafe version of fetching an array's value.+ UnsafeGetArray+ :: ( PredicateExp exp a+ , PredicateExp exp i+ , Integral i+ , Ix i )+ => exp i -> Array i a -> ArrayCMD exp prog (exp a)++type instance IExp (ArrayCMD e) = e+type instance IExp (ArrayCMD e :+: i) = e++instance HFunctor (ArrayCMD exp)+ where+ hfmap _ (NewArray i) = NewArray i+ hfmap _ (InitArray is) = InitArray is+ hfmap _ (GetArray i a) = GetArray i a+ hfmap _ (SetArray i e a) = SetArray i e a+ hfmap _ (UnsafeGetArray i a) = UnsafeGetArray i a++--------------------------------------------------------------------------------+-- ** Looping.++-- | Commands for looping constructs.+data LoopCMD (exp :: * -> *) (prog :: * -> *) a+ where+ -- ^ Creates a new for loop.+ For :: (PredicateExp exp n, Integral n) => exp n -> (exp n -> prog ()) -> LoopCMD exp prog ()+ -- ^ Creates a new while loop.+ While :: PredicateExp exp Bool => prog (exp Bool) -> prog () -> LoopCMD exp prog ()++type instance IExp (LoopCMD e) = e+type instance IExp (LoopCMD e :+: i) = e++instance HFunctor (LoopCMD exp)+ where+ hfmap f (For r step) = For r (f . step)+ hfmap f (While cont step) = While (f cont) (f step)++--------------------------------------------------------------------------------+-- ** Conditional statements.++-- | Commnads for conditional statements.+data ConditionalCMD (exp :: * -> *) (prog :: * -> *) a+ where+ If :: PredicateExp exp Bool+ => (exp Bool, prog ()) -- if+ -> [(exp Bool, prog ())] -- else-if+ -> Maybe (prog ()) -- else+ -> ConditionalCMD exp prog ()++type instance IExp (ConditionalCMD e) = e+type instance IExp (ConditionalCMD e :+: i) = e++instance HFunctor (ConditionalCMD exp)+ where+ hfmap f (If a cs b) = If (fmap f a) (fmap (fmap f) cs) (fmap f b)++--------------------------------------------------------------------------------+-- ** Structural entities.++-- | Untyped signals.+data SignalX = forall a. SignalX (Signal a)++-- | Commands for structural entities.+data StructuralCMD (exp :: * -> *) (prog :: * -> *) a+ where+ -- ^ Wraps the program in an entity.+ Entity :: String -> prog a -> StructuralCMD exp prog a+ -- ^ Wraps the program in an architecture.+ Architecture :: String -> String -> prog a -> StructuralCMD exp prog a+ -- ^ Wraps the program in a process.+ Process :: [SignalX] -> prog () -> StructuralCMD exp prog ()++type instance IExp (StructuralCMD e) = e+type instance IExp (StructuralCMD e :+: i) = e++instance HFunctor (StructuralCMD exp)+ where+ hfmap f (Entity e p) = Entity e (f p)+ hfmap f (Architecture e a p) = Architecture e a (f p)+ hfmap f (Process xs p) = Process xs (f p)++--------------------------------------------------------------------------------
+ src/Language/Embedded/Hardware/Command/Frontend.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}++module Language.Embedded.Hardware.Command.Frontend where++import Language.Embedded.VHDL (Mode(..))+import Language.Embedded.Hardware.Interface (PredicateExp)+import Language.Embedded.Hardware.Command.CMD++import Control.Monad.Operational.Higher++import Data.Ix (Ix)++--------------------------------------------------------------------------------+-- ** Signals.++-- | Declare a signal.+newSignal :: (SignalCMD (IExp i) :<: i, PredicateExp (IExp i) a) => IExp i a -> ProgramT i m (Signal a)+newSignal = singleE . NewSignal Port SArchitecture InOut . Just++-- | Declare an uninitialized signal.+newSignal_ :: (SignalCMD (IExp i) :<: i, PredicateExp (IExp i) a) => ProgramT i m (Signal a)+newSignal_ = singleE $ NewSignal Port SArchitecture InOut Nothing++-- | Fetches the current value of a signal.+getSignal :: (SignalCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Signal a -> ProgramT i m (IExp i a)+getSignal = singleE . GetSignal++-- | Update the value of a signal.+setSignal :: (SignalCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Signal a -> IExp i a -> ProgramT i m ()+setSignal s = singleE . SetSignal s++-- | Unsafe version of fetching the contents of a signal.+unsafeFreezeSignal :: (SignalCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Signal a -> ProgramT i m (IExp i a)+unsafeFreezeSignal = singleE . UnsafeFreezeSignal++-- | Declare port signals of the given mode and assign it initial value.+newPort :: (SignalCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Mode -> IExp i a -> ProgramT i m (Signal a)+newPort m = singleE . NewSignal Port SEntity m . Just++-- | Declare port signals of the given mode.+newPort_ :: (SignalCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Mode -> ProgramT i m (Signal a)+newPort_ m = singleE $ NewSignal Port SEntity m Nothing++-- | Declare generic signals of the given mode and assign it initial value.+newGeneric :: (SignalCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Mode -> IExp i a -> ProgramT i m (Signal a)+newGeneric m = singleE . NewSignal Generic SEntity m . Just++-- | Declare generic signals of the given mode.+newGeneric_ :: (SignalCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Mode -> ProgramT i m (Signal a)+newGeneric_ m = singleE $ NewSignal Generic SEntity m Nothing++-- | Short-hand for 'setSignal'.+(<==) :: (SignalCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Signal a -> IExp i a -> ProgramT i m ()+(<==) = setSignal++--------------------------------------------------------------------------------+-- ** Variables.++-- | Declare a variable.+newVariable :: (VariableCMD (IExp i) :<: i, PredicateExp (IExp i) a) => IExp i a -> ProgramT i m (Variable a)+newVariable = singleE . NewVariable . Just++-- | Declare an uninitialized variable.+newVariable_ :: (VariableCMD (IExp i) :<: i, PredicateExp (IExp i) a) => ProgramT i m (Variable a)+newVariable_ = singleE $ NewVariable Nothing++-- | Fetches the current value of a variable.+getVariable :: (VariableCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Variable a -> ProgramT i m (IExp i a)+getVariable = singleE . GetVariable++-- | Updates the value of a variable.+setVariable :: (VariableCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Variable a -> IExp i a -> ProgramT i m ()+setVariable v = singleE . SetVariable v++-- | Unsafe version of fetching the contents of a variable.+unsafeFreezeVariable :: (VariableCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Variable a -> ProgramT i m (IExp i a)+unsafeFreezeVariable = singleE . UnsafeFreezeVariable++-- | Short-hand for 'setVariable'.+(==:) :: (VariableCMD (IExp i) :<: i, PredicateExp (IExp i) a) => Variable a -> IExp i a -> ProgramT i m ()+(==:) = setVariable++--------------------------------------------------------------------------------+-- ** Arrays.++-- | Create an uninitialized array.+newArray+ :: ( PredicateExp (IExp instr) a+ , PredicateExp (IExp instr) i+ , Integral i, Ix i+ , ArrayCMD (IExp instr) :<: instr )+ => IExp instr i -> ProgramT instr m (Array i a)+newArray = singleE . NewArray++-- | Create an initialized array.+initArray+ :: ( PredicateExp (IExp instr) a+ , PredicateExp (IExp instr) i+ , Integral i, Ix i+ , ArrayCMD (IExp instr) :<: instr )+ => [a] -> ProgramT instr m (Array i a) +initArray = singleE . InitArray++-- | Get an element of an array.+getArray+ :: ( PredicateExp (IExp instr) a+ , PredicateExp (IExp instr) i+ , Integral i, Ix i+ , ArrayCMD (IExp instr) :<: instr )+ => IExp instr i -> Array i a -> ProgramT instr m (IExp instr a)+getArray i = singleE . GetArray i++-- | Set an element of an array.+setArray+ :: ( PredicateExp (IExp instr) a+ , PredicateExp (IExp instr) i+ , Integral i, Ix i+ , ArrayCMD (IExp instr) :<: instr )+ => IExp instr i -> IExp instr a -> Array i a -> ProgramT instr m ()+setArray i a = singleE . SetArray i a++-- | Unsafe version of fetching the contents of an array's index.+unsafeGetArray+ :: ( PredicateExp (IExp instr) a+ , PredicateExp (IExp instr) i+ , Integral i, Ix i+ , ArrayCMD (IExp instr) :<: instr )+ => IExp instr i -> Array i a -> ProgramT instr m (IExp instr a)+unsafeGetArray i = singleE . UnsafeGetArray i++--------------------------------------------------------------------------------+-- ** Looping.++-- | For loop.+for+ :: (LoopCMD (IExp instr) :<: instr, PredicateExp (IExp instr) n, Integral n)+ => IExp instr n+ -> (IExp instr n -> ProgramT instr m ())+ -> ProgramT instr m ()+for range = singleE . For range++-- | While loop.+while+ :: (LoopCMD (IExp instr) :<: instr, PredicateExp (IExp instr) Bool)+ => ProgramT instr m (IExp instr Bool)+ -> ProgramT instr m ()+ -> ProgramT instr m ()+while cond = singleE . While cond++--------------------------------------------------------------------------------+-- ** Conditional statements.++-- | Conditional statements guarded by if and then clauses with an optional else.+conditional+ :: (ConditionalCMD (IExp i) :<: i, PredicateExp (IExp i) Bool)+ => (IExp i Bool, ProgramT i m ())+ -> [(IExp i Bool, ProgramT i m ())]+ -> Maybe (ProgramT i m ())+ -> ProgramT i m ()+conditional a bs = singleE . If a bs++-- | Guarded statement.+when+ :: (ConditionalCMD (IExp i) :<: i, PredicateExp (IExp i) Bool)+ => IExp i Bool+ -> ProgramT i m ()+ -> ProgramT i m ()+when e p = conditional (e, p) [] Nothing++-- | Standard if-then-else statement.+iff+ :: (ConditionalCMD (IExp i) :<: i, PredicateExp (IExp i) Bool)+ => IExp i Bool+ -> ProgramT i m ()+ -> ProgramT i m ()+ -> ProgramT i m ()+iff b t e = conditional (b, t) [] (Just e)++--------------------------------------------------------------------------------+-- ** Structural entities.++-- | Declare a new entity by wrapping the program to declare ports & generics.+entity :: (StructuralCMD (IExp i) :<: i) => String -> ProgramT i m a -> ProgramT i m a+entity e = singleE . Entity e++-- | Declare a new architecture for some entity by wrapping the given program.+architecture :: (StructuralCMD (IExp i) :<: i) => String -> String -> ProgramT i m a -> ProgramT i m a+architecture e a = singleE . Architecture e a++-- | Declare a new process listening to some signals by wrapping the given program.+process :: (StructuralCMD (IExp i) :<: i) => [SignalX] -> ProgramT i m () -> ProgramT i m ()+process is = singleE . Process is++-- | ...+hideSig :: Signal a -> SignalX+hideSig = SignalX++--------------------------------------------------------------------------------
+ src/Language/Embedded/Hardware/Expression.hs view
@@ -0,0 +1,9 @@+module Language.Embedded.Hardware.Expression+ ( HExp+ , HType+ , module Language.Embedded.Hardware.Expression.Frontend+ ) where++import Language.Embedded.Hardware.Expression.Syntax (HExp, HType)+import Language.Embedded.Hardware.Expression.Frontend+import Language.Embedded.Hardware.Expression.Backend.VHDL ()
+ src/Language/Embedded/Hardware/Expression/Backend/VHDL.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Language.Embedded.Hardware.Expression.Backend.VHDL where++import Language.Syntactic+import Language.Syntactic.Functional (Denotation, evalSym)++import Language.Embedded.Hardware.Expression.Syntax+import Language.Embedded.Hardware.Expression.Frontend (value, variable)+import Language.Embedded.Hardware.Expression.Represent+import Language.Embedded.Hardware.Expression.Hoist (Kind)+import Language.Embedded.Hardware.Interface+import qualified Language.Embedded.Hardware.Expression.Hoist as Hoist++import Language.Embedded.VHDL (VHDL)+import qualified Language.VHDL as VHDL+import qualified Language.Embedded.VHDL as VHDL++import Control.Applicative++--------------------------------------------------------------------------------+-- * Compilation and evaluation of hardware expressions for VHDL.+--------------------------------------------------------------------------------++instance EvaluateExp HExp+ where+ litE = value+ evalE = evalHExp++evalHExp :: HExp a -> a+evalHExp = go . unHExp+ where+ go :: AST T sig -> Denotation sig+ go (Sym (T s)) = evalSym s+ go (f :$ a) = go f $ go a++--------------------------------------------------------------------------------++instance CompileExp HExp+ where+ varE v = variable ('v' : show v)+ compT = compHType+ compE = compHExp++compHType :: forall a. HType a => HExp a -> VHDL VHDL.Type+compHType _ = declare (undefined :: a) >> return (unTag (typed :: Tagged a VHDL.Type))++compHExp :: forall a. HType a => HExp a -> VHDL VHDL.Expression+compHExp e = Hoist.lift <$> compSimple e+ where+ compSimple :: HExp b -> VHDL Kind+ compSimple = simpleMatch (\(T s) -> compDomain s) . unHExp++ compLoop :: ASTF T b -> VHDL Kind+ compLoop = compSimple . HExp++ compDomain :: forall sig. HType (DenResult sig) => Dom sig -> Args (AST T) sig -> VHDL Kind+ compDomain expr (x :* y :* _)+ | Just And <- prj expr = go $ \a b -> VHDL.and [a, b]+ | Just Or <- prj expr = go $ \a b -> VHDL.or [a, b]+ | Just Xor <- prj expr = go $ \a b -> VHDL.xor [a, b]+ | Just Xnor <- prj expr = go $ \a b -> VHDL.xnor [a, b]+ | Just Nand <- prj expr = go VHDL.nand+ | Just Nor <- prj expr = go VHDL.nor+ where+ go :: (VHDL.Relation -> VHDL.Relation -> VHDL.Expression) -> VHDL Kind+ go f = do+ x' <- Hoist.lift <$> compLoop x+ y' <- Hoist.lift <$> compLoop y+ return $ Hoist.E $ f x' y'+ compDomain relate (x :* y :* _)+ | Just Eq <- prj relate = go VHDL.eq+ | Just Neq <- prj relate = go VHDL.neq+ | Just Lt <- prj relate = go VHDL.lt+ | Just Lte <- prj relate = go VHDL.lte+ | Just Gt <- prj relate = go VHDL.gt+ | Just Gte <- prj relate = go VHDL.gte+ where+ go :: (VHDL.ShiftExpression -> VHDL.ShiftExpression -> VHDL.Relation) -> VHDL Kind+ go f = do+ x' <- Hoist.lift <$> compLoop x+ y' <- Hoist.lift <$> compLoop y+ return $ Hoist.R $ f x' y'+ compDomain shift (x :* y :* _)+ | Just Sll <- prj shift = go $ VHDL.sll+ | Just Srl <- prj shift = go $ VHDL.srl+ | Just Sla <- prj shift = go $ VHDL.sla+ | Just Sra <- prj shift = go $ VHDL.sra+ | Just Rol <- prj shift = go $ VHDL.rol+ | Just Ror <- prj shift = go $ VHDL.ror+ where+ go :: (VHDL.SimpleExpression -> VHDL.SimpleExpression -> VHDL.ShiftExpression) -> VHDL Kind+ go f = do+ x' <- Hoist.lift <$> compLoop x+ y' <- Hoist.lift <$> compLoop y+ return $ Hoist.Sh $ f x' y'+ compDomain simple (x :* y :* _)+ | Just Add <- prj simple = go VHDL.add+ | Just Sub <- prj simple = go VHDL.sub+ | Just Cat <- prj simple = go VHDL.cat+ where+ go :: ([VHDL.Term] -> VHDL.SimpleExpression) -> VHDL Kind+ go f = do+ x' <- Hoist.lift <$> compLoop x+ y' <- Hoist.lift <$> compLoop y+ return $ Hoist.Si $ f [x', y']+ compDomain simple (x :* _)+ | Just Neg <- prj simple = do+ x' <- Hoist.lift <$> compLoop x+ return $ Hoist.Si $ VHDL.neg x'+ | Just Pos <- prj simple = do+ x' <- Hoist.lift <$> compLoop x+ return $ Hoist.Si x'+ compDomain term (x :* y :* _)+ | Just Mul <- prj term = go VHDL.mul+ | Just Div <- prj term = go VHDL.div+ | Just Mod <- prj term = go VHDL.mod+ | Just Rem <- prj term = go VHDL.rem+ where+ go :: ([VHDL.Factor] -> VHDL.Term) -> VHDL Kind+ go f = do+ x' <- Hoist.lift <$> compLoop x+ y' <- Hoist.lift <$> compLoop y+ return $ Hoist.T $ f [x', y']+ compDomain factor (x :* y :* _)+ | Just Exp <- prj factor = do+ x' <- Hoist.lift <$> compLoop x+ y' <- Hoist.lift <$> compLoop y+ return $ Hoist.F $ VHDL.exp x' y'+ compDomain factor (x :* _)+ | Just Abs <- prj factor = do+ x' <- Hoist.lift <$> compLoop x+ return $ Hoist.F $ VHDL.abs x'+ | Just Not <- prj factor = do+ x' <- Hoist.lift <$> compLoop x+ return $ Hoist.F $ VHDL.not x'+ compDomain primary (x :* Nil)+ | Just (Qualified t) <- prj primary = do+ f <- compHType (undefined :: HExp (DenResult sig))+ x' <- Hoist.lift <$> compLoop x+ return $ Hoist.P $ VHDL.qualified f x'+ | Just (Conversion f) <- prj primary = do+ t <- compHType (undefined :: HExp (DenResult sig))+ x' <- Hoist.lift <$> compLoop x+ return $ Hoist.P $ VHDL.cast t x'+ compDomain primary args+ | Just (Name n) <- prj primary = return $ Hoist.P $ VHDL.name n+ | Just (Literal i) <- prj primary = return $ Hoist.P $ VHDL.lit $ format i+ | Just (Aggregate xs) <- prj primary =+ let maps = fmap (Hoist.lift . VHDL.lit . format)+ in return $ Hoist.P $ VHDL.aggregate $ maps xs+ | Just (Function f _) <- prj primary = do+ as <- sequence $ listArgs compLoop args+ return $ Hoist.P $ VHDL.function (VHDL.Ident f) (fmap Hoist.lift as)+ | Just (Allocator) <- prj primary = undefined++--------------------------------------------------------------------------------
+ src/Language/Embedded/Hardware/Expression/Frontend.hs view
@@ -0,0 +1,139 @@+module Language.Embedded.Hardware.Expression.Frontend where++import Language.Embedded.Hardware.Expression.Syntax++import Data.Bits (Bits)++import Prelude hiding (not, and, or, abs, rem, div, mod, exp)+import qualified Prelude as P++--------------------------------------------------------------------------------+-- *+--------------------------------------------------------------------------------++-- | Lifts a typed value to an expression.+value :: HType a => a -> HExp a+value i = sugarT (Literal i)++-- | Creates a variable from a string.+variable :: HType a => String -> HExp a+variable = sugarT . Name++-- | Casts an expression using supplied conversion function.+cast :: (HType a, HType b) => (a -> b) -> HExp a -> HExp b+cast f = sugarT (Conversion f)++--------------------------------------------------------------------------------++true, false :: HExp Bool+true = value True+false = value False++-- logical operators+and, or, xor, xnor, nand, nor :: HExp Bool -> HExp Bool -> HExp Bool+and = sugarT And+or = sugarT Or+xor = sugarT Xor+xnor = sugarT Xnor+nand = sugarT Nand+nor = sugarT Nor++-- relational operators+eq, neq :: (HType a, Eq a) => HExp a -> HExp a -> HExp Bool+eq = sugarT Eq+neq = sugarT Neq++lt, lte, gt, gte :: (HType a, Ord a) => HExp a -> HExp a -> HExp Bool+lt = sugarT Lt+lte = sugarT Lte+gt = sugarT Gt+gte = sugarT Gte++-- shift operators+sll, srl, sla, sra, rol, ror :: (HType a, Bits a, HType b, Integral b) => HExp a -> HExp b -> HExp a+sll = sugarT Sll+srl = sugarT Srl+sla = sugarT Sla+sra = sugarT Sra+rol = sugarT Rol+ror = sugarT Ror++-- adding operators+add, sub :: (HType a, Num a) => HExp a -> HExp a -> HExp a+add = sugarT Add+sub = sugarT Sub++cat :: (HType a, Read a, Show a) => HExp a -> HExp a -> HExp a+cat = sugarT Cat++-- multiplying operators+mul :: (HType a, Num a) => HExp a -> HExp a -> HExp a+mul = sugarT Mul++div, mod, rem :: (HType a, Integral a) => HExp a -> HExp a -> HExp a+div = sugarT Div+mod = sugarT Mod+rem = sugarT Rem++-- miscellaneous operators+exp :: (HType a, Num a, HType b, Integral b) => HExp a -> HExp b -> HExp a+exp = sugarT Exp++abs :: (HType a, Num a) => HExp a -> HExp a+abs = sugarT Abs++not :: HExp Bool -> HExp Bool+not = sugarT Not++--------------------------------------------------------------------------------++instance (HType a, Eq a) => Eq (HExp a)+ where+ (==) = error "VHDL: equality checking is not supported"++instance (HType a, Ord a) => Ord (HExp a)+ where+ compare = error "VHDL: compare is not supported"+ max = error "VHDL: max is not supported"+ min = error "VHDL: min is not supported"++instance (HType a, Bounded a) => Bounded (HExp a)+ where+ minBound = value minBound+ maxBound = value maxBound++instance (HType a, Enum a) => Enum (HExp a)+ where+ toEnum = error "VHDL: toEnum is not supported"+ fromEnum = error "VHDL: fromEnum is not supported"++instance (HType a, Real a) => Real (HExp a)+ where+ toRational = error "VHDL: toRational is not supported"++instance (HType a, Num a) => Num (HExp a)+ where+ fromInteger = value . fromInteger+ (+) = add+ (-) = sub+ (*) = mul+ abs = abs+ signum = error "VHDL: signum is not supported"++instance (HType a, Integral a) => Integral (HExp a)+ where+ quot = error "VHDL: quotient is not supported"+ rem = rem+ div = div+ mod = mod+ quotRem a b = (quot a b, rem a b)+ divMod a b = (div a b, mod a b)+ toInteger = error "VHDL: toInteger is not supported"++instance (HType a, Fractional a) => Fractional (HExp a)+ where+ (/) = error "VHDL: floating point division is not _yet_ supported"+ recip = (/) (value 1)+ fromRational = error "VHDL: fromRational is not supported" ++--------------------------------------------------------------------------------
+ src/Language/Embedded/Hardware/Expression/Hoist.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}++module Language.Embedded.Hardware.Expression.Hoist where++import Language.VHDL (+ Expression (..)+ , Relation (..)+ , ShiftExpression (..)+ , SimpleExpression (..)+ , Term (..)+ , Factor (..)+ , Primary (..)+ , Identifier (..)+ )++--------------------------------------------------------------------------------+-- * Lifting & hoisting of expressions.+--------------------------------------------------------------------------------++-- | Lift an expression into another.+class Lift a b where+ lift :: a -> b++-- base: we are the correct level.+instance {-# OVERLAPPING #-} Lift a a where+ lift = id++-- step: we can get to the correct level by stepping through the types.+instance {-# OVERLAPPABLE #-} (Hoist a, Lift (Next a) b) => Lift a b where+ lift = lift . hoist++--------------------------------------------------------------------------------++-- | Hoist an expression up one level.+class Hoist a where+ type Next a :: *+ hoist :: a -> Next a++instance Hoist Primary where+ type Next Primary = Factor+ hoist p = FacPrim p Nothing++instance Hoist Factor where+ type Next Factor = Term+ hoist f = Term f []++instance Hoist Term where+ type Next Term = SimpleExpression+ hoist t = SimpleExpression Nothing t []++instance Hoist SimpleExpression where+ type Next SimpleExpression = ShiftExpression+ hoist si = ShiftExpression si Nothing++instance Hoist ShiftExpression where+ type Next ShiftExpression = Relation+ hoist sh = Relation sh Nothing++instance Hoist Relation where+ type Next Relation = Expression+ hoist r = ENand r Nothing++instance Hoist Expression where+ type Next Expression = Primary+ hoist e = PrimExp e++--------------------------------------------------------------------------------+-- ... I need to replace these ...+--------------------------------------------------------------------------------+ +-- | A collection of hardware expression types.+--+-- Going from "Expr a -> VHDL.Exp" means recovering the structure of VHDL's+-- expressions since VHDL.Exp isn't a single type. Hence the need for "Kind".+data Kind = E Expression | R Relation | Sh ShiftExpression | Si SimpleExpression+ | T Term | F Factor | P Primary++instance Lift Kind Expression where+ lift (E e) = lift e+ lift (R r) = lift r+ lift (Sh sh) = lift sh+ lift (Si si) = lift si+ lift (T t) = lift t+ lift (F f) = lift f+ lift (P p) = lift p++instance Lift Kind Relation where+ lift (E e) = lift e+ lift (R r) = lift r+ lift (Sh sh) = lift sh+ lift (Si si) = lift si+ lift (T t) = lift t+ lift (F f) = lift f+ lift (P p) = lift p++instance Lift Kind ShiftExpression where+ lift (E e) = lift e+ lift (R r) = lift r+ lift (Sh sh) = lift sh+ lift (Si si) = lift si+ lift (T t) = lift t+ lift (F f) = lift f+ lift (P p) = lift p++instance Lift Kind SimpleExpression where+ lift (E e) = lift e+ lift (R r) = lift r+ lift (Sh sh) = lift sh+ lift (Si si) = lift si+ lift (T t) = lift t+ lift (F f) = lift f+ lift (P p) = lift p++instance Lift Kind Term where+ lift (E e) = lift e+ lift (R r) = lift r+ lift (Sh sh) = lift sh+ lift (Si si) = lift si+ lift (T t) = lift t+ lift (F f) = lift f+ lift (P p) = lift p++instance Lift Kind Factor where+ lift (E e) = lift e+ lift (R r) = lift r+ lift (Sh sh) = lift sh+ lift (Si si) = lift si+ lift (T t) = lift t+ lift (F f) = lift f+ lift (P p) = lift p++instance Lift Kind Primary where+ lift (E e) = lift e+ lift (R r) = lift r+ lift (Sh sh) = lift sh+ lift (Si si) = lift si+ lift (T t) = lift t+ lift (F f) = lift f+ lift (P p) = lift p++--------------------------------------------------------------------------------
+ src/Language/Embedded/Hardware/Expression/Represent.hs view
@@ -0,0 +1,141 @@+module Language.Embedded.Hardware.Expression.Represent+ ( Tagged (..)+ , Rep (..)+ ) where++import Language.Embedded.VHDL (VHDL)+import Language.Embedded.VHDL.Monad (newLibrary, newImport)+import Language.Embedded.VHDL.Monad.Type++import Data.Int+import Data.Word++import Data.Char (intToDigit)+import Data.Bits (shiftR)+import Text.Printf (printf)+import Numeric (showIntAtBase)++import Data.ByteString (ByteString)+import qualified Data.ByteString as B++--------------------------------------------------------------------------------+-- * Representable types (until I come up with a solution free of VHDL stuff).+--------------------------------------------------------------------------------++-- | Tag a value with some (possibly) interesting information+newtype Tagged s b = Tag { unTag :: b }++-- | A 'rep'resentable value.+class Rep a+ where+ width :: Tagged a Int+ typed :: Tagged a Type+ declare :: a -> VHDL ()+ format :: a -> String++declareBoolean :: VHDL ()+declareBoolean =+ do newLibrary "IEEE"+ newImport "IEEE.std_logic_1164"++declareNumeric :: VHDL ()+declareNumeric =+ do newLibrary "IEEE"+ newImport "IEEE.std_logic_1164"+ newImport "IEEE.numeric_std"++--------------------------------------------------------------------------------+-- ** Boolean++instance Rep Bool where+ width = Tag 1+ typed = Tag std_logic+ declare _ = declareBoolean+ format True = "1"+ format False = "0"++--------------------------------------------------------------------------------+-- ** Signed++instance Rep Int8 where+ width = Tag 8+ typed = Tag signed8+ declare _ = declareNumeric+ format = convert++instance Rep Int16 where+ width = Tag 16+ typed = Tag signed16+ declare _ = declareNumeric+ format = convert++instance Rep Int32 where+ width = Tag 32+ typed = Tag signed32+ declare _ = declareNumeric+ format = convert++instance Rep Int64 where+ width = Tag 64+ typed = Tag signed64+ declare _ = declareNumeric+ format = convert++--------------------------------------------------------------------------------+-- ** Unsigned++instance Rep Word8 where+ width = Tag 8+ typed = Tag usigned8+ declare _ = declareNumeric+ format = convert++instance Rep Word16 where+ width = Tag 16+ typed = Tag usigned16+ declare _ = declareNumeric+ format = convert++instance Rep Word32 where+ width = Tag 32+ typed = Tag usigned32+ declare _ = declareNumeric+ format = convert++instance Rep Word64 where+ width = Tag 64+ typed = Tag usigned64+ declare _ = declareNumeric+ format = convert++--------------------------------------------------------------------------------+-- * Converting Integers to their Binrary representation+--------------------------------------------------------------------------------++-- | Convert an Integral to its binary representation+convert :: Integral a => a -> String+convert = foldr1 (++) . fmap w2s . B.unpack . i2bs . toInteger++-- | Go over an Integer and convert it into a bytestring containing its+-- binary representation+i2bs :: Integer -> ByteString+i2bs x = B.reverse . B.unfoldr (fmap chunk) . Just $ sign x+ where+ sign :: (Num a, Ord a) => a -> a+ sign | x < 0 = subtract 1 . negate+ | otherwise = id++ chunk :: Integer -> (Word8, Maybe Integer)+ chunk x = (b, i)+ where+ b = sign (fromInteger x)+ i | x >= 128 = Just (x `shiftR` 8)+ | otherwise = Nothing++-- | Shows a word with zero padding+--+-- I assum the negative numbers to already be padded with ones+w2s :: Word8 -> String+w2s w = printf "%08s" $ showIntAtBase 2 intToDigit w ""++--------------------------------------------------------------------------------
+ src/Language/Embedded/Hardware/Expression/Syntax.hs view
@@ -0,0 +1,375 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}++module Language.Embedded.Hardware.Expression.Syntax where++import Language.Syntactic+import Language.Syntactic.Functional (Denotation, Eval(..), EvalEnv)++import Language.Embedded.Hardware.Command+import Language.Embedded.Hardware.Interface+import Language.Embedded.Hardware.Expression.Represent++import Data.Bits (Bits)+import Data.Typeable (Typeable)+import qualified Data.Bits as Bits++--------------------------------------------------------------------------------+-- * Syntax of hardware expressions.+--------------------------------------------------------------------------------++-- | Collection of required classes for hardware expressions.+class (Typeable a, Rep a, Eq a) => HType a+instance (Typeable a, Rep a, Eq a) => HType a++type instance PredicateExp HExp = HType++-- | Domain of expressions.+type Dom =+ Expression+ :+: Relational+ :+: Shift+ :+: Simple+ :+: Term+ :+: Factor+ :+: Primary++-- | Typed expressions.+data T sig+ where+ T :: HType (DenResult sig) => { unT :: Dom sig } -> T sig++-- | Specialized sugarSym for T.+sugarT+ :: ( Signature (SmartSig fi), sub :<: Dom+ , T :<: SmartSym fi+ , SyntacticN f fi+ , SmartFun (SmartSym fi) (SmartSig fi) ~ fi+ , HType (DenResult (SmartSig fi)))+ => sub (SmartSig fi)+ -> f+sugarT sym = sugarSym (T $ inj sym)++-- | Hardware expressions.+newtype HExp a = HExp { unHExp :: ASTF T a }++instance Syntactic (HExp a)+ where+ type Domain (HExp a) = T+ type Internal (HExp a) = a++ desugar = unHExp+ sugar = HExp++--------------------------------------------------------------------------------+-- ** Syntax.++-- | Logical expressions.+data Expression sig+ where+ And :: Expression (Bool :-> Bool :-> Full Bool)+ Or :: Expression (Bool :-> Bool :-> Full Bool)+ Xor :: Expression (Bool :-> Bool :-> Full Bool)+ Xnor :: Expression (Bool :-> Bool :-> Full Bool)+ Nand :: Expression (Bool :-> Bool :-> Full Bool)+ Nor :: Expression (Bool :-> Bool :-> Full Bool)++-- | Relational expressions.+data Relational sig+ where+ Eq :: (HType a) => Relational (a :-> a :-> Full Bool)+ Neq :: (HType a) => Relational (a :-> a :-> Full Bool)+ Lt :: (HType a, Ord a) => Relational (a :-> a :-> Full Bool)+ Lte :: (HType a, Ord a) => Relational (a :-> a :-> Full Bool)+ Gt :: (HType a, Ord a) => Relational (a :-> a :-> Full Bool)+ Gte :: (HType a, Ord a) => Relational (a :-> a :-> Full Bool)++-- | Bit vector expressions.+data Shift sig+ where+ Sll :: (HType a, Bits a, HType b, Integral b) => Shift (a :-> b :-> Full a)+ Srl :: (HType a, Bits a, HType b, Integral b) => Shift (a :-> b :-> Full a)+ Sla :: (HType a, Bits a, HType b, Integral b) => Shift (a :-> b :-> Full a)+ Sra :: (HType a, Bits a, HType b, Integral b) => Shift (a :-> b :-> Full a)+ Rol :: (HType a, Bits a, HType b, Integral b) => Shift (a :-> b :-> Full a)+ Ror :: (HType a, Bits a, HType b, Integral b) => Shift (a :-> b :-> Full a)++-- | Numerical expressions.+data Simple sig+ where+ Neg :: (HType a, Num a) => Simple (a :-> Full a)+ Pos :: (HType a, Num a) => Simple (a :-> Full a)+ Add :: (HType a, Num a) => Simple (a :-> a :-> Full a)+ Sub :: (HType a, Num a) => Simple (a :-> a :-> Full a)+ Cat :: (HType a, Show a, Read a) => Simple (a :-> a :-> Full a)++-- | Integral expressions.+data Term sig+ where+ Mul :: (HType a, Num a) => Term (a :-> a :-> Full a)+ Div :: (HType a, Integral a) => Term (a :-> a :-> Full a)+ Mod :: (HType a, Integral a) => Term (a :-> a :-> Full a)+ Rem :: (HType a, Integral a) => Term (a :-> a :-> Full a)++-- | ...+data Factor sig+ where+ Exp :: (HType a, Num a, HType b, Integral b) => Factor (a :-> b :-> Full a)+ Abs :: (HType a, Num a) => Factor (a :-> Full a)+ Not :: Factor (Bool :-> Full Bool)++-- | ...+data Primary sig+ where+ Name :: (HType a) => String -> Primary (Full a)+ Literal :: (HType a) => a -> Primary (Full a)+ Aggregate :: (HType a) => [a] -> Primary (Full [a])+ Function :: (Signature sig) => String -> Denotation sig -> Primary sig+ Qualified :: (HType a, HType b) => b -> Primary (a :-> Full a)+ Conversion :: (HType a, HType b) => (a -> b) -> Primary (a :-> Full b)+ Allocator :: (HType a) => Primary (Full a)++--------------------------------------------------------------------------------+-- ** Syntactic instances.++instance CompArrayIx HExp++instance Equality T+ where+ equal (T s) (T t) = equal s t+ hash (T s) = hash s++instance StringTree T+ where+ stringTreeSym as (T s) = stringTreeSym as (T s)++instance Symbol T+ where+ symSig (T s) = symSig s++instance Render T+ where+ renderSym (T s) = renderSym s+ renderArgs as (T s) = renderArgs as s++instance Equality Expression+instance StringTree Expression++instance Symbol Expression+ where+ symSig And = signature+ symSig Or = signature+ symSig Xor = signature+ symSig Xnor = signature+ symSig Nand = signature+ symSig Nor = signature++instance Render Expression+ where+ renderSym And = "and"+ renderSym Or = "or"+ renderSym Xor = "xor"+ renderSym Xnor = "xnor"+ renderSym Nand = "nand"+ renderSym Nor = "nor"++instance Eval Expression+ where+ evalSym And = (&&)+ evalSym Or = (||)+ evalSym Xor = \x y -> (x && Prelude.not y) || (Prelude.not x && y)+ evalSym Xnor = \x y -> (Prelude.not x && Prelude.not y) || (x && y)+ evalSym Nand = \x y -> Prelude.not (x && y)+ evalSym Nor = \x y -> Prelude.not (x || y)++instance EvalEnv Expression env++instance Equality Relational+instance StringTree Relational++instance Symbol Relational+ where+ symSig Eq = signature+ symSig Neq = signature+ symSig Lt = signature+ symSig Lte = signature+ symSig Gt = signature+ symSig Gte = signature++instance Render Relational+ where+ renderSym Eq = "(==)"+ renderSym Neq = "(/=)"+ renderSym Lt = "(<)"+ renderSym Lte = "(<=)"+ renderSym Gt = "(>)"+ renderSym Gte = "(>=)"++instance Eval Relational+ where+ evalSym Eq = (==)+ evalSym Neq = (/=)+ evalSym Lt = (<)+ evalSym Lte = (<=)+ evalSym Gt = (>)+ evalSym Gte = (>=)++instance EvalEnv Relational env++instance Equality Shift+instance StringTree Shift++instance Symbol Shift+ where+ symSig Sll = signature+ symSig Srl = signature+ symSig Sla = signature+ symSig Sra = signature+ symSig Rol = signature+ symSig Ror = signature++instance Render Shift+ where+ renderSym Sll = "sll"+ renderSym Srl = "srl"+ renderSym Sla = "sla"+ renderSym Sra = "sra"+ renderSym Rol = "rol"+ renderSym Ror = "ror"++instance Eval Shift+ where+ evalSym Sll = \x i -> Bits.shiftL x (fromIntegral i)+ evalSym Srl = \x i -> shiftLR x (fromIntegral i)+ where+ shiftLR :: Bits a => a -> Int -> a+ shiftLR x n = let y = Bits.shiftR x n in+ case Bits.bitSizeMaybe x of+ Just i -> foldr (flip Bits.clearBit) y [i - n `Prelude.mod` i .. i]+ Nothing -> y+ evalSym Sla = \x i -> Bits.shiftL x (fromIntegral i)+ evalSym Sra = \x i -> Bits.shiftR x (fromIntegral i)+ evalSym Rol = \x i -> Bits.rotateL x (fromIntegral i)+ evalSym Ror = \x i -> Bits.rotateR x (fromIntegral i)++instance EvalEnv Shift env++instance Equality Simple+instance StringTree Simple++instance Symbol Simple+ where+ symSig Neg = signature+ symSig Pos = signature+ symSig Add = signature+ symSig Sub = signature+ symSig Cat = signature++instance Render Simple+ where+ renderSym Neg = "(-)"+ renderSym Pos = "id"+ renderSym Add = "(+)"+ renderSym Sub = "(-)"+ renderSym Cat = "(&)"++instance Eval Simple+ where+ evalSym Neg = negate+ evalSym Pos = id+ evalSym Add = (+)+ evalSym Sub = (-)+ evalSym Cat = \x y -> read (show x ++ show y)++instance EvalEnv Simple env++instance Equality Term+instance StringTree Term++instance Symbol Term+ where+ symSig Mul = signature+ symSig Div = signature+ symSig Mod = signature+ symSig Rem = signature++instance Render Term+ where+ renderSym Mul = "(*)"+ renderSym Div = "(/)"+ renderSym Mod = "(%)"+ renderSym Rem = "rem"++instance Eval Term+ where+ evalSym Mul = (*)+ evalSym Div = Prelude.div+ evalSym Mod = Prelude.mod+ evalSym Rem = Prelude.rem++instance EvalEnv Term env++instance Equality Factor+instance StringTree Factor++instance Symbol Factor+ where+ symSig Exp = signature+ symSig Abs = signature+ symSig Not = signature++instance Render Factor+ where+ renderSym Exp = "(**)"+ renderSym Abs = "abs"+ renderSym Not = "not"++instance Eval Factor+ where+ evalSym Exp = (^)+ evalSym Abs = Prelude.abs+ evalSym Not = Prelude.not++instance EvalEnv Factor env++instance Equality Primary+instance StringTree Primary++instance Symbol Primary+ where+ symSig (Name _) = signature+ symSig (Literal _) = signature+ symSig (Aggregate _) = undefined+ symSig (Function _ _) = signature+ symSig (Qualified _) = signature+ symSig (Conversion _) = signature+ symSig (Allocator) = signature++instance Render Primary+ where+ renderSym (Name _) = "name"+ renderSym (Literal _) = "lit"+ renderSym (Aggregate _) = "agg"+ renderSym (Function _ _) = "fun"+ renderSym (Qualified _) = "qual"+ renderSym (Conversion _) = "conv"+ renderSym (Allocator) = "alloc"++instance Eval Primary+ where+ evalSym (Name _) = error "cannot eval open names!"+ evalSym (Literal i) = i+ evalSym (Aggregate xs) = xs+ evalSym (Function _ f) = f+ evalSym (Qualified _) = error "todo: eval qualified names."+ evalSym (Conversion f) = f+ evalSym (Allocator) = undefined++instance EvalEnv Primary env++--------------------------------------------------------------------------------
+ src/Language/Embedded/Hardware/Interface.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}++module Language.Embedded.Hardware.Interface where++import Language.VHDL (Expression)+import Language.Embedded.VHDL (VHDL, Type)+import Data.Constraint++--------------------------------------------------------------------------------+-- * Interface for evaluation and compilation of pure expressions into VHDL.+--------------------------------------------------------------------------------++-- | Constraint on the types of variables in a given expression language.+type family PredicateExp (exp :: * -> *) :: * -> Constraint++-- | General interface for evaluating expressions.+class EvaluateExp exp+ where+ -- | Literal expressions.+ litE :: PredicateExp exp a => a -> exp a++ -- | Evaluation of (closed) expressions.+ evalE :: PredicateExp exp a => exp a -> a++-- | General interface for compiling expressions.+class CompileExp exp+ where+ -- | Variable expressions.+ varE :: PredicateExp exp a => Integer -> exp a++ -- | Compilation of type kind.+ compT :: PredicateExp exp a => exp a -> VHDL Type++ -- | Compilation of expressions.+ compE :: PredicateExp exp a => exp a -> VHDL Expression++--------------------------------------------------------------------------------
+ src/Language/Embedded/VHDL.hs view
@@ -0,0 +1,12 @@+module Language.Embedded.VHDL+ ( module VHDL+ , module Language.Embedded.VHDL.Monad+ , module Language.Embedded.VHDL.Monad.Expression+ , module Language.Embedded.VHDL.Monad.Type+ ) where++import Language.VHDL as VHDL (Identifier(..), Mode(..), Direction(..)) ++import Language.Embedded.VHDL.Monad+import Language.Embedded.VHDL.Monad.Expression+import Language.Embedded.VHDL.Monad.Type
+ src/Language/Embedded/VHDL/Monad.hs view
@@ -0,0 +1,674 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}++-- used for the Ord/Eq inst. of XDeclaration etc.+{-# LANGUAGE StandaloneDeriving #-}++module Language.Embedded.VHDL.Monad (+ VHDL+ , VHDLT+ , VHDLEnv+ , emptyVHDLEnv+ + -- ^ run+ , runVHDLT, runVHDL, execVHDLT, execVHDL++ -- ^ pretty printing+ , prettyVHDL, prettyVHDLT++ -- ^ name generation+ , freshUnique, newSym, newLabel++ -- ^ imports+ , newLibrary, newImport++ -- ^ declarations+ , addPort, addGeneric+ , addGlobal, addLocal+ , addConcurrent, addSequential+ , addType, addComponent++ -- ^ statements+ , inProcess, inFor, inWhile, inConditional, inCase++ -- ^ structures+ , entity, architecture, package++ -- ^ common things+ , interfaceConstant, interfaceSignal, interfaceVariable+ , declareConstant, declareSignal, declareVariable+ , assignSignal, assignSignalS, assignVariable, assignArray++ , unconstrainedArray, constrainedArray+ ) where++import Language.VHDL++import Control.Applicative ((<$>))+import Control.Monad.Identity (Identity)+import Control.Monad.State (StateT, MonadState, MonadIO)+import qualified Control.Monad.Identity as CMI+import qualified Control.Monad.State as CMS++import Data.Maybe (catMaybes)+import Data.Foldable (toList)+import Data.Functor (fmap)+import Data.List (groupBy)+import Data.Set (Set)+import Data.Map (Map)+import qualified Data.Set as Set+import qualified Data.Map as Map++import Text.PrettyPrint (Doc)++import Prelude hiding (null, not, abs, exp, rem, mod, div, and, or)+import qualified Prelude as P++--------------------------------------------------------------------------------+-- * VHDL monad and environment.+--------------------------------------------------------------------------------++-- | Code generation state+data VHDLEnv = VHDLEnv+ { _unique :: !Integer+ , _designs :: [DesignUnit]+ , _context :: Set ContextItem+ , _types :: Set TypeDeclaration+ , _ports :: [InterfaceDeclaration]+ , _generics :: [InterfaceDeclaration]+ , _components :: Set ComponentDeclaration+ , _global :: [BlockDeclarativeItem]+ , _local :: [BlockDeclarativeItem]+ , _concurrent :: [ConcurrentStatement]+ , _sequential :: [SequentialStatement]+ }++-- | Initial state during code generation+emptyVHDLEnv = VHDLEnv+ { _unique = 0+ , _designs = []+ , _context = Set.empty+ , _types = Set.empty+ , _components = Set.empty+ , _ports = []+ , _generics = []+ , _global = []+ , _local = []+ , _concurrent = []+ , _sequential = []+ }++--------------------------------------------------------------------------------+-- * VHDL monad.++-- | Type constraints for the VHDL monads+type MonadV m = (Functor m, Applicative m, Monad m, MonadState VHDLEnv m)++-- | VHDL code generation monad+type VHDL = VHDLT Identity++-- | VHDL code genreation monad transformer.+newtype VHDLT m a = VHDLT { unVGenT :: StateT VHDLEnv m a }+ deriving ( Functor+ , Applicative+ , Monad+ , MonadState VHDLEnv+ , MonadIO+ )++-- | Run the VHDL code generation monad transformer.+runVHDLT :: Monad m => VHDLT m a -> VHDLEnv -> m (a, VHDLEnv)+runVHDLT m = CMS.runStateT (unVGenT m)++-- | -- | Executes the VHDL code generation monad transformer, returning only its final state.+execVHDLT :: Monad m => VHDLT m a -> VHDLEnv -> m VHDLEnv+execVHDLT m = CMS.execStateT (unVGenT m)++-- | Run the VHDL code generation monad.+runVHDL :: VHDL a -> VHDLEnv -> (a, VHDLEnv)+runVHDL m = CMI.runIdentity . runVHDLT m++-- | Executes the VHDL code generation monad, returning only its final state.+execVHDL :: VHDL a -> VHDLEnv -> VHDLEnv+execVHDL m = CMI.runIdentity . execVHDLT m++--------------------------------------------------------------------------------+-- ** Generating uniques.++-- | Generates a unique integer.+freshUnique :: MonadV m => m Integer+freshUnique =+ do u <- CMS.gets _unique+ CMS.modify (\e -> e { _unique = u + 1 })+ return u++-- | Generates a fresh and unique identifier.+newSym :: MonadV m => m Identifier+newSym = do i <- freshUnique; return (Ident $ 'v' : show i)++-- | Generates a fresh and unique label.+newLabel :: MonadV m => m Label+newLabel = do i <- freshUnique; return (Ident $ 'l' : show i)++--------------------------------------------------------------------------------+-- ** VHDL environment updates.++-- | Adds a new library import to the context.+newLibrary :: MonadV m => String -> m ()+newLibrary l = CMS.modify $ \s -> s { _context = Set.insert item (_context s) }+ where+ item :: ContextItem+ item = ContextLibrary (LibraryClause (LogicalNameList [Ident l]))++-- | Adds a new library use clause to the context (with an .ALL suffix by default).+newImport :: MonadV m => String -> m ()+newImport i = CMS.modify $ \s -> s { _context = Set.insert item (_context s) }+ where+ item :: ContextItem+ item = ContextUse (UseClause [SelectedName (PName (NSimple (Ident i))) (SAll)])++-- | Adds a port declaration to the entity.+addPort :: MonadV m => InterfaceDeclaration -> m ()+addPort p = CMS.modify $ \s -> s { _ports = p : (_ports s) }++-- | Adds a generic declaration to the entity.+addGeneric :: MonadV m => InterfaceDeclaration -> m ()+addGeneric g = CMS.modify $ \s -> s { _generics = g : (_generics s) }++-- | Adds a type declaration.+addType :: MonadV m => TypeDeclaration -> m ()+addType t = CMS.modify $ \s -> s { _types = Set.insert t (_types s) }++-- | Adds a component declaration.+addComponent :: MonadV m => ComponentDeclaration -> m ()+addComponent c = CMS.modify $ \s -> s { _components = Set.insert c (_components s) }++-- | Adds a global declaration.+addGlobal :: MonadV m => BlockDeclarativeItem -> m ()+addGlobal g = CMS.modify $ \s -> s { _global = g : (_global s) }++-- | Adds a local declaration.+addLocal :: MonadV m => BlockDeclarativeItem -> m ()+addLocal l = CMS.modify $ \s -> s { _local = l : (_local s) }++-- | Adds a concurrent statement.+addConcurrent :: MonadV m => ConcurrentStatement -> m ()+addConcurrent con = CMS.modify $ \s -> s { _concurrent = con : (_concurrent s) }++-- | Adds a sequential statement.+addSequential :: MonadV m => SequentialStatement -> m ()+addSequential seq = CMS.modify $ \s -> s { _sequential = seq : (_sequential s) }++--------------------------------------------------------------------------------+-- * Concurrent and sequential statements+--------------------------------------------------------------------------------++-- | Runs the given action inside a process.+inProcess :: MonadV m => Label -> [Identifier] -> m a -> m (a, ProcessStatement)+inProcess l is m =+ do oldLocals <- CMS.gets _local+ oldSequential <- CMS.gets _sequential+ CMS.modify $ \e -> e { _local = []+ , _sequential = [] }+ result <- m+ newLocals <- reverse <$> CMS.gets _local+ newSequential <- reverse <$> CMS.gets _sequential+ CMS.modify $ \e -> e { _local = oldLocals+ , _sequential = oldSequential }+ return ( result+ , ProcessStatement+ (Just l) -- label+ (False) -- postponed+ (sensitivity) -- sensitivitylist+ (translate $ merge $ newLocals) -- declarativepart+ (newSequential)) -- statementpart+ where+ sensitivity | P.null is = Nothing+ | otherwise = Just $ SensitivityList $ fmap NSimple is++-- | Run program in for loop.+inFor :: MonadV m => Identifier -> Range -> m () -> m (LoopStatement)+inFor i r m =+ do oldSequential <- CMS.gets _sequential+ CMS.modify $ \e -> e { _sequential = [] }+ m+ newSequential <- reverse <$> CMS.gets _sequential+ CMS.modify $ \e -> e { _sequential = oldSequential }+ return $+ LoopStatement+ (Nothing)+ (Just (IterFor (ParameterSpecification+ (i)+ (DRRange r))))+ (newSequential)++-- | Run program inside while loop.+inWhile :: MonadV m => Expression -> m () -> m (LoopStatement)+inWhile cont m =+ do oldSequential <- CMS.gets _sequential+ CMS.modify $ \e -> e { _sequential = [] }+ m+ newSequential <- reverse <$> CMS.gets _sequential+ CMS.modify $ \e -> e { _sequential = oldSequential }+ return $+ LoopStatement+ (Nothing)+ (Just (IterWhile cont))+ (newSequential)++-- | Conditional statements.+inConditional :: MonadV m => (Condition, m ()) -> [(Condition, m ())] -> m () -> m (IfStatement)+inConditional (c, m) os e =+ do let (cs, ns) = unzip os+ oldSequential <- CMS.gets _sequential+ CMS.modify $ \e -> e { _sequential = [] }+ m' <- contain m+ ns' <- mapM contain ns+ e' <- contain e+ CMS.modify $ \e -> e { _sequential = oldSequential }+ return $+ IfStatement+ (Nothing)+ (c, m')+ (zip cs ns')+ (maybeList e')+ where+ maybeList :: [SequentialStatement] -> Maybe [SequentialStatement]+ maybeList xs+ | P.null xs = Nothing+ | otherwise = Just xs++-- | Case statements.+inCase :: MonadV m => Expression -> [(Choices, m ())] -> m (CaseStatement)+inCase e choices =+ do let (cs, ns) = unzip choices+ oldSequential <- CMS.gets _sequential+ CMS.modify $ \e -> e { _sequential = [] }+ ns' <- mapM contain ns+ CMS.modify $ \e -> e { _sequential = oldSequential } + return $+ CaseStatement+ (Nothing)+ (e)+ (zipWith CaseStatementAlternative cs ns')++contain :: MonadV m => m () -> m [SequentialStatement]+contain m = do+ m -- do+ new <- reverse <$> CMS.gets _sequential -- get+ CMS.modify $ \e -> e { _sequential = [] } -- reset+ return new -- return++--------------------------------------------------------------------------------+-- * Design units+--------------------------------------------------------------------------------++-- ... design unit with context+addDesign :: MonadV m => LibraryUnit -> m ()+addDesign lib =+ do ctxt <- CMS.gets _context+ dsig <- CMS.gets _designs+ let item = DesignUnit (ContextClause (Set.toList ctxt)) lib+ CMS.modify $ \s -> s { _designs = item : dsig+ , _context = Set.empty+ }++-- .. design unit ignoring context+addDesign_ :: MonadV m => LibraryUnit -> m ()+addDesign_ lib = CMS.modify $ \s -> s { _designs = (DesignUnit (ContextClause []) lib) : (_designs s)}++--------------------------------------------------------------------------------+-- ** Architectures++-- | Wraps the given monadic action in an architecture, consuming all global+-- identifiers and concurrent statements it produces. Strings are its entity+-- and architecture names, respectively.+architecture :: MonadV m => Identifier -> Identifier -> m a -> m a+architecture entity name m =+ do oldGlobal <- CMS.gets _global+ oldConcurrent <- CMS.gets _concurrent+ CMS.modify $ \e -> e { _global = []+ , _concurrent = [] }+ result <- m+ newGlobal <- reverse <$> CMS.gets _global+ newConcurrent <- reverse <$> CMS.gets _concurrent+ addDesign_ $ LibrarySecondary $ SecondaryArchitecture $+ ArchitectureBody+ (name)+ (NSimple entity)+ (merge newGlobal)+ (newConcurrent)+ CMS.modify $ \e -> e { _global = oldGlobal+ , _concurrent = oldConcurrent }+ return result++--------------------------------------------------------------------------------+-- ** Entities++-- | Declares an entity with the given name by consuming all port-level+-- declaraions and context items produced by running the monadic action.+entity :: MonadV m => Identifier -> m a -> m a+entity name m =+ do oldPorts <- CMS.gets _ports+ oldGenerics <- CMS.gets _generics+ CMS.modify $ \e -> e { _ports = []+ , _generics = [] }+ result <- m+ newPorts <- reverse <$> CMS.gets _ports+ newGenerics <- reverse <$> CMS.gets _generics+ addDesign $ LibraryPrimary $ PrimaryEntity $+ EntityDeclaration+ (name)+ (EntityHeader+ (GenericClause <$> maybeNull newGenerics)+ (PortClause <$> maybeNull newPorts))+ ([])+ (Nothing)+ CMS.modify $ \e -> e { _ports = oldPorts+ , _generics = oldGenerics }+ return result+ where+ maybeNull :: [InterfaceDeclaration] -> Maybe InterfaceList+ maybeNull [] = Nothing+ maybeNull xs = Just $ InterfaceList $ merge xs++--------------------------------------------------------------------------------+-- ** Packages++-- | Declares a package with the given name by consuming all type declarations+-- produced by running the monadic action.+package :: MonadV m => String -> m a -> m a+package name m =+ do oldTypes <- CMS.gets _types+ CMS.modify $ \e -> e { _types = Set.empty }+ result <- m+ newTypes <- CMS.gets _types+ addDesign $ LibraryPrimary $ PrimaryPackage $+ PackageDeclaration+ (Ident name)+ (fmap PHDIType $ Set.toList newTypes)+ CMS.modify $ \e -> e { _types = oldTypes }+ return result++--------------------------------------------------------------------------------+-- * Pretty printing VHDL programs+--------------------------------------------------------------------------------++-- | Runs the VHDL monad and pretty prints its resulting VHDL program.+prettyVHDL :: VHDL a -> Doc+prettyVHDL = CMI.runIdentity . prettyVHDLT++-- | Runs the VHDL monad transformer and pretty prints its resulting VHDL program.+prettyVHDLT :: Monad m => VHDLT m a -> m Doc+prettyVHDLT m = prettyVEnv <$> execVHDLT m emptyVHDLEnv++--------------------------------------------------------------------------------++-- | Pretty print a VHDL environment.+--+-- *** Shouldn't use revers to fix ordering issues! Pair architectures/bodies+-- with their respective entities.+prettyVEnv :: VHDLEnv -> Doc+prettyVEnv env = pp (DesignFile $ types ++ archi)+ where+ archi = reverse $ _designs env+ types = reverse $ designTypes (_types env)++-- *** Scan type declarations for necessary imports instead.+-- *** Types are added in an ugly manner.+designTypes :: Set TypeDeclaration -> [DesignUnit]+designTypes set+ | Set.null set = []+ | otherwise = _designs . snd $ runVHDL pack emptyVHDLEnv+ where+ pack :: MonadV m => m ()+ pack = package "types" $ do+ -- *** Instead of importing every library possible the correct ones+ -- should be declared when adding a type through 'addType'.+ newLibrary "IEEE"+ newImport "IEEE.STD_LOGIC_1164"+ newImport "IEEE.NUMERIC_STD"+ CMS.modify $ \e -> e { _types = set }++--------------------------------------------------------------------------------+-- * Common things+--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+-- ** Ports/Generic declarations++interfaceConstant :: Identifier -> SubtypeIndication -> Maybe Expression -> InterfaceDeclaration+interfaceConstant i t e = InterfaceConstantDeclaration [i] t e++interfaceSignal :: Identifier -> Mode -> SubtypeIndication -> Maybe Expression -> InterfaceDeclaration+interfaceSignal i m t e = InterfaceSignalDeclaration [i] (Just m) t False e++interfaceVariable :: Identifier -> Mode -> SubtypeIndication -> Maybe Expression -> InterfaceDeclaration+interfaceVariable i m t e = InterfaceVariableDeclaration [i] (Just m) t e++--------------------------------------------------------------------------------+-- ** Array Declarations.++compositeTypeDeclaration :: Identifier -> CompositeTypeDefinition -> TypeDeclaration+compositeTypeDeclaration name t = TDFull (FullTypeDeclaration name (TDComposite t))++unconstrainedArray :: Identifier -> SubtypeIndication -> TypeDeclaration+unconstrainedArray name typ = compositeTypeDeclaration name $+ CTDArray (ArrU (UnconstrainedArrayDefinition [] typ))++constrainedArray :: Identifier -> SubtypeIndication -> Range -> TypeDeclaration+constrainedArray name typ range = compositeTypeDeclaration name $+ CTDArray (ArrC (ConstrainedArrayDefinition+ (IndexConstraint [DRRange range]) typ))++--------------------------------------------------------------------------------+-- ** Global/Local Declarations.++declareConstant :: Identifier -> SubtypeIndication -> Maybe Expression -> BlockDeclarativeItem+declareConstant i t e = BDIConstant $ ConstantDeclaration [i] t e++declareSignal :: Identifier -> SubtypeIndication -> Maybe Expression -> BlockDeclarativeItem+declareSignal i t e = BDISignal $ SignalDeclaration [i] t Nothing e++declareVariable :: Identifier -> SubtypeIndication -> Maybe Expression -> BlockDeclarativeItem+declareVariable i t e = BDIShared $ VariableDeclaration False [i] t e++--------------------------------------------------------------------------------+-- ** Assign Signal/Variable.++assignSignal :: Identifier -> Expression -> ConcurrentStatement+assignSignal i e = ConSignalAss $ CSASCond Nothing False $ + ConditionalSignalAssignment+ (TargetName (NSimple i))+ (Options False Nothing)+ (ConditionalWaveforms+ ([])+ ( WaveElem [WaveEExp e Nothing]+ , Nothing))++assignSignalS :: Identifier -> Expression -> SequentialStatement+assignSignalS i e = SSignalAss $+ SignalAssignmentStatement+ (Nothing)+ (TargetName (NSimple i))+ (Nothing)+ (WaveElem [WaveEExp e Nothing])++assignVariable :: Identifier -> Expression -> SequentialStatement+assignVariable i e = SVarAss $+ VariableAssignmentStatement+ (Nothing)+ (TargetName (NSimple i))+ (e)++assignArray :: Name -> Expression -> SequentialStatement+assignArray i e = SSignalAss $+ SignalAssignmentStatement+ (Nothing)+ (TargetName i)+ (Nothing)+ (WaveElem [WaveEExp e Nothing])++--------------------------------------------------------------------------------+-- Some helper classes and their instances+--------------------------------------------------------------------------------+--+-- I use BlockDeclarativeItem to represent all declarative items, which means we+-- have to translate them over to their correct VHDL kind when generating an AST++class Merge a+ where+ -- group two items if this holds+ group :: a -> a -> Bool++ -- merge in this way+ reduce :: [a] -> a++ merge :: [a] -> [a]+ merge = fmap reduce . groupBy group++instance Merge BlockDeclarativeItem+ where+ group l r = setBlockIds l [] == setBlockIds r []+ reduce bs@(b:_) = setBlockIds b $ concatMap getBlockIds bs++instance Merge InterfaceDeclaration+ where+ group l r = l { idecl_identifier_list = [] } == r { idecl_identifier_list = [] }+ reduce (x:xs) = x { idecl_identifier_list = ids x ++ concatMap ids xs }+ where ids = idecl_identifier_list++--------------------------------------------------------------------------------++setBlockIds :: BlockDeclarativeItem -> [Identifier] -> BlockDeclarativeItem+setBlockIds (BDIConstant c) is = BDIConstant $ c { const_identifier_list = is }+setBlockIds (BDISignal s) is = BDISignal $ s { signal_identifier_list = is }+setBlockIds (BDIShared v) is = BDIShared $ v { var_identifier_list = is }+setBlockIds (BDIFile f) is = BDIFile $ f { fd_identifier_list = is }+setBlockIds x _ = x++getBlockIds :: BlockDeclarativeItem -> [Identifier]+getBlockIds (BDIConstant c) = const_identifier_list c+getBlockIds (BDISignal s) = signal_identifier_list s+getBlockIds (BDIShared v) = var_identifier_list v+getBlockIds (BDIFile f) = fd_identifier_list f++class Declarative a+ where+ -- lists are used so we can fail without having to throw errors+ translate :: [BlockDeclarativeItem] -> [a]++instance Declarative ProcessDeclarativeItem+ where+ translate = catMaybes . fmap tryProcess++-- | Try to transform the declarative item into a process item+tryProcess :: BlockDeclarativeItem -> Maybe (ProcessDeclarativeItem)+tryProcess (BDIConstant c) = Just $ PDIConstant c+tryProcess (BDIShared v) = Just $ PDIVariable v+tryProcess (BDIFile f) = Just $ PDIFile f+tryProcess _ = Nothing++--------------------------------------------------------------------------------+-- Ord instance for use in sets+--------------------------------------------------------------------------------+--+-- *** These break the Ord rules but seems to be needed for Set.++deriving instance Ord ContextItem+deriving instance Ord LibraryClause+deriving instance Ord LogicalNameList+deriving instance Ord UseClause++instance Ord TypeDeclaration + where+ compare (TDFull l) (TDFull r) = compare (ftd_identifier l) (ftd_identifier r)+ compare (TDPartial l) (TDPartial r) = compare l r+ compare (TDFull l) _ = GT+ compare (TDPartial l) _ = LT++deriving instance Ord IncompleteTypeDeclaration++instance Ord ComponentDeclaration+ where+ compare l r = compare (comp_identifier l) (comp_identifier r)++deriving instance Ord SubtypeIndication+deriving instance Ord TypeMark++instance Ord Constraint+ where+ compare (CRange a) (CRange b) = compare a b+ compare _ _ = error "Ord not supported for index constraints"++deriving instance Ord RangeConstraint++instance Ord Range+ where+ compare (RSimple a b c) (RSimple x y z) =+ case compare a x of+ GT -> GT+ LT -> LT+ EQ -> case compare b y of+ GT -> GT+ LT -> LT+ EQ -> case compare c z of+ GT -> GT+ LT -> LT+ EQ -> EQ+ compare _ _ = error "Ord not supported for attribute ranges"++deriving instance Ord Direction+deriving instance Ord Expression+deriving instance Ord Relation+deriving instance Ord ShiftExpression+deriving instance Ord SimpleExpression+deriving instance Ord Term+deriving instance Ord Factor++instance Ord Primary+ where+ compare (PrimName a) (PrimName x) = compare a x++deriving instance Ord LogicalOperator+deriving instance Ord RelationalOperator+deriving instance Ord ShiftOperator+deriving instance Ord AddingOperator+deriving instance Ord Sign+deriving instance Ord MultiplyingOperator+deriving instance Ord MiscellaneousOperator+deriving instance Ord Identifier++instance Ord Name+ where+ compare (NSimple a) (NSimple x) = compare a x+ compare (NSelect a) (NSelect x) = compare a x+ compare (NIndex a) (NIndex x) = compare a x+ compare (NSlice a) (NSlice x) = compare a x+ compare (NAttr a) (NAttr x) = compare a x++deriving instance Ord StringLiteral+deriving instance Ord SelectedName++instance Ord Suffix+ where+ compare (SSimple a) (SSimple x) = compare a x+ compare (SChar a) (SChar x) = compare a x+ compare (SAll) (SAll) = EQ+ compare _ _ = error "Ord not supported for operator symbols"++deriving instance Ord CharacterLiteral+deriving instance Ord IndexedName+deriving instance Ord SliceName+deriving instance Ord DiscreteRange++instance Ord Prefix+ where+ compare (PName a) (PName x) = compare a x+ compare _ _ = error "Ord not supported for function names"++deriving instance Ord AttributeName+deriving instance Ord Signature++--------------------------------------------------------------------------------
+ src/Language/Embedded/VHDL/Monad/Expression.hs view
@@ -0,0 +1,167 @@+module Language.Embedded.VHDL.Monad.Expression+ ( and, or, xor, xnor, nand, nor+ , eq, neq, lt, lte, gt, gte+ , sll, srl, sla, sra, rol, ror+ , add, sub, cat, neg+ , mul, div, mod, rem+ , exp, abs, not+ , name, string, indexed, selected, slice+ , lit, null+ , aggregate, associate+ , function+ , qualified+ , cast+ , resize+ , range, downto, to+ ) where++import Language.VHDL++import Prelude hiding (and, or, div, mod, rem, exp, abs, not, null)++--------------------------------------------------------------------------------+-- * Expressions and their sub-layers.+--------------------------------------------------------------------------------++relation :: RelationalOperator -> ShiftExpression -> ShiftExpression -> Relation+relation r a b = Relation a (Just (r, b))++shiftexp :: ShiftOperator -> SimpleExpression -> SimpleExpression -> ShiftExpression+shiftexp s a b = ShiftExpression a (Just (s, b))++simplexp :: Maybe Sign -> AddingOperator -> [Term] -> SimpleExpression+simplexp s o (a:as) = SimpleExpression s a (fmap ((,) o) as)++term :: MultiplyingOperator -> [Factor] -> Term+term o (a:as) = Term a (fmap ((,) o) as)++--------------------------------------------------------------------------------+-- ** Expressions++and, or, xor, xnor :: [Relation] -> Expression+and = EAnd +or = EOr +xor = EXor +xnor = EXnor++nand, nor :: Relation -> Relation -> Expression+nand a b = ENand a (Just b)+nor a b = ENor a (Just b)++--------------------------------------------------------------------------------+-- ** Relations++eq, neq, lt, lte, gt, gte :: ShiftExpression -> ShiftExpression -> Relation+eq = relation Eq+neq = relation Neq+lt = relation Lt+lte = relation Lte+gt = relation Gt+gte = relation Gte++--------------------------------------------------------------------------------+-- ** Shift Expressions++sll, srl, sla, sra, rol, ror :: SimpleExpression -> SimpleExpression -> ShiftExpression+sll = shiftexp Sll+srl = shiftexp Srl+sla = shiftexp Sla+sra = shiftexp Sra+rol = shiftexp Rol+ror = shiftexp Ror++--------------------------------------------------------------------------------+-- ** Simple Expressions++add, sub, cat :: [Term] -> SimpleExpression+add = simplexp Nothing Plus+sub = simplexp Nothing Minus+cat = simplexp Nothing Concat++neg :: Term -> SimpleExpression+neg = simplexp (Just Negation) Plus . (: [])++--------------------------------------------------------------------------------+-- ** Terms++mul, div, mod, rem :: [Factor] -> Term+mul = term Times+div = term Div+mod = term Mod+rem = term Rem++--------------------------------------------------------------------------------+-- ** Factors++exp :: Primary -> Primary -> Factor+exp a b = FacPrim a (Just b)++abs, not :: Primary -> Factor+abs = FacAbs+not = FacNot++--------------------------------------------------------------------------------+-- ** Primaries++-- names+name :: String -> Primary+name = PrimName . NSimple . Ident++string :: String -> Primary+string = PrimLit . LitString . SLit++indexed :: Identifier -> Expression -> Name+indexed i l = NIndex $ IndexedName (PName $ NSimple i) [l]++selected :: Identifier -> Identifier -> Primary+selected p s = PrimName $ NSelect $ SelectedName (PName $ NSimple p) (SSimple s)++slice :: Identifier -> (SimpleExpression, SimpleExpression) -> Primary+slice i (f, t) = PrimName $ NSlice $ SliceName (PName $ NSimple i) (DRRange $ RSimple f DownTo t)++-- literals+lit :: Show i => i -> Primary+lit = PrimLit . LitNum . NLitPhysical . PhysicalLiteral Nothing . NSimple . Ident . show++null :: Primary+null = PrimLit LitNull++-- aggregates+aggregate :: [Expression] -> Primary+aggregate = PrimAgg . Aggregate . fmap (ElementAssociation Nothing)++associate :: [(Maybe Choices, Expression)] -> Primary+associate es = PrimAgg $ Aggregate $ map (uncurry ElementAssociation) es++-- function calls+function :: Identifier -> [Expression] -> Primary+function i [] = PrimFun $ FunctionCall (NSimple i) Nothing+function i xs = PrimFun+ . FunctionCall (NSimple i) . Just . AssociationList+ $ fmap (AssociationElement Nothing . APDesignator . ADExpression) xs++-- qualified expressions+qualified :: SubtypeIndication -> Expression -> Primary+qualified (SubtypeIndication _ t _) = PrimQual . QualExp t++-- type conversions+cast :: SubtypeIndication -> Expression -> Primary+cast (SubtypeIndication _ t _) = PrimTCon . TypeConversion t++--------------------------------------------------------------------------------+-- ** Utility++resize :: Expression -> Expression -> Primary+resize size exp = PrimFun $ FunctionCall name $ Just $ AssociationList [assoc size, assoc exp]+ where+ name = NSimple $ Ident "resize"+ assoc = AssociationElement Nothing . APDesignator . ADExpression++range :: SimpleExpression -> Direction -> SimpleExpression -> Range+range = RSimple++downto, to :: Direction+downto = DownTo+to = To++--------------------------------------------------------------------------------
+ src/Language/Embedded/VHDL/Monad/Type.hs view
@@ -0,0 +1,60 @@+module Language.Embedded.VHDL.Monad.Type+ ( Type+ , Kind(..)++ , std_logic+ , signed8, signed16, signed32, signed64+ , usigned8, usigned16, usigned32, usigned64+ ) where++import Language.VHDL++import Language.Embedded.VHDL.Monad.Expression (lit)++--------------------------------------------------------------------------------+-- * VHDL Types.+--------------------------------------------------------------------------------++-- | Type indication for signals/variables/..+type Type = SubtypeIndication++-- | The different kinds of signals/variables/.. that exist in VHDL.+data Kind = Constant | Signal | Variable | File++--------------------------------------------------------------------------------+-- ** Standard logic types.++std_logic :: Type+std_logic = SubtypeIndication Nothing (TMType (NSimple (Ident "std_logic"))) Nothing++--------------------------------------------------------------------------------+-- ** Signed & unsigned numbers.++arith :: String -> Int -> Type+arith typ range = SubtypeIndication Nothing+ (TMType (NSlice (SliceName+ (PName (NSimple (Ident typ)))+ (DRRange (RSimple (point (range - 1)) DownTo (point 0))))))+ (Nothing)+ where+ point :: Int -> SimpleExpression+ point i = SimpleExpression Nothing (Term (FacPrim (lit i) (Nothing)) []) []++signed, usigned :: Int -> Type+signed = arith "signed"+usigned = arith "unsigned"++signed8, signed16, signed32, signed64 :: Type+signed8 = signed 8+signed16 = signed 16+signed32 = signed 32+signed64 = signed 64++usigned8, usigned16, usigned32, usigned64 :: Type+usigned8 = usigned 8+usigned16 = usigned 16+usigned32 = usigned 32+usigned64 = usigned 64++-- .. add more ..+--------------------------------------------------------------------------------