In order to take full advantage of this tutorial, it is essential to have a good background in the Haskell programming diff --git a/doc/www/files/tutorial/tutorial.pdf b/doc/www/files/tutorial/tutorial.pdf Binary files a/doc/www/files/tutorial/tutorial.pdf and b/doc/www/files/tutorial/tutorial.pdf differ diff --git a/examples/ALU.hs b/examples/ALU.hs --- a/examples/ALU.hs +++ b/examples/ALU.hs @@ -44,7 +44,7 @@ and4BitSys :: SysDef (Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit)) -and4BitSys = $(newSysDefTHName 'and4BitProc ["a", "b"] ["y"]) +and4BitSys = newSysDef and4BitProc "and4Bit" ["a", "b"] ["y"] simAnd4Bit :: [FSVec D4 Bit] -> [FSVec D4 Bit] -> [FSVec D4 Bit] simAnd4Bit = simulate and4BitSys @@ -70,7 +70,7 @@ or4BitSys :: SysDef (Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit)) -or4BitSys = $(newSysDefTHName 'or4BitProc ["a", "b"] ["y"]) +or4BitSys = newSysDef or4BitProc "or4Bit" ["a", "b"] ["y"] simOr4Bit :: [FSVec D4 Bit] -> [FSVec D4 Bit] -> [FSVec D4 Bit] simOr4Bit = simulate or4BitSys @@ -88,7 +88,7 @@ lslProc = mapSY "lsl" lslFun lslSys :: SysDef (Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit)) -lslSys = $(newSysDefTHName 'lslProc ["in"] ["out"]) +lslSys = newSysDef lslProc "lsl" ["in"] ["out"] simLsl :: [FSVec D4 Bit] -> [FSVec D4 Bit] simLsl = simulate lslSys @@ -130,7 +130,7 @@ mux41Sys :: SysDef (Signal (FSVec D2 Bit) -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit)) -mux41Sys = $(newSysDefTHName 'mux41Proc ["sel", "d3", "d2", "d1", "d0"] ["out"]) +mux41Sys = newSysDef mux41Proc "mux41" ["sel", "d3", "d2", "d1", "d0"] ["out"] simMux41 :: [FSVec D2 Bit] -> [FSVec D4 Bit] -> [FSVec D4 Bit] -> [FSVec D4 Bit] -> [FSVec D4 Bit] -> [FSVec D4 Bit] @@ -150,7 +150,7 @@ convFromFSVec4Proc = (unzip4SY "unzip4" . mapSY "conv4" convFromFSVec4Fun) convFromFSVec4Sys :: SysDef (Signal (FSVec D4 Bit) -> (Signal Bit, Signal Bit, Signal Bit, Signal Bit)) -convFromFSVec4Sys = $(newSysDefTHName 'convFromFSVec4Proc ["vector4"] ["v3", "v2", "v1", "v0"]) +convFromFSVec4Sys = newSysDef convFromFSVec4Proc "convFromFSVec" ["vector4"] ["v3", "v2", "v1", "v0"] simConvFromFSVec4 :: [FSVec D4 Bit] -> ([Bit], [Bit], [Bit], [Bit]) simConvFromFSVec4 = simulate convFromFSVec4Sys @@ -168,7 +168,7 @@ convToFSVec4Proc = zipWith4SY "toVector4" convToFSVec4Fun convToFSVec4Sys :: SysDef (Signal Bit -> Signal Bit -> Signal Bit -> Signal Bit -> Signal (FSVec D4 Bit)) -convToFSVec4Sys = $(newSysDefTHName 'convToFSVec4Proc ["x3", "x2", "x1", "x0"] ["vec4"]) +convToFSVec4Sys = newSysDef convToFSVec4Proc "convToFSVec" ["x3", "x2", "x1", "x0"] ["vec4"] simConvToFSVec4 = simulate convToFSVec4Sys @@ -177,13 +177,14 @@ ------ Full Adder fullAddFun :: ProcFun (Bit -> Bit -> Bit -> (Bit, Bit)) -fullAddFun = $(newProcFun [d|fullAddFun :: Bit -> Bit -> Bit -> (Bit, Bit) - -- I would like to use 'where'-clauses. Is this possible? - -- fullAddFun a b c_in = (c_out, sum) - -- where c_out = (a .&. b) .|. (a .&. c_in) .|. (b .&. c_in) - -- sum = (a `xor` b) `xor` c_in |]) - fullAddFun a b c_in = ((a .&. b) .|. (a .&. c_in) .|. (b .&. c_in), - (a `xor` b) `xor` c_in) |]) +fullAddFun = $(newProcFun + [d|fullAddFun :: Bit -> Bit -> Bit -> (Bit, Bit) + fullAddFun a b c_in = (c_out, sum) + where c_out :: Bit + c_out = (a .&. b) .|. (a .&. c_in) .|. (b .&. c_in) + sum :: Bit + sum = (a `xor` b) `xor` c_in |]) + --fullAddProc :: Signal Bit -> Signal Bit -> Signal Bit -> Signal (Bit, Bit) --fullAddProc = zipWith3SY "fulladd" fullAddFun @@ -191,7 +192,7 @@ fullAddProc a b c_in = (unzipSY "unzipSY") $ (zipWith3SY "fulladd" fullAddFun a b c_in) fullAddSys :: SysDef (Signal Bit -> Signal Bit -> Signal Bit -> (Signal Bit, Signal Bit)) -fullAddSys = $(newSysDefTHName 'fullAddProc ["a", "b", "c_in"] ["cout", "sum"]) +fullAddSys = newSysDef fullAddProc "fullAddSys" ["a", "b", "c_in"] ["cout", "sum"] simFullAdd :: [Bit] -> [Bit] -> [Bit] -> ([Bit], [Bit]) simFullAdd = simulate fullAddSys @@ -239,9 +240,9 @@ Signal Bit, -- SUM2 Signal Bit, -- SUM1 Signal Bit)) -- SUM0 -fourBitAdderSys = $(newSysDefTHName 'fourBitAdder ["C_IN", "A3", "A2", "A1", "A0", +fourBitAdderSys = newSysDef fourBitAdder "fourBitAdder" ["C_IN", "A3", "A2", "A1", "A0", "B3", "B2", "B1", "B0"] - ["C_OUT", "SUM3", "SUM2", "SUM1", "SUM0"]) + ["C_OUT", "SUM3", "SUM2", "SUM1", "SUM0"] simFourBitAdder = simulate fourBitAdderSys @@ -274,7 +275,7 @@ add4FSVecSys :: SysDef (Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit) -> (Signal Bit, Signal (FSVec D4 Bit))) -add4FSVecSys = $(newSysDefTHName 'add4FSVecProc ["a", "b"] ["cout", "sum"]) +add4FSVecSys = newSysDef add4FSVecProc "add4FSVec" ["a", "b"] ["cout", "sum"] simAdd4FSVecSys = simulate add4FSVecSys @@ -287,14 +288,14 @@ oneProc = constSY "high" H oneSys :: SysDef (Signal Bit) -oneSys = $(newSysDefTHName 'oneProc [] ["one"]) +oneSys = newSysDef oneProc "one" [] ["one"] -- Constant input 'L' modeled with constSY zeroProc :: Signal Bit zeroProc = constSY "low" L zeroSys :: SysDef (Signal Bit) -zeroSys = $(newSysDefTHName 'zeroProc [] ["zero"]) +zeroSys = newSysDef zeroProc "zero" [] ["zero"] ----- ALU @@ -316,7 +317,7 @@ -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit) -> (Signal Bit, Signal (FSVec D4 Bit))) -aluSys = $(newSysDefTHName 'aluProc ["sel", "a", "b"] ["cout", "data"]) +aluSys = newSysDef aluProc "alu" ["sel", "a", "b"] ["cout", "data"] simALU :: [FSVec D2 Bit] -> [FSVec D4 Bit] -> [FSVec D4 Bit] -> ([Bit], [FSVec D4 Bit]) diff --git a/examples/ButtonEncoder.hs b/examples/ButtonEncoder.hs --- a/examples/ButtonEncoder.hs +++ b/examples/ButtonEncoder.hs @@ -35,7 +35,7 @@ if down == H then Down else Unknown |]) buttonEncoderSys :: SysDef (Signal ButtonPress -> Signal Direction) -buttonEncoderSys = $(newSysDefTHName 'buttonEncoder ["buttonPress"] ["direction"]) +buttonEncoderSys = newSysDef buttonEncoder "buttonEncoder" ["buttonPress"] ["direction"] simButtonEncoder :: [ButtonPress] -> [Direction] diff --git a/examples/CarrySelectAdder.hs b/examples/CarrySelectAdder.hs --- a/examples/CarrySelectAdder.hs +++ b/examples/CarrySelectAdder.hs @@ -31,7 +31,7 @@ fullAddProc a b c_in = (unzipSY "unzipSY") $ (zipWith3SY "fulladd" fullAddFun a b c_in) fullAddSys :: SysDef (Signal Bit -> Signal Bit -> Signal Bit -> (Signal Bit, Signal Bit)) -fullAddSys = $(newSysDefTHName 'fullAddProc ["a", "b", "c_in"] ["cout", "sum"]) +fullAddSys = newSysDef fullAddProc "fullAdd" ["a", "b", "c_in"] ["cout", "sum"] simFullAdd :: [Bit] -> [Bit] -> [Bit] -> ([Bit], [Bit]) simFullAdd = simulate fullAddSys @@ -56,7 +56,7 @@ mux21Proc = zipWith3SY "mux21" mux21Fun mux21Sys :: SysDef (Signal Bit -> Signal Bit -> Signal Bit -> Signal Bit) -mux21Sys = $(newSysDefTHName 'mux21Proc ["sel", "d1", "d0"] ["out"]) +mux21Sys = newSysDef mux21Proc "mux21" ["sel", "d1", "d0"] ["out"] simMux21 :: [Bit] -> [Bit] -> [Bit] -> [Bit] simMux21 = simulate mux21Sys @@ -100,9 +100,9 @@ Signal Bit, -- SUM2 Signal Bit, -- SUM1 Signal Bit)) -- SUM0 -fourBitAdderSys = $(newSysDefTHName 'fourBitAdder ["C_IN", "A3", "A2", "A1", "A0", +fourBitAdderSys = newSysDef fourBitAdder "fourBitAdder" ["C_IN", "A3", "A2", "A1", "A0", "B3", "B2", "B1", "B0"] - ["C_OUT", "SUM3", "SUM2", "SUM1", "SUM0"]) + ["C_OUT", "SUM3", "SUM2", "SUM1", "SUM0"] simFourBitAdder = simulate fourBitAdderSys @@ -152,9 +152,9 @@ one = instantiate "One" oneSys zero = instantiate "Zero" zeroSys -fourBitCSAdderSys = $(newSysDefTHName 'fourBitCSAdder ["C_IN", "A3", "A2", "A1", "A0", +fourBitCSAdderSys = newSysDef fourBitCSAdder "fourBitCSAdder" ["C_IN", "A3", "A2", "A1", "A0", "B3", "B2", "B1", "B0"] - ["C_OUT", "SUM3", "SUM2", "SUM1", "SUM0"]) + ["C_OUT", "SUM3", "SUM2", "SUM1", "SUM0"] simFourBitCSAdder = simulate fourBitCSAdderSys @@ -178,7 +178,7 @@ convOutputProc = zipWith5SY "toVector5" convOutput convOutputSys :: SysDef (Signal Bit -> Signal Bit -> Signal Bit -> Signal Bit -> Signal Bit -> Signal (FSVec D5 Bit)) -convOutputSys = $(newSysDefTHName 'convOutputProc ["x4", "x3", "x2", "x1", "x0"] ["vec5"]) +convOutputSys = newSysDef convOutputProc "convOutput" ["x4", "x3", "x2", "x1", "x0"] ["vec5"] fourBitCSAdder' :: Signal Bit -- C_IN -> Signal Bit -- A3 @@ -205,9 +205,9 @@ -> Signal Bit -- B1 -> Signal Bit -- B0 -> Signal (FSVec D5 Bit)) -fourBitCSAdderSys2 = $(newSysDefTHName 'fourBitCSAdder' ["C_IN", "A3", "A2", "A1", "A0", +fourBitCSAdderSys2 = newSysDef fourBitCSAdder' "fourBitCSAdder" ["C_IN", "A3", "A2", "A1", "A0", "B3", "B2", "B1", "B0"] - ["vect5"]) + ["vect5"] simFourBitCSAdder2 = simulate fourBitCSAdderSys2 @@ -239,7 +239,7 @@ adder4BitProc cin a b = (unzipSY "unzip") $ (zipWith3SY "4BitAdder" adder4BitFun cin a b) adder4BitSys :: SysDef (Signal Bit -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit) -> (Signal Bit, Signal (FSVec D4 Bit))) -adder4BitSys = $(newSysDefTHName 'adder4BitProc ["cin", "a", "b"] ["cout", "sum"]) +adder4BitSys = newSysDef adder4BitProc "adder4Bit" ["cin", "a", "b"] ["cout", "sum"] simAdder4Bit = simulate adder4BitSys @@ -260,7 +260,7 @@ mux21_4BitProc = zipWith3SY "mux21" mux21Fun mux21_4BitSys :: SysDef (Signal Bit -> Signal ( FSVec D4 Bit) -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit)) -mux21_4BitSys = $(newSysDefTHName 'mux21_4BitProc ["sel", "d1", "d0"] ["out"]) +mux21_4BitSys = newSysDef mux21_4BitProc "mux21_4Bit" ["sel", "d1", "d0"] ["out"] simMux21_4Bit :: [Bit] -> [FSVec D4 Bit] -> [FSVec D4 Bit] -> [FSVec D4 Bit] simMux21_4Bit = simulate mux21_4BitSys @@ -277,14 +277,14 @@ oneProc = constSY "high" H oneSys :: SysDef (Signal Bit) -oneSys = $(newSysDefTHName 'oneProc [] ["one"]) +oneSys = newSysDef oneProc "one" [] ["one"] -- Constant input 'L' modeled with constSY zeroProc :: Signal Bit zeroProc = constSY "low" L zeroSys :: SysDef (Signal Bit) -zeroSys = $(newSysDefTHName 'zeroProc [] ["zero"]) +zeroSys = newSysDef zeroProc "zero" [] ["zero"] -- The 4-Bit carry select adder is implemented as a composition of components csAdder4BitProc :: Signal Bit -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit) -> (Signal Bit, Signal (FSVec D4 Bit)) @@ -297,7 +297,7 @@ zero = instantiate "Zero" zeroSys csAdder4BitSys :: SysDef (Signal Bit -> Signal (FSVec D4 Bit) -> Signal (FSVec D4 Bit) -> (Signal Bit, Signal (FSVec D4 Bit))) -csAdder4BitSys = $(newSysDefTHName 'csAdder4BitProc ["cin", "a", "b"] ["cout", "sum"]) +csAdder4BitSys = newSysDef csAdder4BitProc "csAdder4Bit" ["cin", "a", "b"] ["cout", "sum"] simCSAdder4Bit = simulate csAdder4BitSys @@ -323,7 +323,7 @@ zero = instantiate "Zero" zeroSys -csAdder16BitSys = $(newSysDefTHName 'csAdder16BitProc ["a", "b"] ["cout", "sum"]) +csAdder16BitSys = newSysDef csAdder16BitProc "csAdder16Bit" ["a", "b"] ["cout", "sum"] simCSAdder16Bit = simulate csAdder16BitSys diff --git a/examples/Multiplexer.hs b/examples/Multiplexer.hs --- a/examples/Multiplexer.hs +++ b/examples/Multiplexer.hs @@ -28,7 +28,7 @@ -- System definition associated to the system process 'selectProc' muxSysDef :: SysDef (Signal (Bit, Bit) -> Signal (Bit, Bit, Bit, Bit) -> Signal Bit) -muxSysDef = $(newSysDefTHName 'selectProc ["sel", "data"] ["out1"]) +muxSysDef = newSysDef selectProc "muxSys" ["sel", "data"] ["out1"] -- we simulate the system simMux :: [(Bit, Bit)] -> [(Bit, Bit, Bit, Bit)] -> [Bit] diff --git a/examples/Null.hs b/examples/Null.hs --- a/examples/Null.hs +++ b/examples/Null.hs @@ -11,7 +11,7 @@ nullSysF = () nullSysDef :: SysDef () -nullSysDef = $(newSysDefTHName 'nullSysF [] []) +nullSysDef = newSysDef nullSysF "null" [] [] nullIns0 :: () nullIns0 = instantiate "null0" nullSysDef diff --git a/examples/ParAddFour.hs b/examples/ParAddFour.hs --- a/examples/ParAddFour.hs +++ b/examples/ParAddFour.hs @@ -16,7 +16,7 @@ addSys :: SysDef (Signal Int32 -> Signal Int32 -> Signal Int32) -addSys = $(newSysDefTHName 'addProc ["in1","in2"] ["sum"]) +addSys = newSysDef addProc "add" ["in1","in2"] ["sum"] simAdd :: [Int32] -> [Int32] -> [Int32] simAdd = simulate addSys @@ -33,8 +33,8 @@ parAddFourSys :: SysDef (Signal Int32 -> Signal Int32 -> Signal Int32 -> Signal Int32 -> Signal Int32 -> (Signal Int32, Signal Int32, Signal Int32, Signal Int32)) -parAddFourSys = $(newSysDefTHName 'parAddFour ["toAdd","s1","s2","s3","s4"] - ["sum1","sum2","sum3","sum4"]) +parAddFourSys = newSysDef parAddFour "parAddFour" ["toAdd","s1","s2","s3","s4"] + ["sum1","sum2","sum3","sum4"] simParAddFour :: [Int32] diff --git a/examples/ZipTwist.hs b/examples/ZipTwist.hs --- a/examples/ZipTwist.hs +++ b/examples/ZipTwist.hs @@ -27,9 +27,9 @@ -> Signal Int32 -> Signal Int32 -> Signal Int32 -> (Signal Int32, Signal Int32, Signal Int32, Signal Int32, Signal Int32, Signal Int32)) -zipTwistSys = $(newSysDefTHName 'zipTwistFun +zipTwistSys = newSysDef zipTwistFun "zipTwist" ["in1","in2","in3","in4","in5","in6"] - ["out1","out2","out3","out4","out5","out6"]) + ["out1","out2","out3","out4","out5","out6"] simZipTwist = simulate zipTwistSys diff --git a/src/ForSyDe/Backend/VHDL/Generate.hs b/src/ForSyDe/Backend/VHDL/Generate.hs --- a/src/ForSyDe/Backend/VHDL/Generate.hs +++ b/src/ForSyDe/Backend/VHDL/Generate.hs @@ -65,13 +65,21 @@ genLibDesignFile (GlobalTravResult typeDecs subtypeDecs subProgBodies) = DesignFile commonContextClause [LUPackageDec packageDec, LUPackageBody packageBody] - where packageDec = PackageDec typesId (packageTypeDecs ++ + -- Due to dependency among types and subtypes we first output + -- unconstrained types (which may have constarined types depending on), + -- then subtypes (which we may have composite types depending on) + -- A general solution could be a type dependency resolving algorithm + where packageDec = PackageDec typesId (packageUnconsTypeDecs ++ packageSubtypeDecs ++ + packageTypeDecs ++ subProgSpecs) - packageTypeDecs = map PDITD typeDecs + packageUnconsTypeDecs = map PDITD $ filter (\a -> isUnconsType a) typeDecs + packageTypeDecs = map PDITD $ filter (\a -> (not.isUnconsType) a) typeDecs packageSubtypeDecs = map PDISD subtypeDecs subProgSpecs = map (\(SubProgBody spec _ _) -> PDISS spec) subProgBodies packageBody = PackageBody typesId subProgBodies + isUnconsType (TypeDec _ (TDA (UnconsArrayDef _ _))) = True + isUnconsType _ = False -- | Generate a list of association from two lists of signal identifiers diff --git a/src/ForSyDe/Backend/VHDL/Translate.hs b/src/ForSyDe/Backend/VHDL/Translate.hs --- a/src/ForSyDe/Backend/VHDL/Translate.hs +++ b/src/ForSyDe/Backend/VHDL/Translate.hs @@ -14,6 +14,7 @@ ----------------------------------------------------------------------------- module ForSyDe.Backend.VHDL.Translate where + import ForSyDe.Backend.VHDL.AST import qualified ForSyDe.Backend.VHDL.AST as VHDL import ForSyDe.Backend.VHDL.Constants @@ -32,7 +33,9 @@ import ForSyDe.Process.ProcType import Data.Typeable.TypeRepLib (unArrowT) +import Language.Haskell.TH.TypeLib (type2TypeRep) +import Data.Generics (tyconUQname) import Data.Int import Data.Char (digitToInt) import Data.List (intersperse) @@ -40,7 +43,7 @@ import Control.Monad.State import qualified Data.Set as S import qualified Language.Haskell.TH as TH -import Language.Haskell.TH hiding (global) +import Language.Haskell.TH hiding (global,Loc) import qualified Data.Traversable as DT import Data.Typeable import qualified Data.Param.FSVec as V @@ -139,7 +142,7 @@ [1..length outSigs] -- Generate the port interface of the block nOuts = length outSigs - tupTyCon = mkTyCon $ replicate (nOuts-1) ',' + tupTyCon = mkTyCon $ '(':replicate (nOuts-1) ','++")" inTRType = tupTyCon `mkTyConApp` outTRTypes outTMTypes <- mapM transTR2TM outTRTypes inTMType <- transTR2TM inTRType @@ -205,7 +208,7 @@ -- Get the type of the initial value initTR <- transTR2TM tr -- Translate the initial value - initExp <- withProcValC exp $ withInitTransNameSpace $ (transExp2VHDL exp) + initExp <- withProcValC exp $ withInitFunTransST $ (transExp2VHDL exp) -- Build the block let formalIn = unsafeIdAppend vPid "_in" formalOut = unsafeIdAppend vPid "_out" @@ -263,7 +266,7 @@ -> VHDLM SigDec transVHDLName2SigDec vId tr mExp = do tm <- transTR2TM tr - mVExp <- DT.mapM (\e -> withInitTransNameSpace (transExp2VHDL e)) mExp + mVExp <- DT.mapM (\e -> withInitFunTransST (transExp2VHDL e)) mExp return $ SigDec vId tm mVExp @@ -288,7 +291,12 @@ -- | Translate a local TH name to a VHDL Identifier transTHName2VHDL :: TH.Name -> VHDLM VHDLId -transTHName2VHDL = transPortId2VHDL . nameBase +-- we use pprint becase it shows unique names for local names +-- e.g. let x = 1 in let x =2 in x is printed as +-- let x_0 = 1 in let x_1 = 2 in x_1 +-- we want unique names because it saves us from dealing wiht +-- name scopes and having a global name table. +transTHName2VHDL = transPortId2VHDL . tyconUQname . pprint -- | Translate a system identifier to a VHDL identifier transSysId2VHDL :: SysId -> VHDLM VHDLId @@ -403,7 +411,7 @@ return $ Left $ (TypeDec recordId (TDR $ RecordTypeDef elems)) where (cons, args) = splitTyConApp rep conStr = tyConString cons - isTuple = all (==',') conStr + isTuple = (length conStr > 2) && (all (==',') (reverse.tail.reverse.tail $ conStr)) -- | AbstExt? @@ -480,7 +488,7 @@ funErr :: VHDLFunErr -> VHDLM a funErr err = throwFError $ UntranslatableVHDLFun err --- | Translate a typed function ast to VHDL +-- | Translate a typed function AST to VHDL transProcFun2VHDL :: TypedProcFunAST -- ^ input ast -> VHDLM (SubProgBody, VHDLId, [VHDLId], [TypeMark], TypeMark) -- ^ Function, Function name, name of inputs, type of inputs, return type @@ -489,31 +497,82 @@ addEnumTypes fEnums -- Check if the procFunAST fullfils the restrictions of the VHDL Backend -- FIXME: translate the default arguments - (fName, fInputPats, fBodyExp) <- checkProcFunAST fAST + (fName, fInputPats, fBodyExp, whereDecs) <- checkProcFunAST fAST -- Get the function spec and initialize the translation namespace (fSpec, fVHDLName, fVHDLPars, argsTM, retTM) <- transProcFunSpec fName fType fInputPats + -- Translate the where declarations and them to the + -- auxiliary declarations of the function + transDecs whereDecs -- Translate the function's body bodySm <- transFunBodyExp2VHDL fBodyExp - let fBody = SubProgBody fSpec [] [bodySm] + decs <- gets (auxDecs.funTransST.local) + let fBody = SubProgBody fSpec decs [bodySm] return (fBody, fVHDLName, fVHDLPars, argsTM, retTM) +-- | Translate a typed function AST to VHDL (only returning the functions body +transProcFun2VHDLBody :: TypedProcFunAST -> VHDLM SubProgBody +transProcFun2VHDLBody tpf = do + (body, _, _, _, _) <- transProcFun2VHDL tpf + return body +-- | Translate a list of declarations to a list of process function +-- ASTs +decs2ProcFuns :: [Dec] -> VHDLM [TypedProcFunAST] +decs2ProcFuns [] = return [] +decs2ProcFuns decs = do + (dec, t, name, clauses, restDecs) <- case decs of + -- A type signature followed by its function declaration + SigD n1 t : f@(FunD n2 cls) : xs | n1 == n2 -> + return (f, t, n1, cls, xs) + -- A type signature followed by its value declaration + -- which will be translated to a function + SigD n1 t : v@(ValD (VarP n2) bdy ds) : xs | n1 == n2 -> do + return (v, t, n1, [Clause [] bdy ds] , xs) + -- Otherwise the provided declaration block is not supported + _ -> funErr $ UnsupportedDecBlock decs + t' <- maybe (funErr $ PolyDec dec) return (type2TypeRep t) + let tpf = TypedProcFunAST t' S.empty (ProcFunAST name clauses []) + restTPFs <- decs2ProcFuns restDecs + return $ tpf:restTPFs + +-- | Tranlate a list of declarations and add them to the auxiliary +-- declarations in the function translation state +transDecs :: [Dec] -> VHDLM () +transDecs decs = do + -- first we tranlsate the declarations to process functions + tpfs <- decs2ProcFuns decs + -- Before translating the process functions we add their names to the + -- name translation table. It is important to note that, since + -- Template Haskell makes local names unique (e.g. [| let x = 1 in + -- let x = 2 in x |] is tranlsated to let x_0 = 1 in let x_1 = 2 in x_2), + -- we don't have to take care of name scopes i.e. we can have a global name + -- scope. + mapM_ addDecName tpfs + -- Translate the declarations to VHDL and add them + -- to the auxiliary declarations of the function translation + bodyDecs <- mapM (liftM SPSB . transProcFun2VHDLBody) tpfs + addDecsToFunTransST bodyDecs + where addDecName :: TypedProcFunAST -> VHDLM () + addDecName (TypedProcFunAST t _ (ProcFunAST n _ _)) = do + let arity = (length.fst.unArrowT) t + vhdlId <- transTHName2VHDL n + addTransNamePair n arity (genExprFCallN vhdlId arity) + -- | Check if a process function AST fulfils the VHDL backend restrictions. --- It returs the function TH-name its input paterns and its body expression. +-- It returs the function TH-name its input paterns, its body expression, +-- and the list of theclarations in the where construct. checkProcFunAST :: ProcFunAST - -> VHDLM (Name, [Pat], Exp) + -> VHDLM (Name, [Pat], Exp, [Dec]) -- FIXME: translate the default arguments! -checkProcFunAST (ProcFunAST thName [Clause pats (NormalB exp) []] []) = - return (thName, pats, exp) +checkProcFunAST (ProcFunAST thName [Clause pats (NormalB exp) decs] []) = + return (thName, pats, exp, decs) checkProcFunAST (ProcFunAST _ _ (_:_)) = intError "ForSyDe.Backend.VHDL.Translate.checkProcFunSpec" (UntranslatableVHDLFun $ GeneralErr (Other "default parameters are not yet supported")) -checkProcFunAST (ProcFunAST _ [Clause _ _ whereConstruct@(_:_)] _) = - funErr (FunWhereConstruct whereConstruct) checkProcFunAST (ProcFunAST _ [Clause _ bdy@(GuardedB _) _] _) = funErr (FunGuardedBody bdy) -checkProcFunAST (ProcFunAST _ clauses@(_:_:_) _) = +checkProcFunAST (ProcFunAST _ clauses@(_:_) _) = funErr (MultipleClauses clauses) -- cannot happen checkProcFunAST (ProcFunAST _ [] _) = @@ -539,7 +598,7 @@ -- Check that the number of patterns equal the function parameter number expectedN = length argsTR actualN = length fPats - when (expectedN /= actualN) (funErr $ InsParamNum actualN) + when (expectedN /= actualN) (funErr $ InsParamNum fName actualN) -- Get a VHDL identifier for each input pattern and -- initialize the translation namespace fVHDLParIds <- mapM transInputPat2VHDLId fPats @@ -660,8 +719,9 @@ -- FIXME: the exp passed (which contains the full case expression for -- error reporting purposes) should be part of the context once VHDLM -- is reworked -transMatch2VHDLCaseSmAlt contextExp (Match pat (NormalB matchExp) []) = - do sm <- transFunBodyExp2VHDL matchExp +transMatch2VHDLCaseSmAlt contextExp (Match pat (NormalB matchExp) decs) = + do transDecs decs + sm <- transFunBodyExp2VHDL matchExp case pat of -- FIXME: support pattern matching with tuples, AbsExt, -- and enumerated types @@ -672,8 +732,6 @@ VarP name -> do vHDLExp <- transExp2VHDL (VarE name) return $ CaseSmAlt [ChoiceE vHDLExp] [sm] _ -> expErr contextExp $ UnsupportedCasePat pat -transMatch2VHDLCaseSmAlt contextExp (Match _ _ whereDecs@(_:_)) = - expErr contextExp $ CaseWhereConstruct whereDecs transMatch2VHDLCaseSmAlt contextExp (Match _ bdy@(GuardedB _) _) = expErr contextExp $ CaseGuardedBody bdy @@ -710,7 +768,7 @@ -- or an unkown name. transExp2VHDL e | isConsOrFun = do -- get the symbol table (name translation table) - nameTable <- gets (nameTable.transNameSpace.local) + nameTable <- gets (nameTable.funTransST.local) case lookup name nameTable of -- found name Just (arity, transF) -> @@ -754,10 +812,14 @@ vExps <- mapM transExp2VHDL exps return $ Aggregate $ map (\expr -> ElemAssoc Nothing expr) vExps +-- Let expressions +transExp2VHDL (LetE decs e) = do + transDecs decs + transExp2VHDL e + -- Unsupported expressions transExp2VHDL lamE@(LamE _ _) = expErr lamE LambdaAbstraction transExp2VHDL condE@(CondE _ _ _) = expErr condE Conditional -transExp2VHDL letE@(LetE _ _) = expErr letE Let transExp2VHDL caseE@(CaseE _ _) = expErr caseE Case transExp2VHDL doE@(DoE _) = expErr doE Do transExp2VHDL compE@(CompE _) = expErr compE ListComprehension @@ -786,7 +848,10 @@ transTLNat2Int :: TypeRep -> Int transTLNat2Int tr -- Digit - | isDigit = (digitToInt.last.tyConString) cons + -- FIXME: Could be made cleaner. It was like this before: + -- isDigit = (digitToInt.last.tyConString) cons + -- which was not able to take care of e.g. Data.TypeLevel.Num.Aliases.D10 + | isDigit = (read.reverse.takeWhile (/='D').reverse.tyConString) cons -- Connective | otherwise = 10 * (transTLNat2Int prefix) + (transTLNat2Int lastDigit) where (cons, args@(~[prefix, lastDigit])) = splitTyConApp tr diff --git a/src/ForSyDe/Backend/VHDL/Traverse.hs b/src/ForSyDe/Backend/VHDL/Traverse.hs --- a/src/ForSyDe/Backend/VHDL/Traverse.hs +++ b/src/ForSyDe/Backend/VHDL/Traverse.hs @@ -45,8 +45,6 @@ let workDir = rootDir "vhdl" "work" liftIO $ createDirectoryIfMissing True workDir liftIO $ setCurrentDirectory workDir - -- write the local results for the first-level entity - writeLocalVHDLM -- if we are in recursive mode, also write the local results -- for the rest of the subsystems rec <- isRecursiveSet @@ -55,6 +53,8 @@ withLocalST (initLocalST ((readURef.unPrimSysDef) s)) writeLocalVHDLM mapM_ writeSub subs + -- write the local results for the first-level entity + writeLocalVHDLM -- create and change to systemName/vhdl/systemName_lib -- (remember we are in workDir) let libDir = ".." rootDir ++ "_lib" @@ -232,8 +232,3 @@ -- Othewise there is a problem of inconsisten tags _ -> intError "ForSyDe.Backend.VHDL.Traverse.defineVHDL" InconsOutTag - - - - - diff --git a/src/ForSyDe/Backend/VHDL/Traverse/VHDLM.hs b/src/ForSyDe/Backend/VHDL/Traverse/VHDLM.hs --- a/src/ForSyDe/Backend/VHDL/Traverse/VHDLM.hs +++ b/src/ForSyDe/Backend/VHDL/Traverse/VHDLM.hs @@ -76,26 +76,34 @@ -- 1) generate and write to disk the corresponding Design File -- 2) add the System Definition to the table ------------------ --- TransNameSpace ------------------ +------------- +-- FunTransST +------------- --- | Translation namespace. +-- | Function translation state. State used during the translation of +-- ProcFuns to VHDL. -- --- This type provides the number of fresh names already generated and --- a tranlsation table from Template Haskell Names to VHDL Expressions (a symbol table). +-- This type provides the number of fresh names already generated, +-- a translation table from Template Haskell Names to VHDL Expressions +-- (a symbol table) and auxiliary VHDL declarations. +-- -- It only makes sense in a process-function context. -data TransNameSpace = TransNameSpace +data FunTransST = FunTransST {freshNameCount :: Int, - nameTable :: [(Name, (Int, [VHDL.Expr] -> VHDL.Expr ) )] } - -- The table entries work as follows: - -- (Template Haskell Name (table key), - -- (Arity, function with which to construct the translated VHDL expression given its - -- arguments already translated to VHDL )) + nameTable :: [(Name, (Int, [VHDL.Expr] -> VHDL.Expr ) )], + -- The table entries work as follows: + -- (Template Haskell Name (table key), + -- (Arity, function with which to construct the translated VHDL expression + -- given itsarguments already translated to VHDL -- ) + -- ) + auxDecs :: [SubProgDecItem]} + -- Auxiliary VHDL declarations generated during the translation of + -- the ProcFun to be put in the declaration block of the translated VHDL + -- function. --- | Initial trnaslation namespace for functions -initTransNameSpace :: TransNameSpace -initTransNameSpace = TransNameSpace 0 globalNameTable +-- | Initial translation state for functions +initFunTransST :: FunTransST +initFunTransST = FunTransST 0 globalNameTable [] ----------- -- VHDLM -- @@ -119,9 +127,9 @@ {currSysDef :: SysDefVal, -- System definition which is currently -- being compiled context :: Context, -- Error Context - transNameSpace :: TransNameSpace, -- Translation namespace for functions - -- It only makes sense - -- in a process-function context + funTransST :: FunTransST, -- Translation state for functions (ProcFuns) + -- It only makes sense + -- in a process-function context localRes :: LocalTravResult} -- Result accumulated during the -- traversal of current System Definition -- netlist @@ -133,7 +141,7 @@ initLocalST :: SysDefVal -> LocalVHDLST initLocalST sysDefVal = LocalVHDLST sysDefVal (SysDefC (sid sysDefVal) (loc sysDefVal)) - initTransNameSpace emptyLocalTravResult + initFunTransST emptyLocalTravResult -- | Execute certain operation with a concrete local state. -- The initial local state is restored after the operation is executed @@ -152,22 +160,22 @@ -- return the result return res --- | Execute certain operation with the initial translation namespace --- The initial namespace is restored after the operation is executed -withInitTransNameSpace :: VHDLM a -> VHDLM a -withInitTransNameSpace action = do +-- | Execute certain operation with the initial function translation state +-- The initial state is restored after the operation is executed +withInitFunTransST :: VHDLM a -> VHDLM a +withInitFunTransST action = do -- get the initial name space st <- get let l = local st - ns = transNameSpace l + ns = funTransST l -- set the empty name space - put st{local=l{transNameSpace=initTransNameSpace}} + put st{local=l{funTransST=initFunTransST}} -- execute the action res <- action -- restore the initial name table st' <- get let l' = local st' - put st'{local=l'{transNameSpace=ns}} + put st'{local=l'{funTransST=ns}} -- return the result return res @@ -386,13 +394,17 @@ modify (\st -> st{global = case eTD of Left td@(TypeDec id _) -> + if id `notElem` (map snd transTable) then globalST {typeTable = transTable ++ [(rep, id)], globalRes = gRes{typeDecs = tDecs ++ [td]}} + else globalST Right std@(SubtypeDec id _) -> + if id `notElem` (map snd transTable) then globalST {typeTable = transTable ++ [(rep, id)], globalRes = gRes{subtypeDecs = stDecs ++ [std]}} + else globalST }) -- | Add type declaration to the global results @@ -436,15 +448,27 @@ {globalRes = gRes{subProgBodies = bodies ++ [newBody]}}}) --- | Add a TH-name (arity, VHDL expression construtor fucntion) pair to the translation namespace table +-- | Add a TH-name (arity, VHDL expression construtor function) pair to the translation namespace table addTransNamePair :: Name -> Int -> ([Expr] -> Expr) -> VHDLM () addTransNamePair thName arity vHDLFun = do lState <- gets local - let ns = transNameSpace lState - table = nameTable ns - modify (\st -> st{local=lState{transNameSpace=ns{ + let s = funTransST lState + table = nameTable s + modify (\st -> st{local=lState{funTransST=s{ nameTable=(thName,(arity,vHDLFun)):table}}}) +-- | Add a declarations to Auxiliary VHDL declarations of the Function +-- translation state +addDecsToFunTransST :: [SubProgDecItem] -> VHDLM () +addDecsToFunTransST decs = do + lState <- gets local + let s = funTransST lState + auxs = auxDecs s + modify (\st -> st{local=lState{funTransST=s{ + auxDecs=decs++auxs}}}) + + + -- | Get a fresh VHDL Identifier and increment the -- tranlation-namespace-count of freshly generated identifiers. -- @@ -457,9 +481,9 @@ genFreshVHDLId :: VHDLM VHDLId genFreshVHDLId = do lState <- gets local - let ns = transNameSpace lState + let ns = funTransST lState count = freshNameCount ns - modify (\st -> st{local=lState{transNameSpace=ns{freshNameCount=count+1}}}) + modify (\st -> st{local=lState{funTransST=ns{freshNameCount=count+1}}}) return $ unsafeVHDLBasicId ("fresh_" ++ show count) -- | Lift an 'EProne' value to the VHDL monad setting current error context diff --git a/src/ForSyDe/ForSyDeErr.hs b/src/ForSyDe/ForSyDeErr.hs --- a/src/ForSyDe/ForSyDeErr.hs +++ b/src/ForSyDe/ForSyDeErr.hs @@ -43,7 +43,7 @@ import Control.Monad.Error import Data.Dynamic import Data.Typeable -import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Syntax hiding (Loc) import Language.Haskell.TH.Ppr import Language.Haskell.TH.PprLib import Text.PrettyPrint.HughesPJ (render) @@ -124,16 +124,18 @@ -- | Function translation errors in the VHDL backend data VHDLFunErr = + -- | Polymorphic declaration + PolyDec Dec | + -- | Unsupported declaration block + UnsupportedDecBlock [Dec] | -- | Insufficient number of parameters - InsParamNum Int | + InsParamNum Name Int | -- | Unsupported input pattern in function UnsupportedFunPat Pat | -- | Multiple clauses MultipleClauses [Clause] | -- | Guards in case alternatives are not supported FunGuardedBody Body | - -- | Where constructs in case alternatives are not supported - FunWhereConstruct [Dec] | -- | A general Error which applies to a function -- (e.g. its name or parameters are not a VHDL identifier, -- an error in an inner expression ... ) @@ -141,12 +143,24 @@ instance Show VHDLFunErr where + show (PolyDec dec) = "polymorphic daclaration:\n" ++ + pprint dec ++ + "\nDeclarations within a ProcFun must be monomorphic in order to be " ++ + "translatable to VHDL" + show (UnsupportedDecBlock decs) = "Unsupported declaration block:\n" ++ + concatMap pprint decs ++ + "All declaration blocks within a process function must follow the following " ++ + "pattern:\n" ++ + " name1 :: type\n" ++ + " name1 arg1 arg2 ... = defintion1\n" ++ + " name2 :: type\n" ++ + " name2 arg1 arg2 .... = defintion2\n" show (FunGuardedBody body) = "guards are not supported in functions:\n" ++ (render.to_HPJ_Doc.(pprBody True)) body - show (FunWhereConstruct decs) = - "where constructs are not supported in functions:\n" ++ - (render.to_HPJ_Doc.where_clause) decs - show (InsParamNum n) = "insufficient number of parameters (" ++ show n ++ ")" + show (InsParamNum name n) = + "insufficient number of parameters (" ++ show n ++ ") in the defintion of `" ++ + pprint name ++ + "'\n point free definitons are not suported by the VHDL backend" show (UnsupportedFunPat pat) = "input pattern `" ++ pprint pat ++ "' is not supported" show (MultipleClauses cs) = "multiple clauses (" ++ @@ -160,8 +174,6 @@ -- Unsupported case pattern UnsupportedCasePat Pat | -- | Where constructs in case alternatives are not supported - CaseWhereConstruct [Dec] | - -- | Currification not supported function arguments must be fully supplied CurryUnsupported Int Int | -- | Unkown identifier UnkownIdentifier Name | @@ -173,8 +185,6 @@ LambdaAbstraction | -- Conditional expressions are only supported in a function body Conditional | - -- Let expressions are not supported - Let | -- Case expressions are only supported in a function body Case | -- Do expressions are not supported @@ -199,21 +209,16 @@ (render.to_HPJ_Doc.(pprBody True)) body show (UnsupportedCasePat pat) = "unsupported case pattern: `" ++ pprint pat ++ "'" - show (CaseWhereConstruct decs) = - "where constructs are not supported in case alternatives:\n" ++ - (render.to_HPJ_Doc.where_clause) decs show (CurryUnsupported expected real) = "Currification is not supported, all arguments must be fully supplied\n"++ " Expected arguments: " ++ show expected ++ " Provided arguments: " ++ show real show (UnkownIdentifier name) = "unkown identifier `" ++ pprint name ++ "'" - show UnsupportedLiteral = "unsupported literal" - + show UnsupportedLiteral = "unsupported literal" show Section = "sections are not supported" show LambdaAbstraction = "lambda abstractions are not supported" show Conditional = "conditional expressions are only supported within" ++ " a function body" - show Let = "let expressions are not supported" show Case = "case expressions are only supported within" ++ " a function body" show Do = "do expressions are not suupported" diff --git a/src/ForSyDe/Process/ProcFun.hs b/src/ForSyDe/Process/ProcFun.hs --- a/src/ForSyDe/Process/ProcFun.hs +++ b/src/ForSyDe/Process/ProcFun.hs @@ -29,8 +29,8 @@ import ForSyDe.Process.ProcVal (ProcValAST, mkProcValAST) import ForSyDe.ForSyDeErr -import Language.Haskell.TH -import Language.Haskell.TH.Syntax +import Language.Haskell.TH hiding (Loc) +import Language.Haskell.TH.Syntax hiding (Loc) import Language.Haskell.TH.LiftInstances () import Data.Dynamic import Data.Maybe (fromJust) @@ -90,7 +90,8 @@ (name, cls) <- recover (currErr $ IncorrProcFunDecs fDecs) (checkDecs fDecs) -- Generate the main expression - errInfo <- qCurrentModule + loc <- qLocation + let errInfo = loc_module loc in do exp <- [| let fName = name fClauses = cls in ProcFun $(varE name) diff --git a/src/ForSyDe/Process/ProcType.hs b/src/ForSyDe/Process/ProcType.hs --- a/src/ForSyDe/Process/ProcType.hs +++ b/src/ForSyDe/Process/ProcType.hs @@ -170,7 +170,7 @@ genTypeableIns names tupType = do -- generate n-1 commas to be consistent with the (faulty) instances -- of tuples from 2 to 7 elements - let strRep = replicate (n-1) ',' + let strRep = '(':replicate (n-1) ','++")" typeOfExpr = [| mkTyCon $(litE $ stringL strRep) `mkTyConApp` diff --git a/src/ForSyDe/System/SysDef.hs b/src/ForSyDe/System/SysDef.hs --- a/src/ForSyDe/System/SysDef.hs +++ b/src/ForSyDe/System/SysDef.hs @@ -35,7 +35,7 @@ import Control.Monad.ST import Control.Monad.State import Data.Typeable -import Language.Haskell.TH +import Language.Haskell.TH hiding (Loc) import Language.Haskell.TH.LiftInstances () @@ -185,8 +185,9 @@ (outIds, outN) when (isJust portCheck) (currError (fromJust portCheck)) -- Build the system definition - errInfo <- currentModule + loc <- location let + errInfo = loc_module loc -- Input arguments passed to the system function -- in order to get the netlist inArgs = [ [| Signal $ newInPort $(litE $ stringL id) |] diff --git a/src/Language/Haskell/TH/TypeLib.hs b/src/Language/Haskell/TH/TypeLib.hs --- a/src/Language/Haskell/TH/TypeLib.hs +++ b/src/Language/Haskell/TH/TypeLib.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.TypeLib @@ -27,14 +28,32 @@ dynTHType, thTypeOf, typeRep2Type, - tyCon2Type) + tyCon2Type, + type2TypeRep) where import Data.Dynamic import Data.Typeable import Language.Haskell.TH (Type(..), Cxt, Name, pprint, mkName) import Text.Regex.Posix ((=~)) +import Data.Maybe(isJust) +-- Due to type translations +import GHC.Exts (RealWorld) +import Data.Word (Word, Word8, Word16, Word32, Word64) +import Data.Int (Int, Int8, Int16, Int32, Int64) +import System.IO (Handle) +import Data.IORef (IORef) +import Foreign (Ptr, FunPtr, StablePtr, ForeignPtr) +import Data.Array (Array) +import Control.OldException (Exception, + AsyncException, + ArrayException, + ArithException, + IOException) +import Data.Ratio (Ratio) +import Control.Concurrent.MVar (MVar) + ----------- -- Context ----------- @@ -163,12 +182,94 @@ -- Monomorphic types reArrowT (args, ret, _) = foldr1 (-->) (args ++ [ret]) - +------------------------------------------------------------------- +-- Transforming Language.Haskell.TH.Type into Data.Typeable.TypeRep +------------------------------------------------------------------- +-- | Translate monomorphic Template Haskell Types to TypeReps +-- If the type os polymorhpic 'Nothing' will be returned +type2TypeRep :: Type -> Maybe TypeRep +-- Note: In the case of constructors, we don't need to translate to a TyCon first +-- because: +-- +-- mkTyConApp tCon [t1 .. tn] = mkTyConApp tCon [] `mkAppTy` t1 ... `mkAppTy` tn +type2TypeRep (ForallT (_:_) _ _) = Nothing +type2TypeRep (ForallT _ (_:_) _) = Nothing +type2TypeRep (ForallT _ _ t) = type2TypeRep t +type2TypeRep (VarT _) = Nothing +-- Tuple tyCon strings don't correspond to hierarchical names. They are +-- simply sequences of commas plus paranthesis: e.g. 2-tuple "(,)" 3-tuple "(,,)" .... +type2TypeRep (TupleT n) = Just $ strCon ('(':replicate (n-1) ','++")") +type2TypeRep ArrowT = Just $ typeableCon (undefined :: () -> ()) +type2TypeRep ListT = Just $ typeableCon (undefined :: [()]) +type2TypeRep (t1 `AppT` t2) = do + tRep1 <- type2TypeRep t1 + tRep2 <- type2TypeRep t2 + return $ tRep1 `mkAppTy` tRep2 +-- Constructors +type2TypeRep (ConT name) + -- There are certain TyCons whose string does not correspond + -- to the hierarchical name of the constructor (the instances generated + -- in Data.Typeable), we have to cover all those cases by hand + -- See http://hackage.haskell.org/trac/ghc/ticket/1841 for details + | isJust mSpecialTypeRep = mSpecialTypeRep + -- Tuples (they cannot be put in the table) + | isTup = Just $ strCon tupCons + -- General case + | otherwise = Just $ strCon (show name) + where (isTup, tupCons) = + case (show name =~ "^Data\\.Tuple\\.\\((,+)\\)$") + :: (String, String, String, [String]) of + -- it's a tuple, we get the commas subpart (,+) + (_, _, _, [commas]) -> (True, commas) + _ -> (False, "") + mSpecialTypeRep = lookup name specialConTable + specialConTable = + [(''() , typeableCon (undefined :: ()) ), + (''[] , typeableCon (undefined :: [()]) ), + (''Maybe , typeableCon (undefined :: Maybe ()) ), + (''Ratio , typeableCon (undefined :: Ratio ()) ), + (''Either , typeableCon (undefined :: Either () ()) ), + (''(->) , typeableCon (undefined :: () -> ()) ), + (''MVar , typeableCon (undefined :: MVar ()) ), + (''Exception , typeableCon (undefined :: Exception) ), + (''IOException , typeableCon (undefined :: IOException) ), + (''ArithException , typeableCon (undefined :: ArithException) ), + (''ArrayException , typeableCon (undefined :: ArrayException) ), + (''AsyncException , typeableCon (undefined :: AsyncException) ), + (''Array , typeableCon (undefined :: Array () ()) ), + (''Ptr , typeableCon (undefined :: Ptr ()) ), + (''FunPtr , typeableCon (undefined :: FunPtr ()) ), + (''ForeignPtr , typeableCon (undefined :: ForeignPtr ()) ), + (''StablePtr , typeableCon (undefined :: StablePtr ()) ), + (''IORef , typeableCon (undefined :: IORef ()) ), + (''Bool , typeableCon (undefined :: Bool) ), + (''Char , typeableCon (undefined :: Char) ), + (''Float , typeableCon (undefined :: Float) ), + (''Double , typeableCon (undefined :: Double) ), + (''Int , typeableCon (undefined :: Int) ), + (''Word , typeableCon (undefined :: Word) ), + (''Integer , typeableCon (undefined :: Integer) ), + (''Ordering , typeableCon (undefined :: Ordering) ), + (''Handle , typeableCon (undefined :: Handle) ), + (''Int8 , typeableCon (undefined :: Int8) ), + (''Int16 , typeableCon (undefined :: Int16) ), + (''Int32 , typeableCon (undefined :: Int32) ), + (''Int64 , typeableCon (undefined :: Int64) ), + (''Word8 , typeableCon (undefined :: Word8) ), + (''Word16 , typeableCon (undefined :: Word16) ), + (''Word32 , typeableCon (undefined :: Word32) ), + (''Word64 , typeableCon (undefined :: Word64) ), + (''TyCon , typeableCon (undefined :: TyCon) ), + (''TypeRep , typeableCon (undefined :: TypeRep) ), + (''RealWorld , typeableCon (undefined :: RealWorld) )] + + ------------------------------------------------------------------- -- Transforming Data.Typeable.TypeRep into Language.Haskell.TH.Type -------------------------------------------------------------------- +------------------------------------------------------------------- +-- | Obtain the Template Haskel type of a dynamic object dynTHType :: Dynamic -> Type dynTHType = typeRep2Type . dynTypeRep @@ -190,6 +291,7 @@ -- Internal Helper Functions ---------------------------- +-- | transfrom a Typeable type constructor to a Template Haskell Type tyConStr2Type :: String -> Type -- NOTE: The tyCon strings of basic types are not qualified and buggy in -- some cases. @@ -197,7 +299,19 @@ -- FIXME: update this function whenever the bug is fixed -- FIXME FIXME: This code is incorrect: -- mkName doesn't generate global names! ''Maybe /= mkName "Data.Maybe.Maybe" +-- in addition global names contain a packagename which cannot be guessed from +-- the type representation. tyConStr2Type "->" = ArrowT tyConStr2Type tupStr | tupStr =~ "^,+$" = ConT (mkName $ "Data.Tuple.(" ++ tupStr ++ ")") tyConStr2Type str = ConT $ mkName str + +-- Get the type constructor corresponding to a String +-- in form of a type representation +strCon :: String -> TypeRep +strCon str = mkTyCon str `mkTyConApp` [] + +-- Get the type constructor corresponding to a typeable value +-- in form of a type representation +typeableCon :: Typeable a => a -> TypeRep +typeableCon t = (typeRepTyCon . typeOf) t `mkTyConApp` [] diff --git a/tests/Install.hs b/tests/Install.hs --- a/tests/Install.hs +++ b/tests/Install.hs diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -38,8 +38,8 @@ where compilePropertiesCmd = "ghc --make -itests/properties -iexamples -package-conf testInstallation.conf " ++ "tests/properties/Main.hs -o properties" - properties = case os of - Windows _ -> "properties.exe" + properties = case buildOS of + Windows -> "properties.exe" _ -> "./properties" -- Check if we need to do the tests, This will be true unless an