X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=clash%2FCLasH%2FVHDL%2FVHDLTools.hs;h=521aa0850b0243d08c3623581a696e351b02f2fc;hb=3a92b8b28270471c7a2c8928cfc63a4c00e80c96;hp=fe807d4f0370559813edfd713448e555e82b9705;hpb=8c10e892bb7cd3637d62bc0044515e2bf59667f8;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/clash/CLasH/VHDL/VHDLTools.hs b/clash/CLasH/VHDL/VHDLTools.hs
index fe807d4..521aa08 100644
--- a/clash/CLasH/VHDL/VHDLTools.hs
+++ b/clash/CLasH/VHDL/VHDLTools.hs
@@ -488,8 +488,10 @@ mkTyconTy htype =
           let enum_decs = Maybe.maybeToList enum_dec_maybe
           let enum_tys = Maybe.maybeToList enum_ty_maybe
           let ty_def = AST.TDR $ AST.RecordTypeDef (enum_decs ++ concat elemss)
-          let tupshow = mkTupleShow (enum_tys ++ concat elem_tyss) ty_id
-          MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, tupshow)
+          let aggrshow = case enum_field_maybe of 
+                          Nothing -> mkTupleShow (enum_tys ++ concat elem_tyss) ty_id
+                          Just (conLbl, EnumType tycon dcs) -> mkAdtShow conLbl dcs (map (map fst) fieldss) ty_id
+          MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, aggrshow)
           return $ Just (ty_id, Just $ Left ty_def)
     (EnumType tycon dcs) -> do
       let ty_id = mkVHDLExtId tycon
@@ -541,7 +543,7 @@ mkNaturalTy ::
 mkNaturalTy min_bound max_bound = do
   let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound)))
   let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
-  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit $ show min_bound) (AST.PrimLit $ show bitsize)]
+  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show bitsize) (AST.PrimLit $ show min_bound)]
   let ty_def = AST.SubtypeIn unsignedTM (Just range)
   return (Just (ty_id, Just $ Right ty_def))
 
@@ -549,8 +551,8 @@ mkUnsignedTy ::
   Int -- ^ Haskell type of the unsigned integer
   -> TypeSession TypeMapRec
 mkUnsignedTy size = do
-  let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
-  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
+  let ty_id = mkVHDLExtId $ "unsigned_" ++ show size
+  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show (size - 1)) (AST.PrimLit "0")]
   let ty_def = AST.SubtypeIn unsignedTM (Just range)
   return (Just (ty_id, Just $ Right ty_def))
   
@@ -558,8 +560,8 @@ mkSignedTy ::
   Int -- ^ Haskell type of the signed integer
   -> TypeSession TypeMapRec
 mkSignedTy size = do
-  let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
-  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
+  let ty_id = mkVHDLExtId $ "signed_" ++ show size
+  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show (size - 1)) (AST.PrimLit "0")]
   let ty_def = AST.SubtypeIn signedTM (Just range)
   return (Just (ty_id, Just $ Right ty_def))
 
@@ -635,6 +637,29 @@ mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
     tupSize = length elemTMs
 
+mkAdtShow ::
+  String
+  -> [String] -- Constructors
+  -> [[String]] -- Fields for every constructor
+  -> AST.TypeMark
+  -> AST.SubProgBody
+mkAdtShow conLbl conIds elemIdss adtTM = AST.SubProgBody showSpec [] [showExpr]
+  where  
+    adtPar   = AST.unsafeVHDLBasicId "adt"
+    showSpec  = AST.Function showId [AST.IfaceVarDec adtPar adtTM] stringTM
+    showExpr  = AST.CaseSm (AST.PrimName $ AST.NSelected $ (AST.NSimple adtPar) AST.:.: (AST.SSimple $ (mkVHDLBasicId conLbl)))
+                  [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit $ show x] [AST.ReturnSm (Just $ ((AST.PrimLit $ '"':(conIds!!x)++[' ','"'])) AST.:&: showFields x)] | x <- [0..(length conIds) -1]]
+    showFields i = if (null (elemIdss!!i)) then
+        AST.PrimLit "''"
+      else
+        foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "' '" AST.:&: e2) $
+              map ((genExprFCall showId).
+                    AST.PrimName .
+                    AST.NSelected .
+                    (AST.NSimple adtPar AST.:.:).
+                    tupVHDLSuffix)
+                  (map mkVHDLBasicId (elemIdss!!i))              
+    
 mkEnumShow ::
   [String]
   -> AST.TypeMark