More restructuring

1 files changed, 564 insertions, 0 deletions

diff --git a/src/VeriFuzz/AST.hs b/src/VeriFuzz/AST.hs
new file mode 100644
index 0000000..0f24c49
--- /dev/null
+++ b/src/VeriFuzz/AST.hs
@@ -0,0 +1,564 @@
+{-|
+Module      : VeriFuzz.Verilog.AST
+Description : Definition of the Verilog AST types.
+Copyright   : (c) 2018-2019, Yann Herklotz Grave
+License     : BSD-3
+Maintainer  : ymherklotz [at] gmail [dot] com
+Stability   : experimental
+Poratbility : POSIX
+
+Defines the types to build a Verilog AST.
+-}
+
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TemplateHaskell            #-}
+
+module VeriFuzz.Verilog.AST
+  ( -- * Top level types
+    VerilogSrc(..)
+  , getVerilogSrc
+  , Description(..)
+  , getDescription
+    -- * Primitives
+    -- ** Identifier
+  , Identifier(..)
+  , getIdentifier
+    -- ** Control
+  , Delay(..)
+  , getDelay
+  , Event(..)
+    -- ** Operators
+  , BinaryOperator(..)
+  , UnaryOperator(..)
+    -- ** Task
+  , Task(..)
+  , taskName
+  , taskExpr
+    -- ** Left hand side value
+  , LVal(..)
+  , regId
+  , regExprId
+  , regExpr
+  , regSizeId
+  , regSizeMSB
+  , regSizeLSB
+  , regConc
+    -- ** Ports
+  , PortDir(..)
+  , PortType(..)
+  , regSigned
+  , Port(..)
+  , portType
+  , portSize
+  , portName
+    -- * Expression
+  , Expr(..)
+  , exprSize
+  , exprVal
+  , exprId
+  , exprConcat
+  , exprUnOp
+  , exprPrim
+  , exprLhs
+  , exprBinOp
+  , exprRhs
+  , exprCond
+  , exprTrue
+  , exprFalse
+  , exprFunc
+  , exprBody
+  , exprStr
+  , exprWithContext
+  , traverseExpr
+  , ConstExpr(..)
+  , constNum
+  , Function (..)
+    -- * Assignment
+  , Assign(..)
+  , assignReg
+  , assignDelay
+  , assignExpr
+  , ContAssign(..)
+  , contAssignNetLVal
+  , contAssignExpr
+    -- * Statment
+  , Stmnt(..)
+  , statDelay
+  , statDStat
+  , statEvent
+  , statEStat
+  , statements
+  , stmntBA
+  , stmntNBA
+  , stmntCA
+  , stmntTask
+  , stmntSysTask
+    -- * Module
+  , ModDecl(..)
+  , modId
+  , modOutPorts
+  , modInPorts
+  , modItems
+  , ModItem(..)
+  , _ModCA
+  , modInstId
+  , modInstName
+  , modInstConns
+  , declDir
+  , declPort
+  , ModConn(..)
+  , modConn
+  , modConnName
+  , modExpr
+  )
+where
+
+import           Control.Lens     (makeLenses, makePrisms)
+import           Control.Monad    (replicateM)
+import           Data.String      (IsString, fromString)
+import           Data.Text        (Text)
+import qualified Data.Text        as T
+import           Data.Traversable (sequenceA)
+import qualified Test.QuickCheck  as QC
+
+positiveArb :: (QC.Arbitrary a, Ord a, Num a) => QC.Gen a
+positiveArb = QC.suchThat QC.arbitrary (> 0)
+
+-- | Identifier in Verilog. This is just a string of characters that can either
+-- be lowercase and uppercase for now. This might change in the future though,
+-- as Verilog supports many more characters in Identifiers.
+newtype Identifier = Identifier { _getIdentifier :: Text }
+                   deriving (Eq, Show, IsString, Semigroup, Monoid)
+
+makeLenses ''Identifier
+
+instance QC.Arbitrary Identifier where
+  arbitrary = do
+    l <- QC.choose (2, 10)
+    Identifier . T.pack <$> replicateM l (QC.elements ['a'..'z'])
+
+-- | Verilog syntax for adding a delay, which is represented as @#num@.
+newtype Delay = Delay { _getDelay :: Int }
+                deriving (Eq, Show, Num)
+
+makeLenses ''Delay
+
+instance QC.Arbitrary Delay where
+  arbitrary = Delay <$> positiveArb
+
+-- | Verilog syntax for an event, such as @\@x@, which is used for always blocks
+data Event = EId Identifier
+           | EExpr Expr
+           | EAll
+           | EPosEdge Identifier
+           | ENegEdge Identifier
+           deriving (Eq, Show)
+
+instance QC.Arbitrary Event where
+  arbitrary = EId <$> QC.arbitrary
+
+-- | Binary operators that are currently supported in the verilog generation.
+data BinaryOperator = BinPlus    -- ^ @+@
+                    | BinMinus   -- ^ @-@
+                    | BinTimes   -- ^ @*@
+                    | BinDiv     -- ^ @/@
+                    | BinMod     -- ^ @%@
+                    | BinEq      -- ^ @==@
+                    | BinNEq     -- ^ @!=@
+                    | BinCEq     -- ^ @===@
+                    | BinCNEq    -- ^ @!==@
+                    | BinLAnd    -- ^ @&&@
+                    | BinLOr     -- ^ @||@
+                    | BinLT      -- ^ @<@
+                    | BinLEq     -- ^ @<=@
+                    | BinGT      -- ^ @>@
+                    | BinGEq     -- ^ @>=@
+                    | BinAnd     -- ^ @&@
+                    | BinOr      -- ^ @|@
+                    | BinXor     -- ^ @^@
+                    | BinXNor    -- ^ @^~@
+                    | BinXNorInv -- ^ @~^@
+                    | BinPower   -- ^ @**@
+                    | BinLSL     -- ^ @<<@
+                    | BinLSR     -- ^ @>>@
+                    | BinASL     -- ^ @<<<@
+                    | BinASR     -- ^ @>>>@
+                    deriving (Eq, Show)
+
+instance QC.Arbitrary BinaryOperator where
+  arbitrary = QC.elements
+    [ BinPlus
+    , BinMinus
+    , BinTimes
+    , BinDiv
+    , BinMod
+    , BinEq
+    , BinNEq
+    , BinCEq
+    , BinCNEq
+    , BinLAnd
+    , BinLOr
+    , BinLT
+    , BinLEq
+    , BinGT
+    , BinGEq
+    , BinAnd
+    , BinOr
+    , BinXor
+    , BinXNor
+    , BinXNorInv
+    , BinPower
+    , BinLSL
+    , BinLSR
+    , BinASL
+    , BinASR
+    ]
+
+-- | Unary operators that are currently supported by the generator.
+data UnaryOperator = UnPlus    -- ^ @+@
+                   | UnMinus   -- ^ @-@
+                   | UnNot     -- ^ @!@
+                   | UnAnd     -- ^ @&@
+                   | UnNand    -- ^ @~&@
+                   | UnOr      -- ^ @|@
+                   | UnNor     -- ^ @~|@
+                   | UnXor     -- ^ @^@
+                   | UnNxor    -- ^ @~^@
+                   | UnNxorInv -- ^ @^~@
+                   deriving (Eq, Show)
+
+instance QC.Arbitrary UnaryOperator where
+  arbitrary = QC.elements
+    [ UnPlus
+    , UnMinus
+    , UnNot
+    , UnAnd
+    , UnNand
+    , UnOr
+    , UnNor
+    , UnXor
+    , UnNxor
+    , UnNxorInv
+    ]
+
+data Function = SignedFunc
+              | UnSignedFunc
+              deriving (Eq, Show)
+
+instance QC.Arbitrary Function where
+  arbitrary = QC.elements
+    [ SignedFunc
+    , UnSignedFunc
+    ]
+
+-- | Verilog expression, which can either be a primary expression, unary
+-- expression, binary operator expression or a conditional expression.
+data Expr = Number { _exprSize :: Int
+                   , _exprVal  :: Integer
+                   }
+          | Id { _exprId :: Identifier }
+          | Concat { _exprConcat :: [Expr] }
+          | UnOp { _exprUnOp :: UnaryOperator
+                 , _exprPrim :: Expr
+                 }
+          | BinOp { _exprLhs   :: Expr
+                  , _exprBinOp :: BinaryOperator
+                  , _exprRhs   :: Expr
+                  }
+          | Cond { _exprCond  :: Expr
+                 , _exprTrue  :: Expr
+                 , _exprFalse :: Expr
+                 }
+          | Func { _exprFunc :: Function
+                 , _exprBody :: Expr
+                 }
+          | Str { _exprStr :: Text }
+          deriving (Eq, Show)
+
+instance Num Expr where
+  a + b = BinOp a BinPlus b
+  a - b = BinOp a BinMinus b
+  a * b = BinOp a BinTimes b
+  negate = UnOp UnMinus
+  abs = undefined
+  signum = undefined
+  fromInteger = Number 32 . fromInteger
+
+instance Semigroup Expr where
+  (Concat a) <> (Concat b) = Concat $ a <> b
+  (Concat a) <> b = Concat $ a <> [b]
+  a <> (Concat b) = Concat $ a : b
+  a <> b = Concat [a, b]
+
+instance Monoid Expr where
+  mempty = Concat []
+
+instance IsString Expr where
+  fromString = Str . fromString
+
+exprSafeList :: [QC.Gen Expr]
+exprSafeList =
+  [ Number <$> positiveArb <*> QC.arbitrary
+    -- , Str <$> QC.arbitrary
+  ]
+
+exprRecList :: (Int -> QC.Gen Expr) -> [QC.Gen Expr]
+exprRecList subexpr =
+  [ Number <$> positiveArb <*> QC.arbitrary
+  , Concat <$> QC.listOf1 (subexpr 8)
+  , UnOp
+    <$> QC.arbitrary
+    <*> subexpr 2
+    -- , Str <$> QC.arbitrary
+  , BinOp <$> subexpr 2 <*> QC.arbitrary <*> subexpr 2
+  , Cond <$> subexpr 3 <*> subexpr 3 <*> subexpr 3
+  , Func <$> QC.arbitrary <*> subexpr 2
+  ]
+
+expr :: Int -> QC.Gen Expr
+expr n
+  | n == 0 = QC.oneof $ (Id <$> QC.arbitrary) : exprSafeList
+  | n > 0 = QC.oneof $ (Id <$> QC.arbitrary) : exprRecList subexpr
+  | otherwise = expr 0
+  where subexpr y = expr (n `div` y)
+
+exprWithContext :: [Identifier] -> Int -> QC.Gen Expr
+exprWithContext l n
+  | n == 0 = QC.oneof $ (Id <$> QC.elements l) : exprSafeList
+  | n > 0 = QC.oneof $ (Id <$> QC.elements l) : exprRecList subexpr
+  | otherwise = exprWithContext l 0
+  where subexpr y = exprWithContext l (n `div` y)
+
+instance QC.Arbitrary Expr where
+  arbitrary = QC.sized expr
+
+traverseExpr :: (Applicative f) => (Expr -> f Expr) -> Expr -> f Expr
+traverseExpr f (Concat e    ) = Concat <$> sequenceA (f <$> e)
+traverseExpr f (UnOp un e   ) = UnOp un <$> f e
+traverseExpr f (BinOp l op r) = BinOp <$> f l <*> pure op <*> f r
+traverseExpr f (Cond  c l  r) = Cond <$> f c <*> f l <*> f r
+traverseExpr f (Func fn e   ) = Func fn <$> f e
+traverseExpr _ e              = pure e
+
+makeLenses ''Expr
+
+-- | Constant expression, which are known before simulation at compilation time.
+newtype ConstExpr = ConstExpr { _constNum :: Int }
+                  deriving (Eq, Show, Num, QC.Arbitrary)
+
+makeLenses ''ConstExpr
+
+data Task = Task { _taskName :: Identifier
+                 , _taskExpr :: [Expr]
+                 } deriving (Eq, Show)
+
+makeLenses ''Task
+
+instance QC.Arbitrary Task where
+  arbitrary = Task <$> QC.arbitrary <*> QC.arbitrary
+
+-- | Type that represents the left hand side of an assignment, which can be a
+-- concatenation such as in:
+--
+-- @
+-- {a, b, c} = 32'h94238;
+-- @
+data LVal = RegId { _regId :: Identifier}
+          | RegExpr { _regExprId :: Identifier
+                    , _regExpr   :: Expr
+                    }
+          | RegSize { _regSizeId  :: Identifier
+                    , _regSizeMSB :: ConstExpr
+                    , _regSizeLSB :: ConstExpr
+                    }
+          | RegConcat { _regConc :: [Expr] }
+          deriving (Eq, Show)
+
+makeLenses ''LVal
+
+instance QC.Arbitrary LVal where
+  arbitrary = QC.oneof [ RegId <$> QC.arbitrary
+                       , RegExpr <$> QC.arbitrary <*> QC.arbitrary
+                       , RegSize <$> QC.arbitrary <*> QC.arbitrary <*> QC.arbitrary
+                       ]
+
+instance IsString LVal where
+  fromString = RegId . fromString
+
+-- | Different port direction that are supported in Verilog.
+data PortDir = PortIn    -- ^ Input direction for port (@input@).
+             | PortOut   -- ^ Output direction for port (@output@).
+             | PortInOut -- ^ Inout direction for port (@inout@).
+             deriving (Eq, Show)
+
+instance QC.Arbitrary PortDir where
+  arbitrary = QC.elements [PortIn, PortOut, PortInOut]
+
+-- | Currently, only @wire@ and @reg@ are supported, as the other net types are
+-- not that common and not a priority.
+data PortType = Wire
+              | Reg { _regSigned :: Bool }
+              deriving (Eq, Show)
+
+instance QC.Arbitrary PortType where
+  arbitrary = QC.oneof [pure Wire, Reg <$> QC.arbitrary]
+
+makeLenses ''PortType
+
+-- | Port declaration. It contains information about the type of the port, the
+-- size, and the port name. It used to also contain information about if it was
+-- an input or output port. However, this is not always necessary and was more
+-- cumbersome than useful, as a lot of ports can be declared without input and
+-- output port.
+--
+-- This is now implemented inside 'ModDecl' itself, which uses a list of output
+-- and input ports.
+data Port = Port { _portType :: PortType
+                 , _portSize :: Int
+                 , _portName :: Identifier
+                 } deriving (Eq, Show)
+
+makeLenses ''Port
+
+instance QC.Arbitrary Port where
+  arbitrary = Port <$> QC.arbitrary <*> positiveArb <*> QC.arbitrary
+
+-- | This is currently a type because direct module declaration should also be
+-- added:
+--
+-- @
+-- mod a(.y(y1), .x1(x11), .x2(x22));
+-- @
+data ModConn = ModConn { _modConn :: Expr }
+             | ModConnNamed { _modConnName :: Identifier
+                            , _modExpr     :: Expr
+                            }
+             deriving (Eq, Show)
+
+makeLenses ''ModConn
+
+instance QC.Arbitrary ModConn where
+  arbitrary = ModConn <$> QC.arbitrary
+
+data Assign = Assign { _assignReg   :: LVal
+                     , _assignDelay :: Maybe Delay
+                     , _assignExpr  :: Expr
+                     } deriving (Eq, Show)
+
+makeLenses ''Assign
+
+instance QC.Arbitrary Assign where
+  arbitrary = Assign <$> QC.arbitrary <*> QC.arbitrary <*> QC.arbitrary
+
+data ContAssign = ContAssign { _contAssignNetLVal :: Identifier
+                             , _contAssignExpr    :: Expr
+                             } deriving (Eq, Show)
+
+makeLenses ''ContAssign
+
+instance QC.Arbitrary ContAssign where
+  arbitrary = ContAssign <$> QC.arbitrary <*> QC.arbitrary
+
+-- | Statements in Verilog.
+data Stmnt = TimeCtrl { _statDelay :: Delay
+                      , _statDStat :: Maybe Stmnt
+                      }                             -- ^ Time control (@#NUM@)
+           | EventCtrl { _statEvent :: Event
+                       , _statEStat :: Maybe Stmnt
+                       }
+           | SeqBlock { _statements :: [Stmnt] }    -- ^ Sequential block (@begin ... end@)
+           | BlockAssign { _stmntBA :: Assign }     -- ^ blocking assignment (@=@)
+           | NonBlockAssign { _stmntNBA :: Assign } -- ^ Non blocking assignment (@<=@)
+           | StatCA { _stmntCA :: ContAssign }      -- ^ Stmnt continuous assignment. May not be correct.
+           | TaskEnable { _stmntTask :: Task}
+           | SysTaskEnable { _stmntSysTask :: Task}
+           deriving (Eq, Show)
+
+makeLenses ''Stmnt
+
+instance Semigroup Stmnt where
+  (SeqBlock a) <> (SeqBlock b) = SeqBlock $ a <> b
+  (SeqBlock a) <> b = SeqBlock $ a <> [b]
+  a <> (SeqBlock b) = SeqBlock $ a : b
+  a <> b = SeqBlock [a, b]
+
+instance Monoid Stmnt where
+  mempty = SeqBlock []
+
+statement :: Int -> QC.Gen Stmnt
+statement n
+  | n == 0 = QC.oneof
+    [ BlockAssign <$> QC.arbitrary
+    , NonBlockAssign <$> QC.arbitrary
+    -- , StatCA <$> QC.arbitrary
+    , TaskEnable <$> QC.arbitrary
+    , SysTaskEnable <$> QC.arbitrary
+    ]
+  | n > 0 = QC.oneof
+    [ TimeCtrl <$> QC.arbitrary <*> (Just <$> substat 2)
+    , SeqBlock <$> QC.listOf1 (substat 4)
+    , BlockAssign <$> QC.arbitrary
+    , NonBlockAssign <$> QC.arbitrary
+    -- , StatCA <$> QC.arbitrary
+    , TaskEnable <$> QC.arbitrary
+    , SysTaskEnable <$> QC.arbitrary
+    ]
+  | otherwise = statement 0
+  where substat y = statement (n `div` y)
+
+instance QC.Arbitrary Stmnt where
+  arbitrary = QC.sized statement
+
+-- | Module item which is the body of the module expression.
+data ModItem = ModCA ContAssign
+             | ModInst { _modInstId    :: Identifier
+                       , _modInstName  :: Identifier
+                       , _modInstConns :: [ModConn]
+                       }
+             | Initial Stmnt
+             | Always Stmnt
+             | Decl { _declDir  :: Maybe PortDir
+                    , _declPort :: Port
+                    }
+             deriving (Eq, Show)
+
+makeLenses ''ModItem
+makePrisms ''ModItem
+
+instance QC.Arbitrary ModItem where
+  arbitrary = QC.oneof [ ModCA <$> QC.arbitrary
+                       , ModInst <$> QC.arbitrary <*> QC.arbitrary <*> QC.arbitrary
+                       , Initial <$> QC.arbitrary
+                       , Always <$> (EventCtrl <$> QC.arbitrary <*> QC.arbitrary)
+                       , Decl <$> pure Nothing <*> QC.arbitrary
+                       ]
+
+-- | 'module' module_identifier [list_of_ports] ';' { module_item } 'end_module'
+data ModDecl = ModDecl { _modId       :: Identifier
+                       , _modOutPorts :: [Port]
+                       , _modInPorts  :: [Port]
+                       , _modItems    :: [ModItem]
+                       } deriving (Eq, Show)
+
+makeLenses ''ModDecl
+
+modPortGen :: QC.Gen Port
+modPortGen = QC.oneof
+  [ Port Wire <$> positiveArb <*> QC.arbitrary
+  , Port <$> (Reg <$> QC.arbitrary) <*> positiveArb <*> QC.arbitrary
+  ]
+
+instance QC.Arbitrary ModDecl where
+  arbitrary = ModDecl <$> QC.arbitrary <*> QC.arbitrary <*> QC.listOf1 modPortGen <*> QC.arbitrary
+
+-- | Description of the Verilog module.
+newtype Description = Description { _getDescription :: ModDecl }
+                    deriving (Eq, Show, QC.Arbitrary)
+
+makeLenses ''Description
+
+-- | The complete sourcetext for the Verilog module.
+newtype VerilogSrc = VerilogSrc { _getVerilogSrc :: [Description] }
+                   deriving (Eq, Show, QC.Arbitrary, Semigroup, Monoid)
+
+makeLenses ''VerilogSrc