ForSyDe 3.0 → 3.1
raw patch · 24 files changed
+371/−156 lines, 24 filesdep +arraydep +sybdep ~basesetup-changednew-uploader
Dependencies added: array, syb
Dependency ranges changed: base
Files
- ForSyDe.cabal +11/−9
- README +1/−1
- Setup.hs +6/−4
- dist/build/autogen/Paths_ForSyDe.hs +0/−3
- doc/www/files/tutorial/tutorial.html +2/−2
- doc/www/files/tutorial/tutorial.pdf binary
- examples/ALU.hs +21/−20
- examples/ButtonEncoder.hs +1/−1
- examples/CarrySelectAdder.hs +15/−15
- examples/Multiplexer.hs +1/−1
- examples/Null.hs +1/−1
- examples/ParAddFour.hs +3/−3
- examples/ZipTwist.hs +2/−2
- src/ForSyDe/Backend/VHDL/Generate.hs +10/−2
- src/ForSyDe/Backend/VHDL/Translate.hs +89/−24
- src/ForSyDe/Backend/VHDL/Traverse.hs +2/−7
- src/ForSyDe/Backend/VHDL/Traverse/VHDLM.hs +56/−32
- src/ForSyDe/ForSyDeErr.hs +23/−18
- src/ForSyDe/Process/ProcFun.hs +4/−3
- src/ForSyDe/Process/ProcType.hs +1/−1
- src/ForSyDe/System/SysDef.hs +3/−2
- src/Language/Haskell/TH/TypeLib.hs +117/−3
- tests/Install.hs +0/−0
- tests/Main.hs +2/−2
ForSyDe.cabal view
@@ -1,22 +1,22 @@ name: ForSyDe-version: 3.0+version: 3.1 cabal-version: >= 1.2 build-type: Custom license: BSD3 license-file: LICENSE-author: SAM group, KTH/ICT/ECS-copyright: Copyright (c) 2003-2008 SAM group, KTH/ICT/ECS+author: SAM group, KTH/ICT/ES+copyright: Copyright (c) 2003-2010 SAM group, KTH/ICT/ES maintainer: forsyde-dev@ict.kth.se-homepage: http://www.ict.kth.se/org/ict/ecs/sam/projects/forsyde/www/+homepage: http://www.ict.kth.se/forsyde/ stability: alpha synopsis: ForSyDe's Haskell-embedded Domain Specific Language. description: The ForSyDe (Formal System Design) methodology has been developed with the objective to move system design to a higher level of abstraction and to bridge the abstraction gap by transformational design refinement. - This library provides ForSyDe's implementation as a Haskell-embedded Domain Specific Language (DSL). For more information, please see ForSyDe's website: <http://www.ict.kth.se/org/ict/ecs/sam/projects/forsyde/www/>.+ This library provides ForSyDe's implementation as a Haskell-embedded Domain Specific Language (DSL). For more information, please see ForSyDe's website: <http://www.ict.kth.se/forsyde/>. category: Language-tested-with: GHC==6.8.1, GHC==6.8.2+tested-with: GHC==6.10.4 data-files: lib/forsyde.vhd -- In order to include all this files with sdist extra-source-files: LICENSE,@@ -88,7 +88,7 @@ parameterized-data, containers, packedstring,- base, + base>=4 && <6, regex-posix, mtl, pretty, @@ -97,9 +97,11 @@ directory, filepath, old-time,- random+ random,+ array,+ syb - hs-source-dirs: src, dist/build/autogen+ hs-source-dirs: src exposed-modules: Language.Haskell.TH.Lift, Language.Haskell.TH.LiftInstances, ForSyDe,
README view
@@ -12,7 +12,7 @@ Domain Specific Language (DSL). For more information, please see ForSyDe's website:- <http://www.ict.kth.se/org/ict/ecs/sam/projects/forsyde/www/>.+ <http://www.ict.kth.se/forsyde/>. INSTALLATION
Setup.hs view
@@ -29,7 +29,10 @@ forsydePostCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO ()-forsydePostCopy _ cf = compile_forsyde_vhd (copyDest cf)+forsydePostCopy _ cf = compile_forsyde_vhd $ removeFlag $ (copyDest cf) where+ removeFlag c = case c of+ Distribution.Simple.Setup.Flag x -> x+ _ -> error "Not a Flag" -- NOTE: Most of this code is duplicated from ForSyDe.Backend.VHDL.Modelsim,@@ -52,9 +55,8 @@ modelsimError err = putStrLn $ "Error: " ++ err ++ "\n" ++ " ForSyDe will work, but you will not be able to automatically\n" ++- " simulate the ForSyDe-generated VHDL models with Modelsim\n" ++- " (see function ForSyDe.Backend.VHDL.writeAndSimulateVHDL).\n\n" ++- " In order to fix this, make sure that the Modelsim executables " ++ + " compile or simulate the ForSyDe-generated VHDL models with Modelsim\n\n" +++ " In order to fix this, make sure that the Modelsim executables\n" ++ " can be found in PATH and reinstall ForSyDe" -- Look for modelsim executables
− dist/build/autogen/Paths_ForSyDe.hs
@@ -1,3 +0,0 @@--- Phony file to hush HackageDB, see http://groups.google.com/group/fa.haskell/browse_thread/thread/58994ec169aba9d0/ebcaf29a3b56c0dc?lnk=raot--- The solution is simply to require Cabal >= 1.4 once it is included with GHC--- and which allows to remove Paths_ForSyDe from ForSyDe.cabal
doc/www/files/tutorial/tutorial.html view
@@ -6,8 +6,8 @@ This document has been devised as a practical hands-on introduction to the use of ForSyDe's implementation. Thus, it is intentionally informal and non-exhaustive. If you are interested- in ForSyDe's theoretical foundations please refer to the <a class="ulink" href="http://www.ict.kth.se/org/ict/ecs/sam/projects/forsyde/www/index.html#documentation" target="_top">Documentation- section</a> in our <a class="ulink" href="http://www.ict.kth.se/org/ict/ecs/sam/projects/forsyde/www/" target="_top">website</a>.+ in ForSyDe's theoretical foundations please refer to the <a class="ulink" href="http://www.ict.kth.se/forsyde/index.html#documentation" target="_top">Documentation+ section</a> in our <a class="ulink" href="http://www.ict.kth.se/forsyde" target="_top">website</a>. </p><p> In order to take full advantage of this tutorial, it is essential to have a good background in the <a class="ulink" href="http://www.haskell.org" target="_top">Haskell</a> programming
doc/www/files/tutorial/tutorial.pdf view
binary file changed (518226 → 518046 bytes)
examples/ALU.hs view
@@ -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])
examples/ButtonEncoder.hs view
@@ -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]
examples/CarrySelectAdder.hs view
@@ -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
examples/Multiplexer.hs view
@@ -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]
examples/Null.hs view
@@ -11,7 +11,7 @@ nullSysF = () nullSysDef :: SysDef ()-nullSysDef = $(newSysDefTHName 'nullSysF [] [])+nullSysDef = newSysDef nullSysF "null" [] [] nullIns0 :: () nullIns0 = instantiate "null0" nullSysDef
examples/ParAddFour.hs view
@@ -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]
examples/ZipTwist.hs view
@@ -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
src/ForSyDe/Backend/VHDL/Generate.hs view
@@ -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
src/ForSyDe/Backend/VHDL/Translate.hs view
@@ -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
src/ForSyDe/Backend/VHDL/Traverse.hs view
@@ -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-----
src/ForSyDe/Backend/VHDL/Traverse/VHDLM.hs view
@@ -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
src/ForSyDe/ForSyDeErr.hs view
@@ -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"
src/ForSyDe/Process/ProcFun.hs view
@@ -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)
src/ForSyDe/Process/ProcType.hs view
@@ -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`
src/ForSyDe/System/SysDef.hs view
@@ -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) |]
src/Language/Haskell/TH/TypeLib.hs view
@@ -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` []
tests/Install.hs view
tests/Main.hs view
@@ -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