imperative-edsl-vhdl (empty) → 0.2
raw patch · 12 files changed
+1889/−0 lines, 12 filesdep +basedep +bytestringdep +constraintssetup-changed
Dependencies added: base, bytestring, constraints, containers, language-vhdl, mtl, operational-alacarte, pretty
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- imperative-edsl-vhdl.cabal +49/−0
- src/Language/Embedded/VHDL.hs +16/−0
- src/Language/Embedded/VHDL/Command.hs +387/−0
- src/Language/Embedded/VHDL/Expression.hs +356/−0
- src/Language/Embedded/VHDL/Expression/Format.hs +127/−0
- src/Language/Embedded/VHDL/Expression/Hoist.hs +150/−0
- src/Language/Embedded/VHDL/Expression/Type.hs +75/−0
- src/Language/Embedded/VHDL/Interface.hs +41/−0
- src/Language/Embedded/VHDL/Monad.hs +556/−0
- src/Language/Embedded/VHDL/Monad/Expression.hs +100/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, 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
+ imperative-edsl-vhdl.cabal view
@@ -0,0 +1,49 @@+-- Initial imperative-edsl-vhdl.cabal generated by cabal init. For further+-- documentation, see http://haskell.org/cabal/users-guide/++name: imperative-edsl-vhdl+version: 0.2+synopsis: Deep embedding of VHDL programs with code generation.+-- description: +license: BSD3+license-file: LICENSE+author: Markus Aronsson+maintainer: mararon@chalmers.se+-- copyright: +category: Language+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10++library+ exposed-modules: Language.Embedded.VHDL,+ Language.Embedded.VHDL.Monad,+ Language.Embedded.VHDL.Monad.Expression,+ Language.Embedded.VHDL.Interface,+ Language.Embedded.VHDL.Expression,+ Language.Embedded.VHDL.Expression.Hoist,+ Language.Embedded.VHDL.Expression.Format,+ Language.Embedded.VHDL.Expression.Type,+ Language.Embedded.VHDL.Command++ -- other-modules: + other-extensions: TypeFamilies,+ KindSignatures,+ ConstraintKinds,+ GeneralizedNewtypeDeriving,+ StandaloneDeriving,+ MultiParamTypeClasses,+ FlexibleInstances,+ FlexibleContexts,+ UndecidableInstances+ + build-depends: base >=4 && <5,+ mtl >=2.2 && <3,+ bytestring,+ constraints,+ containers >=0.1 && <1,+ operational-alacarte >=0.1.1,+ language-vhdl >=0.1.1.0,+ pretty >=1.0+ hs-source-dirs: .,src+ default-language: Haskell2010
+ src/Language/Embedded/VHDL.hs view
@@ -0,0 +1,16 @@+module Language.Embedded.VHDL+ ( Mode(..)+ , module Language.Embedded.VHDL.Interface+ , module Language.Embedded.VHDL.Expression+ , module Language.Embedded.VHDL.Expression.Type+ , module Language.Embedded.VHDL.Expression.Format+ , module Language.Embedded.VHDL.Command+ ) where++import Language.VHDL (Mode(..))++import Language.Embedded.VHDL.Interface+import Language.Embedded.VHDL.Expression+import Language.Embedded.VHDL.Expression.Type+import Language.Embedded.VHDL.Expression.Format+import Language.Embedded.VHDL.Command
+ src/Language/Embedded/VHDL/Command.hs view
@@ -0,0 +1,387 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Language.Embedded.VHDL.Command where++import Language.VHDL (Identifier(..), Label, Expression, Mode(..))+import qualified Language.VHDL as V++import Language.Embedded.VHDL.Monad (VHDLT, VHDL)+import Language.Embedded.VHDL.Interface+import Language.Embedded.VHDL.Expression.Type (Type, Kind)+import qualified Language.Embedded.VHDL.Monad as M+import qualified Language.Embedded.VHDL.Expression.Type as T+import qualified Language.Embedded.VHDL.Expression.Hoist as H++import Control.Arrow (second)+import Control.Monad.Identity+import Control.Monad.Operational.Higher+import Control.Applicative+import Data.Typeable+import Data.ALaCarte++--------------------------------------------------------------------------------+-- *+--------------------------------------------------------------------------------++instance CompileExp exp => Interp (SequentialCMD exp) VHDL+ where+ interp = compileSequential++instance CompileExp exp => Interp (ConcurrentCMD exp) VHDL+ where+ interp = compileConcurrent++instance CompileExp exp => Interp (HeaderCMD exp) VHDL+ where+ interp = compileHeader++-- | Compile an VHDL program into a pretty printed text+compile :: (Interp instr VHDL, HFunctor instr) => Program instr a -> String+compile = show . M.prettyVHDL . interpret++--------------------------------------------------------------------------------++-- | Compile if 'exp' is set+compEM :: CompileExp exp => Maybe (exp a) -> VHDL (Maybe Expression)+compEM = maybe (return Nothing) (>>= return . Just) . fmap compE++-- | Compile hidden type+compTM :: forall exp a. (PredicateExp exp a, CompileExp exp) => Maybe (exp a) -> VHDL Type+compTM _ = compT (undefined :: exp a)++--------------------------------------------------------------------------------+-- ** Sequential commands offered by VHDL++data SequentialCMD (exp :: * -> *) (prog :: * -> *) a+ where+ Local+ :: PredicateExp exp a+ => Identifier+ -> Kind+ -> Maybe (exp a)+ -> SequentialCMD exp prog ()++ Assignment+ :: PredicateExp exp a+ => Identifier+ -> Kind+ -> exp a+ -> SequentialCMD exp prog ()++ If+ :: (exp Bool, prog ()) -- if+ -> [(exp Bool, prog ())] -- elseif*+ -> prog () -- else+ -> SequentialCMD exp prog ()++ Case+ :: PredicateExp exp a+ => exp a+ -> [(exp a, prog ())]+ -> Maybe (prog ())+ -> SequentialCMD exp prog ()+ +instance HFunctor (SequentialCMD exp)+ where+ hfmap _ (Local i k e) = Local i k e+ hfmap _ (Assignment i k e) = Assignment i k e+ hfmap f (If (b, t) os e) = If (b, f t) (map (second f) os) (f e)+ hfmap f (Case e cs d) = Case e (map (second f) cs) (fmap f d)++type instance IExp (SequentialCMD e) = e+type instance IExp (SequentialCMD e :+: i) = e++--------------------------------------------------------------------------------++-- | Declare local constands/variables/files+constantL, variableL, fileL+ :: (SequentialCMD (IExp instr) :<: instr, PredicateExp (IExp instr) a)+ => Identifier+ -> Maybe (IExp instr a)+ -> ProgramT instr m ()+constantL i = singleE . Local i T.Constant+variableL i = singleE . Local i T.Variable+fileL i = singleE . Local i T.File++-- | Assign a signal to some expression+(<==) :: (SequentialCMD (IExp instr) :<: instr, PredicateExp (IExp instr) a)+ => Identifier+ -> IExp instr a+ -> ProgramT instr m ()+(<==) i = singleE . Assignment i T.Signal++-- | Assign a variable to some expression+(==:) :: (SequentialCMD (IExp instr) :<: instr, PredicateExp (IExp instr) a)+ => Identifier+ -> IExp instr a+ -> ProgramT instr m ()+(==:) i = singleE . Assignment i T.Variable++-- | Conventional if statement+iff+ :: (SequentialCMD (IExp instr) :<: instr)+ => (IExp instr Bool, ProgramT instr m ())+ -> [(IExp instr Bool, ProgramT instr m ())]+ -> ProgramT instr m ()+ -> ProgramT instr m ()+iff th eif el = singleE $ If th eif el++-- | Conventional switch (or case) statement+switch+ :: (SequentialCMD (IExp instr) :<: instr, PredicateExp (IExp instr) a)+ => IExp instr a+ -> [(IExp instr a, ProgramT instr m ())]+ -> Maybe (ProgramT instr m ())+ -> ProgramT instr m ()+switch e choices def = singleE $ Case e choices def++--------------------------------------------------------------------------------++-- | Guards a program by some predicate+when+ :: (SequentialCMD (IExp instr) :<: instr, Monad m)+ => IExp instr Bool+ -> ProgramT instr m ()+ -> ProgramT instr m ()+when b prg = singleE $ If (b, prg) [] (return ())++-- | Standard 'if .. then .. else ..' statement+ifThen+ :: (SequentialCMD (IExp instr) :<: instr)+ => IExp instr Bool+ -> ProgramT instr m ()+ -> ProgramT instr m ()+ -> ProgramT instr m ()+ifThen b th el = singleE $ If (b, th) [] el+ +--------------------------------------------------------------------------------++compileSequential :: CompileExp exp => SequentialCMD exp VHDL a -> VHDL a+compileSequential (Local i k e) =+ do v <- compEM e+ t <- compTM e+ M.addLocal $ case k of+ T.Constant -> M.declConstant i t v+ T.Signal -> M.declSignal i t v+ T.Variable -> M.declVariable i t v+compileSequential (Assignment i k e) =+ do v <- compE e+ M.addSequential $ case k of+ T.Signal -> M.assignSignal i v+ _ -> M.assignVariable i v+compileSequential (If (b, th) eif els) =+ do let (cs, es) = unzip eif+ v <- compE b+ bs <- mapM compE cs+ s <- M.inConditional (v, th) (zip bs es) els+ M.addSequential $ V.SIf s+compileSequential (Case e choices def) =+ do let (cs, es) = unzip choices+ v <- compE e+ bs <- mapM (compE >=> return . lower) cs+ s <- M.inCase v (others def $ zip bs es)+ M.addSequential $ V.SCase s+ where+ lower :: V.Expression -> V.Choices+ lower exp = V.Choices . (:[]) . V.ChoiceSimple $+ case exp of+ (V.EAnd rels) -> head' rels+ (V.EOr rels) -> head' rels+ (V.EXor rels) -> head' rels+ (V.ENand r _) -> drop' r+ (V.ENor r _) -> drop' r+ (V.EXnor rels) -> head' rels+ where+ head' :: [V.Relation] -> V.SimpleExpression+ head' [] = H.lift $ V.PrimLit V.LitNull+ head' xs = drop' (head xs)++ drop' :: V.Relation -> V.SimpleExpression+ drop' (V.Relation (V.ShiftExpression x _) _) = x++ others :: Maybe x -> [(V.Choices, x)] -> [(V.Choices, x)]+ others (Nothing) cs = cs+ others (Just d) cs = cs ++ [(V.Choices [V.ChoiceOthers], d)]++--------------------------------------------------------------------------------+-- ** Concurrent commands offered by VHDL++data ConcurrentCMD exp (prog :: * -> *) a+ where+ Global+ :: PredicateExp exp a + => Identifier+ -> Kind+ -> Maybe (exp a)+ -> ConcurrentCMD exp prog ()++ Process+ :: Label+ -> [Identifier]+ -> prog ()+ -> ConcurrentCMD exp prog ()++ PortMap+ :: Identifier+ -> [Identifier]+ -> ConcurrentCMD exp prog ()++instance HFunctor (ConcurrentCMD exp)+ where+ hfmap _ (Global i k e) = Global i k e+ hfmap f (Process l is p) = Process l is (f p)+ hfmap _ (PortMap n is) = PortMap n is++type instance IExp (ConcurrentCMD e) = e+type instance IExp (ConcurrentCMD e :+: i) = e++--------------------------------------------------------------------------------++-- | Declare global constands/variables/files+constantG, signalG, variableG, fileG + :: (ConcurrentCMD (IExp instr) :<: instr, PredicateExp (IExp instr) a)+ => Identifier+ -> Maybe (IExp instr a)+ -> ProgramT instr m ()+constantG i = singleE . Global i T.Constant+signalG i = singleE . Global i T.Signal+variableG i = singleE . Global i T.Variable+fileG i = singleE . Global i T.File++-- | Declare a process+process+ :: (ConcurrentCMD (IExp instr) :<: instr)+ => String+ -> [Identifier]+ -> ProgramT instr m ()+ -> ProgramT instr m ()+process i is = singleE . Process (Ident i) is++--------------------------------------------------------------------------------++compileConcurrent :: CompileExp exp => ConcurrentCMD exp VHDL a -> VHDL a+compileConcurrent (Global i k e) =+ do v <- compEM e+ t <- compTM e+ M.addGlobal $ case k of+ T.Constant -> M.declConstant i t v+ T.Signal -> M.declSignal i t v + T.Variable -> M.declVariable i t v+compileConcurrent (Process l is p) =+ do (a, process) <- M.inProcess l is p+ M.addConcurrent (V.ConProcess process)+ return a+compileConcurrent (PortMap n is) =+ do let ads = fmap (V.ADSignal . V.NSimple) is+ lbl <- M.newLabel+ M.addConcurrent (M.portMap lbl n ads)+ +--------------------------------------------------------------------------------+-- ** Entity declaration related commands offered by VHDL++data DeclKind = Port | Generic++data HeaderCMD exp (prog :: * -> *) a+ where+ Declare+ :: PredicateExp exp a+ => DeclKind+ -> Identifier+ -> Kind+ -> Mode+ -> Maybe (exp a)+ -> HeaderCMD exp prog Identifier++ Architecture+ :: String+ -> prog a+ -> HeaderCMD exp prog a++ Record+ :: String+ -> [(String, Type)]+ -> HeaderCMD exp prog a++instance HFunctor (HeaderCMD exp)+ where+ hfmap _ (Declare d i k m e) = Declare d i k m e+ hfmap f (Architecture s p) = Architecture s (f p)+ hfmap _ (Record s es) = Record s es++type instance IExp (HeaderCMD e) = e+type instance IExp (HeaderCMD e :+: i) = e++--------------------------------------------------------------------------------++-- | Declare constands/signal/variables/files ports and generics+constantPort, constantGeneric, signalPort, signalGeneric, variablePort, variableGeneric, filePort, fileGeneric+ :: (HeaderCMD (IExp instr) :<: instr, PredicateExp (IExp instr) a)+ => Identifier+ -> Mode+ -> Maybe (IExp instr a)+ -> ProgramT instr m Identifier+constantPort i m = singleE . Declare Port i T.Constant m+constantGeneric i m = singleE . Declare Generic i T.Constant m+signalPort i m = singleE . Declare Port i T.Signal m+signalGeneric i m = singleE . Declare Generic i T.Signal m+variablePort i m = singleE . Declare Port i T.Variable m+variableGeneric i m = singleE . Declare Generic i T.Variable m+filePort i m = singleE . Declare Port i T.File m+fileGeneric i m = singleE . Declare Generic i T.File m++-- | Declares a clock input port+clock+ :: forall instr m.+ ( HeaderCMD (IExp instr) :<: instr+ , PredicateExp (IExp instr) Bool)+ => ProgramT instr m Identifier+clock = signalPort (Ident "clk") In (Nothing :: Maybe ((IExp instr) Bool))++-- | Declares a reset input port+reset+ :: forall instr m.+ ( HeaderCMD (IExp instr) :<: instr+ , PredicateExp (IExp instr) Bool)+ => ProgramT instr m Identifier+reset = signalPort (Ident "reset") In (Nothing :: Maybe ((IExp instr) Bool))++-- | Declare an architecture+architecture+ :: (HeaderCMD (IExp instr) :<: instr)+ => String+ -> ProgramT instr m a+ -> ProgramT instr m a+architecture name = singleE . Architecture name++--------------------------------------------------------------------------------++compileHeader :: CompileExp exp => HeaderCMD exp VHDL a -> VHDL a+compileHeader (Declare Port i k m e) =+ do v <- compEM e+ t <- compTM e+ M.addPort $ case k of+ T.Constant -> M.interfaceConstant i t v+ T.Signal -> M.interfaceSignal i m t v+ T.Variable -> M.interfaceVariable i m t v+ return i+compileHeader (Declare Generic i k m e) =+ do v <- compEM e+ t <- compTM e+ M.addGeneric $ case k of+ T.Constant -> M.interfaceConstant i t v+ T.Signal -> M.interfaceSignal i m t v+ T.Variable -> M.interfaceVariable i m t v+ return i+compileHeader (Architecture name prg) =+ do M.inArchitecture name prg+compileHeader (Record name es) =+ do undefined++--------------------------------------------------------------------------------
+ src/Language/Embedded/VHDL/Expression.hs view
@@ -0,0 +1,356 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Language.Embedded.VHDL.Expression+ ( Expr+ , not, and, or, xor, xnor, nand, nor+ , eq, neq+ , lt, lte, gt, gte+ , sll, srl, sla, sra, rol, ror+ , add, sub, cat+ , mul+ , div, mod, rem+ , neg+ , exp, abs+ , name, lit+ ) where++import Language.VHDL (Identifier(..), Expression)++import Language.Embedded.VHDL.Interface+import Language.Embedded.VHDL.Monad (VHDL)+import Language.Embedded.VHDL.Expression.Hoist+import Language.Embedded.VHDL.Expression.Format+import Language.Embedded.VHDL.Expression.Type hiding (Kind)+import qualified Language.Embedded.VHDL.Monad as M++import Data.Bits hiding (xor)+import Data.Dynamic+import Data.Maybe (fromJust)+import Data.Typeable++import Prelude hiding (not, and, or, div, mod, rem, exp, abs, null)+import qualified Prelude as P++--------------------------------------------------------------------------------+-- * VHDL Expression Type - a union of VHDLs' types + variables+--------------------------------------------------------------------------------++data Expr a+ where+ -- ^ ...+ Val :: Rep a => a -> Expr a+ Var :: Rep a => Identifier -> Expr a++ -- ^ ...+ Pair :: Expr a -> Expr b -> Expr (a, b)+ Fst :: Expr (a, b) -> Expr a+ Snd :: Expr (a, b) -> Expr b++ -- ^ VHDL Expressions+ + -- expression operators (plus Not)+ Not :: Expr Bool -> Expr Bool+ And :: Expr Bool -> Expr Bool -> Expr Bool+ Or :: Expr Bool -> Expr Bool -> Expr Bool+ Xor :: Expr Bool -> Expr Bool -> Expr Bool+ Xnor :: Expr Bool -> Expr Bool -> Expr Bool+ Nand :: Expr Bool -> Expr Bool -> Expr Bool+ Nor :: Expr Bool -> Expr Bool -> Expr Bool++ -- relational operators+ Eq :: Eq a => Expr a -> Expr a -> Expr Bool+ Neq :: Eq a => Expr a -> Expr a -> Expr Bool+ Lt :: Ord a => Expr a -> Expr a -> Expr Bool+ Lte :: Ord a => Expr a -> Expr a -> Expr Bool+ Gt :: Ord a => Expr a -> Expr a -> Expr Bool+ Gte :: Ord a => Expr a -> Expr a -> Expr Bool++ -- shift operators+ Sll :: (Bits a, Integral b) => Expr a -> Expr b -> Expr a+ Srl :: (Bits a, Integral b) => Expr a -> Expr b -> Expr a+ Sla :: (Bits a, Integral b) => Expr a -> Expr b -> Expr a+ Sra :: (Bits a, Integral b) => Expr a -> Expr b -> Expr a+ Rol :: (Bits a, Integral b) => Expr a -> Expr b -> Expr a+ Ror :: (Bits a, Integral b) => Expr a -> Expr b -> Expr a++ -- adding operators+ Neg :: Num a => Expr a -> Expr a+ Add :: Num a => Expr a -> Expr a -> Expr a+ Sub :: Num a => Expr a -> Expr a -> Expr a+ Cat :: Num a => Expr a -> Expr a -> Expr a++ -- multiplying operators+ Mul :: (Rep a, Num a) => Expr a -> Expr a -> Expr a+ Dif :: Fractional a => Expr a -> Expr a -> Expr a -- floating point division+ Div :: Integral a => Expr a -> Expr a -> Expr a -- integer division+ Mod :: Integral a => Expr a -> Expr a -> Expr a+ Rem :: Integral a => Expr a -> Expr a -> Expr a++ -- misc. operators (minus Not)+ Exp :: Floating a => Expr a -> Expr a -> Expr a+ Abs :: Num a => Expr a -> Expr a++type instance PredicateExp Expr = Rep++--------------------------------------------------------------------------------+-- ** Sugared constructs++class Rep (Internal a) => Syntactic a+ where+ type Internal a++ sugar :: a -> Expr (Internal a)+ desugar :: Expr (Internal a) -> a++instance Rep a => Syntactic (Expr a)+ where+ type Internal (Expr a) = a++ sugar = id+ desugar = id++instance (Syntactic a, Syntactic b) => Syntactic (a, b)+ where+ type Internal (a, b) = (Internal a, Internal b)++ sugar (a, b) = Pair (sugar a) (sugar b)+ desugar p = (desugar (Fst p), desugar (Snd p))++-- ...++--------------------------------------------------------------------------------+-- ** Useful Expr Instances++instance (Rep a, Bounded a) => Bounded (Expr a)+ where+ minBound = Val minBound+ maxBound = Val maxBound++instance (Rep a, Enum a) => Enum (Expr a) -- needed for integral+ where+ toEnum = error "toEnum not supported"+ fromEnum = error "fromEnum not supported"++instance (Rep a, Num a) => Num (Expr a)+ where+ fromInteger = Val . fromInteger+ (+) = Add+ (-) = Sub+ (*) = Mul+ abs = Abs+ signum = error "signum not implemented for Expr"++--------------------------------------------------------------------------------+-- * User interface+--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+-- ** Logical operators++and, or, xor, xnor, nand, nor :: Expr Bool -> Expr Bool -> Expr Bool++and = And+or = Or+xor = Xor+xnor = Xnor+nand = Nand+nor = Nor++--------------------------------------------------------------------------------+-- ** Relational operators++eq, neq :: Eq a => Expr a -> Expr a -> Expr Bool+lt, lte, gt, gte :: Ord a => Expr a -> Expr a -> Expr Bool++eq = Eq+neq = Neq+lt = Lt+lte = Lte+gt = Gt+gte = Gte++--------------------------------------------------------------------------------+-- ** Shift operators++sll, srl, sra, sla, rol, ror :: (Bits a, Integral b) => Expr a -> Expr b -> Expr a++sll = Sll+srl = Srl+sra = Sra+sla = Sla+rol = Rol+ror = Ror++--------------------------------------------------------------------------------+-- ** Adding operators++add, sub, cat :: Num a => Expr a -> Expr a -> Expr a++add = Add+sub = Sub+cat = Cat++--------------------------------------------------------------------------------+-- ** Multiplying operators++mul :: (Num a, Rep a) => Expr a -> Expr a -> Expr a+div, mod, rem :: Integral a => Expr a -> Expr a -> Expr a++mod = Mod+rem = Rem+mul = Mul+div = Div++--------------------------------------------------------------------------------+-- ** Sign operators++neg :: Num a => Expr a -> Expr a+neg = Neg++--------------------------------------------------------------------------------+-- ** Miscellaneous operators++not :: Expr Bool -> Expr Bool+not = Not++exp :: Floating a => Expr a -> Expr a -> Expr a+exp = Exp++abs :: Num a => Expr a -> Expr a+abs = Abs++--------------------------------------------------------------------------------+-- ** Naming operators++name :: Rep a => Identifier -> Expr a+name = Var++lit :: Rep a => a -> Expr a+lit = Val++--------------------------------------------------------------------------------+-- * Compilation of expressions+--------------------------------------------------------------------------------++instance CompileExp Expr+ where+ varE = Var+ compT = compileT+ compE = compileE++compileT :: forall a. Rep a => Expr a -> VHDL Type+compileT _ = return $ unTag $ (typed :: Tagged a Type)++compileE :: Expr a -> VHDL Expression+compileE = return . lift . go+ where+ go :: forall a. Expr a -> Kind+ go exp = case exp of+ Var (Ident i) -> P $ M.name i+ Val v -> P $ M.string $ format v++ And x y -> E $ M.and [lift (go x), lift (go y)]+ Or x y -> E $ M.or [lift (go x), lift (go y)]+ Xor x y -> E $ M.xor [lift (go x), lift (go y)]+ Xnor x y -> E $ M.xnor [lift (go x), lift (go y)]+ Nand x y -> E $ M.nand (lift (go x)) (lift (go y))+ Nor x y -> E $ M.nor (lift (go x)) (lift (go y))++ Eq x y -> R $ M.eq (lift (go x)) (lift (go y))+ Neq x y -> R $ M.neq (lift (go x)) (lift (go y))+ Lt x y -> R $ M.lt (lift (go x)) (lift (go y))+ Lte x y -> R $ M.lte (lift (go x)) (lift (go y))+ Gt x y -> R $ M.gt (lift (go x)) (lift (go y))+ Gte x y -> R $ M.gte (lift (go x)) (lift (go y))++ Sll x y -> Sh $ M.sll (lift (go x)) (lift (go y))+ Srl x y -> Sh $ M.srl (lift (go x)) (lift (go y))+ Sla x y -> Sh $ M.sla (lift (go x)) (lift (go y))+ Sra x y -> Sh $ M.sra (lift (go x)) (lift (go y))+ Rol x y -> Sh $ M.rol (lift (go x)) (lift (go y))+ Ror x y -> Sh $ M.ror (lift (go x)) (lift (go y))++ Neg x -> Si $ M.neg (lift (go x))+ Add x y -> Si $ M.add [lift (go x), lift (go y)]+ Sub x y -> Si $ M.sub [lift (go x), lift (go y)]+ Cat x y -> Si $ M.cat [lift (go x), lift (go y)]++ Mul x y -> P $ resize (unTag (width :: Tagged a Int))+ $ M.mul [lift (go x), lift (go y)]+ Div x y -> T $ M.div [lift (go x), lift (go y)]+ Mod x y -> T $ M.mod [lift (go x), lift (go y)]+ Rem x y -> T $ M.rem [lift (go x), lift (go y)]++ Exp x y -> F $ M.exp (lift (go x)) (lift (go y))+ Abs x -> F $ M.abs (lift (go x))+ Not x -> F $ M.not (lift (go x))++ -- todo ...+ Dif x y -> error "compilation of floating point division is not yet supported"++--------------------------------------------------------------------------------+-- * Evaluation of Expressions+--------------------------------------------------------------------------------++instance EvaluateExp Expr+ where+ litE = Val+ evalE = evaluate++evaluate :: Expr a -> a+evaluate exp = case exp of+ Var v -> error "eval: free variable"+ Val v -> v+ + Not x -> un P.not x+ And x y -> bin (&&) x y+ Or x y -> bin (||) x y+ Xor x y -> bin xor x y+ Xnor x y -> P.not $ bin xor x y+ Nand x y -> P.not $ bin (&&) x y+ Nor x y -> P.not $ bin (||) x y++ Eq x y -> bin (==) x y+ Neq x y -> bin (/=) x y+ Lt x y -> bin (<) x y+ Lte x y -> bin (<=) x y+ Gt x y -> bin (>) x y+ Gte x y -> bin (>=) x y++ Sll x y -> bin (\a b -> shiftL a (fromIntegral b) `clearBit` msb a) x y+ Srl x y -> bin (\a b -> shiftR a (fromIntegral b) `clearBit` msb a) x y + Sla x y -> bin (\a -> shiftL a . fromIntegral) x y+ Sra x y -> bin (\a -> shiftR a . fromIntegral) x y+ Rol x y -> bin (\a -> rotateL a . fromIntegral) x y+ Ror x y -> bin (\a -> rotateR a . fromIntegral) x y++ Neg x -> un negate x+ Add x y -> bin (+) x y+ Sub x y -> bin (-) x y+ Cat x y -> error "evaluation of bit concatenation not yet implemented" ++ Mul x y -> bin (*) x y+ Dif x y -> bin (/) x y+ Div x y -> bin P.div x y+ Mod x y -> bin P.mod x y+ Rem x y -> bin P.rem x y++ Exp x y -> bin (**) x y+ Abs x -> un P.abs x+ where+ xor a b = (a || b) && P.not (a && b)+ + un :: (a -> b) -> Expr a -> b+ un f x = f (evaluate x)++ bin :: (a -> b -> c) -> Expr a -> Expr b -> c+ bin f x y = f (evaluate x) (evaluate y)++ msb :: Bits a => a -> Int+ msb = fromJust . bitSizeMaybe++--------------------------------------------------------------------------------
+ src/Language/Embedded/VHDL/Expression/Format.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Language.Embedded.VHDL.Expression.Format+ ( Tagged(..)+ , Rep(..)+ ) where++import Language.Embedded.VHDL.Expression.Type++import Data.Bits+import Data.Char (intToDigit)+import Data.Word+import Data.Int+import Text.Printf (printf)+import Numeric (showIntAtBase)+import qualified Data.ByteString as B++--------------------------------------------------------------------------------+-- * Kludge - until I come up with a better solution+--------------------------------------------------------------------------------++-- | 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+ format :: a -> String++--------------------------------------------------------------------------------+-- ** Boolean++instance Rep Bool where+ width = Tag 1+ typed = Tag std_logic+ format True = "1"+ format False = "0"++--------------------------------------------------------------------------------+-- ** Signed++instance Rep Int8 where+ width = Tag 8+ typed = Tag signed8+ format = convert++instance Rep Int16 where+ width = Tag 16+ typed = Tag signed16+ format = convert++instance Rep Int32 where+ width = Tag 32+ typed = Tag signed32+ format = convert++instance Rep Int64 where+ width = Tag 64+ typed = Tag signed64+ format = convert++--------------------------------------------------------------------------------+-- ** Unsigned++instance Rep Word8 where+ width = Tag 8+ typed = Tag usigned8+ format = convert++instance Rep Word16 where+ width = Tag 16+ typed = Tag usigned16+ format = convert++instance Rep Word32 where+ width = Tag 32+ typed = Tag usigned32+ format = convert++instance Rep Word64 where+ width = Tag 64+ typed = Tag usigned64+ format = convert++--------------------------------------------------------------------------------+-- ** Records++instance (Rep a, Rep b) => Rep (a, b) where+ width = Tag (unTag (width :: Tagged a Int) + unTag (width :: Tagged b Int))+ typed = undefined+ format = undefined++-- ...++--------------------------------------------------------------------------------+-- * 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 -> B.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/VHDL/Expression/Hoist.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}++module Language.Embedded.VHDL.Expression.Hoist where++import Language.VHDL (+ Expression(..)+ , Relation(..)+ , ShiftExpression(..)+ , SimpleExpression(..)+ , Term(..)+ , Factor(..)+ , Primary(..)+ , Identifier(..)+ )++--------------------------------------------------------------------------------+-- * Lifting / Hoisting of VHDL Expression+--------------------------------------------------------------------------------++-- | Lift any number of levels+class Lift a b where+ lift :: a -> b++-- | Base case: we are the correct level+instance {-# OVERLAPPING #-} Lift a a where+ lift = id++-- | Step case: we can get to the correct level by using a kind of induction step+instance {-# OVERLAPPABLE #-} (Hoist a, Lift (Next a) b) => Lift a b where+ lift = lift . hoist++--------------------------------------------------------------------------------++-- | Lift 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 s = ShiftExpression s Nothing++instance Hoist ShiftExpression where+ type Next ShiftExpression = Relation+ hoist s = Relation s 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++--------------------------------------------------------------------------------+-- ** Lifting of explicit Kinds since I don't have a better solution++-- | A collection type for VHDLs expression types.+--+-- Going from "Expr a -> VHDL.Exp" means recovering the structure of VHDL's+-- expressions since 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/VHDL/Expression/Type.hs view
@@ -0,0 +1,75 @@+module Language.Embedded.VHDL.Expression.Type+ ( Type+ , Kind(..)+ , std_logic+ , signed, usigned+ , signed8, signed16, signed32, signed64+ , usigned8, usigned16, usigned32, usigned64+ , resize+ ) where++import Language.VHDL+import Language.Embedded.VHDL.Expression.Hoist hiding (Kind) -- resize+import Language.Embedded.VHDL.Monad.Expression (lit)++--------------------------------------------------------------------------------+-- * 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++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 (show 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 ..++--------------------------------------------------------------------------------+-- ** Type conversion (and other stuff)++resize :: Int -> Term -> Primary+resize size exp =+ PrimFun (FunctionCall+ (NSimple (Ident "resize"))+ (Just (AssociationList+ [ AssociationElement Nothing (APDesignator (ADExpression (lift exp)))+ , AssociationElement Nothing (APDesignator (ADExpression (lift (lit (show size)))))+ ])+ ))++--------------------------------------------------------------------------------
+ src/Language/Embedded/VHDL/Interface.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}++module Language.Embedded.VHDL.Interface where++import Language.VHDL (Expression, Identifier(..))+import Language.Embedded.VHDL.Monad (VHDL)+import Language.Embedded.VHDL.Expression.Type (Type)++import Data.Constraint+import Data.Typeable (Typeable)++--------------------------------------------------------------------------------+-- *+--------------------------------------------------------------------------------++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 :: exp a -> a+++-- | General interface for compiling expressions+class CompileExp exp+ where+ -- | Variable expressions+ varE :: PredicateExp exp a => Identifier -> exp a++ -- | Compilation of type kind+ compT :: PredicateExp exp a => exp a -> VHDL Type++ -- | Compilation of expressions+ compE :: exp a -> VHDL Expression++--------------------------------------------------------------------------------
+ src/Language/Embedded/VHDL/Monad.hs view
@@ -0,0 +1,556 @@+{-# 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++ -- ^ pretty+ , prettyVHDL+ , prettyVHDLT++ -- ^ ...+ , freshUnique+ , newVar+ , newLabel++ -- ^ declarations+ , addPort+ , addGeneric+ , addType+ , addComponent+ , addGlobal+ , addLocal++ -- ^ statements+ , addConcurrent+ , addSequential++ -- ^ key statements+ , inEntity+ , inArchitecture+ , inProcess+ , inConditional+ , inCase++ -- ^ common+ , interfaceConstant+ , interfaceSignal+ , interfaceVariable+ , declRecord+ , declConstant+ , declSignal+ , declVariable+ , portMap+ , assignSignal+ , assignVariable++ , module Language.Embedded.VHDL.Monad.Expression+ ) where++import Language.VHDL (Identifier(..), Mode(..), Expression, Label)+import qualified Language.VHDL as V++import Language.Embedded.VHDL.Expression.Type+import Language.Embedded.VHDL.Monad.Expression++import Control.Arrow (first, second)+import Control.Applicative+import Control.Monad+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+import Data.List (groupBy)+import Data.Set (Set)+import qualified Data.Set as Set++import Text.PrettyPrint (Doc, ($+$))++import Prelude hiding (null, not, abs, exp, rem, mod, div, and, or)+import qualified Prelude as P++--------------------------------------------------------------------------------+-- * ..+--------------------------------------------------------------------------------++-- | ...+data VFile = VFile (V.EntityDeclaration) [V.ArchitectureBody]++-- | Code generation state+data VHDLEnv = VHDLEnv+ { _unique :: !Integer+ , _entity :: String++ -- ..+ , _parts :: [VFile]++ -- ...+ , _types :: Set V.TypeDeclaration+ , _components :: Set V.ComponentDeclaration++ -- headers+ , _ports :: [V.InterfaceDeclaration]+ , _generics :: [V.InterfaceDeclaration]+ , _architectures :: [V.ArchitectureBody]+ + -- declarations+ , _global :: [V.BlockDeclarativeItem]+ , _local :: [V.BlockDeclarativeItem]++ -- statements+ , _concurrent :: [V.ConcurrentStatement]+ , _sequential :: [V.SequentialStatement]+ }++-- | Initial state during code generation+emptyVHDLEnv = VHDLEnv+ { _unique = 0+ , _entity = "invisible"+ , _parts = []+ , _types = Set.empty+ , _components = Set.empty+ , _ports = []+ , _generics = []+ , _architectures = []+ , _global = []+ , _local = []+ , _concurrent = []+ , _sequential = []+ }++--------------------------------------------------------------------------------+-- *++-- | 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)++-- | Run the VHDL code generation monad+runVHDL :: VHDL a -> VHDLEnv -> (a, VHDLEnv)+runVHDL m = CMI.runIdentity . CMS.runStateT (unVGenT m)++--------------------------------------------------------------------------------+-- ** Unique generation++-- | 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+newVar :: MonadV m => m Identifier+newVar = freshUnique >>= return . Ident . ('u' :) . show++-- | Generates a fresh and unique label+newLabel :: MonadV m => m Label+newLabel = freshUnique >>= return . Ident . ('l' :) . show++--------------------------------------------------------------------------------+-- ** Header declarations -- ignores port/generic maps for now++-- | Adds a port declaration to the entity+addPort :: MonadV m => V.InterfaceDeclaration -> m ()+addPort p = CMS.modify $ \s -> s { _ports = p : (_ports s) }++-- | Adds a generic declaration to the entity+addGeneric :: MonadV m => V.InterfaceDeclaration -> m ()+addGeneric g = CMS.modify $ \s -> s { _generics = g : (_generics s) }++--------------------------------------------------------------------------------+-- ** Component declarations++-- | ...+addType :: MonadV m => V.TypeDeclaration -> m ()+addType t = CMS.modify $ \s -> s { _types = Set.insert t (_types s) }++-- | Adds a component declaration to the architecture+addComponent :: MonadV m => V.ComponentDeclaration -> m ()+addComponent c = CMS.modify $ \s -> s { _components = Set.insert c (_components s) }++--------------------------------------------------------------------------------+-- ** Item declarations++-- | Adds a global declaration+addGlobal :: MonadV m => V.BlockDeclarativeItem -> m ()+addGlobal g = CMS.modify $ \s -> s { _global = g : (_global s) }++-- | Adds a local declaration+addLocal :: MonadV m => V.BlockDeclarativeItem -> m ()+addLocal l = CMS.modify $ \s -> s { _local = l : (_local s) }++--------------------------------------------------------------------------------+-- ** Concurrent statements++-- | Runs the given action inside a process+-- ! Due to how translate works, some local declarations might dissapear.+inProcess :: MonadV m => Label -> [Identifier] -> m a -> m (a, V.ProcessStatement)+inProcess l is m =+ do oldLocals <- CMS.gets _local+ oldSequential <- CMS.gets _sequential+ CMS.modify $ \e -> e { _local = []+ , _sequential = [] }+ a <- m+ newLocals <- reverse <$> CMS.gets _local+ newSequential <- reverse <$> CMS.gets _sequential+ CMS.modify $ \e -> e { _local = oldLocals+ , _sequential = oldSequential }+ return ( a+ , V.ProcessStatement+ (Just l) -- label+ (False) -- postponed+ (sensitivity) -- sensitivitylist+ (translate $ merge $ newLocals) -- declarativepart+ (newSequential)) -- statementpart+ where+ sensitivity | P.null is = Nothing+ | otherwise = Just $ V.SensitivityList $ fmap V.NSimple is++--------------------------------------------------------------------------------+-- ** Sequential statements++addConcurrent :: MonadV m => V.ConcurrentStatement -> m ()+addConcurrent con = CMS.modify $ \s -> s { _concurrent = con : (_concurrent s) }++addSequential :: MonadV m => V.SequentialStatement -> m ()+addSequential seq = CMS.modify $ \s -> s { _sequential = seq : (_sequential s) }++--------------------------------------------------------------------------------+-- **++inConditional :: MonadV m => (V.Condition, m ()) -> [(V.Condition, m ())] -> m () -> m (V.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 $+ V.IfStatement+ (Nothing)+ (c, m')+ (zip cs ns')+ (maybeList e')+ where+ maybeList :: [V.SequentialStatement] -> Maybe [V.SequentialStatement]+ maybeList xs+ | P.null xs = Nothing+ | otherwise = Just xs++contain :: MonadV m => m () -> m [V.SequentialStatement]+contain m =+ do m -- do+ new <- reverse <$> CMS.gets _sequential -- get+ CMS.modify $ \e -> e { _sequential = [] } -- reset+ return $ new++--------------------------------------------------------------------------------+-- **++inCase :: MonadV m => V.Expression -> [(V.Choices, m ())] -> m (V.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 $+ V.CaseStatement+ (Nothing)+ (e)+ (zipWith V.CaseStatementAlternative cs ns')++--------------------------------------------------------------------------------+-- **++addArchitecture :: MonadV m => V.ArchitectureBody -> m ()+addArchitecture a = CMS.modify $ \s -> s { _architectures = a : (_architectures s)}++inArchitecture :: MonadV m => String -> m a -> m a+inArchitecture name m =+ do oldEntity <- CMS.gets _entity+ oldComponent <- CMS.gets _components+ oldGlobal <- CMS.gets _global+ oldLocal <- CMS.gets _local+ oldConcurrent <- CMS.gets _concurrent+ CMS.modify $ \e -> e { _components = Set.empty+ , _global = []+ , _local = []+ , _concurrent = []+ }+ a <- m+ newComponent <- CMS.gets _components+ newGlobal <- reverse <$> CMS.gets _global+ newLocal <- reverse <$> CMS.gets _local+ newConcurrent <- reverse <$> CMS.gets _concurrent+ CMS.modify $ \e -> e { _components = oldComponent+ , _global = oldGlobal+ , _local = oldLocal+ , _concurrent = oldConcurrent+ }++ addArchitecture $ V.ArchitectureBody+ (V.Ident name)+ (V.NSimple (V.Ident oldEntity))+ (merge $ newGlobal ++ newLocal)+ (newConcurrent)+ return a++--------------------------------------------------------------------------------+-- **++addPart :: MonadV m => VFile -> m ()+addPart v = CMS.modify $ \s -> s { _parts = v : (_parts s) }++inEntity :: MonadV m => String -> m a -> m a+inEntity name m =+ do oldUnique <- CMS.gets _unique+ oldEntity <- CMS.gets _entity+ oldPorts <- CMS.gets _ports+ oldGenerics <- CMS.gets _generics+ oldArchitectures <- CMS.gets _architectures+ CMS.modify $ \e -> e { _unique = 0+ , _entity = name+ , _ports = []+ , _generics = []+ , _architectures = []+ }+ a <- m+ newPorts <- reverse <$> CMS.gets _ports+ newGenerics <- reverse <$> CMS.gets _generics+ newArchitectures <- reverse <$> CMS.gets _architectures+ CMS.modify $ \e -> e { _unique = oldUnique+ , _entity = oldEntity+ , _ports = oldPorts+ , _generics = oldGenerics+ , _architectures = oldArchitectures+ }+ addPart $ VFile+ (V.EntityDeclaration+ (V.Ident name)+ (V.EntityHeader+ (V.GenericClause <$> maybeNull newGenerics)+ (V.PortClause <$> maybeNull newPorts))+ ([])+ (Nothing))+ (newArchitectures)+ return a+ where+ maybeNull :: [V.InterfaceDeclaration] -> Maybe V.InterfaceList+ maybeNull [] = Nothing+ maybeNull xs = Just $ V.InterfaceList $ merge xs++--------------------------------------------------------------------------------+-- * Pretty+--------------------------------------------------------------------------------++prettyVHDL :: VHDL a -> Doc+prettyVHDL = CMI.runIdentity . prettyVHDLT++prettyVHDLT :: Monad m => VHDLT m a -> m Doc+prettyVHDLT m = prettyVEnv . snd <$> runVHDLT (inEntity "anonymous" m) emptyVHDLEnv++prettyVEnv :: VHDLEnv -> Doc+prettyVEnv (VHDLEnv _ _ parts types _ _ _ _ _ _ _ _) =+ stack $ (genPackage "types" $ Set.toList types) : (fmap prettyPart parts)+ where+ stack :: [Doc] -> Doc+ stack = foldr1 ($+$)+ + prettyPart :: VFile -> Doc+ prettyPart (VFile e as) = stack (V.pp e : fmap V.pp as)++--------------------------------------------------------------------------------++genPackage :: String -> [V.TypeDeclaration] -> Doc+genPackage name = V.pp . V.PackageDeclaration (V.Ident name) . fmap V.PHDIType+ +--------------------------------------------------------------------------------+-- * Common things+--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+-- ** Ports/Generic declarations++interfaceConstant :: Identifier -> Type -> Maybe Expression -> V.InterfaceDeclaration+interfaceConstant i t e = V.InterfaceConstantDeclaration [i] t e++interfaceSignal :: Identifier -> Mode -> Type -> Maybe Expression -> V.InterfaceDeclaration+interfaceSignal i m t e = V.InterfaceSignalDeclaration [i] (Just m) t False e++interfaceVariable :: Identifier -> Mode -> Type -> Maybe Expression -> V.InterfaceDeclaration+interfaceVariable i m t e = V.InterfaceVariableDeclaration [i] (Just m) t e++--------------------------------------------------------------------------------+-- ** Type/Component Declarations++declRecord :: Identifier -> [(Identifier, Type)] -> V.TypeDeclaration+declRecord name es = V.TDFull+ (V.FullTypeDeclaration+ (name)+ (V.TDComposite (V.CTDRecord (V.RecordTypeDefinition+ (fmap decl es)+ (Just name)))))+ where+ decl (i, t) = V.ElementDeclaration [i] t++--------------------------------------------------------------------------------+-- ** Global/Local Declarations++declConstant :: Identifier -> Type -> Maybe Expression -> V.BlockDeclarativeItem+declConstant i t e = V.BDIConstant $ V.ConstantDeclaration [i] t e++declSignal :: Identifier -> Type -> Maybe Expression -> V.BlockDeclarativeItem+declSignal i t e = V.BDISignal $ V.SignalDeclaration [i] t Nothing e++declVariable :: Identifier -> Type -> Maybe Expression -> V.BlockDeclarativeItem+declVariable i t e = V.BDIShared $ V.VariableDeclaration False [i] t e++--------------------------------------------------------------------------------+-- ** Component instantiation (port mapping)++portMap :: Label -> Identifier -> [V.ActualDesignator] -> V.ConcurrentStatement+portMap l n ns = V.ConComponent $+ V.ComponentInstantiationStatement+ (l)+ (V.IUComponent (V.NSimple n))+ (Nothing)+ (Just $ V.PortMapAspect+ (V.AssociationList $+ fmap (V.AssociationElement Nothing) $+ fmap V.APDesignator ns))++--------------------------------------------------------------------------------+-- ** Assign Signal/Variable++assignSignal :: Identifier -> Expression -> V.SequentialStatement+assignSignal i e = V.SSignalAss $+ V.SignalAssignmentStatement+ (Nothing)+ (V.TargetName (V.NSimple i))+ (Nothing)+ (V.WaveElem [V.WaveEExp e Nothing])++assignVariable :: Identifier -> Expression -> V.SequentialStatement+assignVariable i e = V.SVarAss $+ V.VariableAssignmentStatement+ (Nothing)+ (V.TargetName (V.NSimple i))+ (e)++--------------------------------------------------------------------------------+-- Some helper classes and their instances+--------------------------------------------------------------------------------++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 V.BlockDeclarativeItem+ where+ group l r = setBlockIds l [] == setBlockIds r []+ reduce bs@(b:_) = setBlockIds b $ concatMap getBlockIds bs++instance Merge V.InterfaceDeclaration+ where+ group l r = l { V.idecl_identifier_list = [] } == r { V.idecl_identifier_list = [] }+ reduce (x:xs) = x { V.idecl_identifier_list = ids x ++ concatMap ids xs }+ where ids = V.idecl_identifier_list++--------------------------------------------------------------------------------++setBlockIds :: V.BlockDeclarativeItem -> [Identifier] -> V.BlockDeclarativeItem+setBlockIds (V.BDIConstant c) is = V.BDIConstant $ c { V.const_identifier_list = is }+setBlockIds (V.BDISignal s) is = V.BDISignal $ s { V.signal_identifier_list = is }+setBlockIds (V.BDIShared v) is = V.BDIShared $ v { V.var_identifier_list = is }+setBlockIds (V.BDIFile f) is = V.BDIFile $ f { V.fd_identifier_list = is }+setBlockIds x _ = x++getBlockIds :: V.BlockDeclarativeItem -> [Identifier]+getBlockIds (V.BDIConstant c) = V.const_identifier_list c+getBlockIds (V.BDISignal s) = V.signal_identifier_list s+getBlockIds (V.BDIShared v) = V.var_identifier_list v+getBlockIds (V.BDIFile f) = V.fd_identifier_list f++--------------------------------------------------------------------------------+-- 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 Declarative a+ where+ -- lists are used so we can fail without having to throw errors+ translate :: [V.BlockDeclarativeItem] -> [a]++instance Declarative V.ProcessDeclarativeItem+ where+ translate = catMaybes . fmap tryProcess++-- | Try to transform the declarative item into a process item+tryProcess :: V.BlockDeclarativeItem -> Maybe (V.ProcessDeclarativeItem)+tryProcess (V.BDIConstant c) = Just $ V.PDIConstant c+tryProcess (V.BDIShared v) = Just $ V.PDIVariable v+tryProcess (V.BDIFile f) = Just $ V.PDIFile f+tryProcess _ = Nothing++--------------------------------------------------------------------------------+-- Ord instance for use in Set+--------------------------------------------------------------------------------++deriving instance Ord Identifier++instance Ord V.TypeDeclaration where+ compare (V.TDFull l) (V.TDFull r) = compare (V.ftd_identifier l) (V.ftd_identifier r)+ compare (V.TDPartial l) (V.TDPartial r) = compare l r+ -- ...+ compare (V.TDFull l) _ = GT+ compare (V.TDPartial l) _ = LT++instance Ord V.IncompleteTypeDeclaration where+ compare (V.IncompleteTypeDeclaration l) (V.IncompleteTypeDeclaration r) = compare l r++instance Ord V.ComponentDeclaration where+ compare l r = compare (V.comp_identifier l) (V.comp_identifier r)++--------------------------------------------------------------------------------
+ src/Language/Embedded/VHDL/Monad/Expression.hs view
@@ -0,0 +1,100 @@+module Language.Embedded.VHDL.Monad.Expression where++import Language.VHDL+import Language.Embedded.VHDL.Expression.Hoist hiding (Kind)++--------------------------------------------------------------------------------+-- * Expressions (and its 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+--+-- ! These are a bit simplified..++name, string, lit :: String -> Primary+name = PrimName . NSimple . Ident+string = PrimLit . LitString . SLit+lit = PrimLit . LitNum . NLitPhysical . PhysicalLiteral Nothing . NSimple . Ident++null :: Primary+null = PrimLit LitNull++--------------------------------------------------------------------------------