clash-ghc 0.99.3 → 1.0.0
raw patch · 41 files changed
+25383/−11310 lines, 41 filesdep +ghc-pathsdep +template-haskelldep +utf8-stringdep −unbound-genericsdep ~basedep ~bifunctorsdep ~clash-libnew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies added: ghc-paths, template-haskell, utf8-string
Dependencies removed: unbound-generics
Dependency ranges changed: base, bifunctors, clash-lib, clash-prelude, ghc, ghc-boot, ghc-typelits-extra, ghc-typelits-knownnat, ghc-typelits-natnormalise, ghci, hashable, lens, text, transformers, unix
API changes (from Hackage documentation)
+ Clash.GHC.Evaluator: PEM :: (Supply -> (a, Supply)) -> PrimEvalMonad a
+ Clash.GHC.Evaluator: [runPEM] :: PrimEvalMonad a -> Supply -> (a, Supply)
+ Clash.GHC.Evaluator: bConPrim :: Type -> Term
+ Clash.GHC.Evaluator: bitLiterals :: [Value] -> [(Integer, Integer)]
+ Clash.GHC.Evaluator: bitVectorLitIntLit :: TyConMap -> [Type] -> [Value] -> Maybe (Type, Integer, (Integer, Integer), Integer)
+ Clash.GHC.Evaluator: bitVectorLiterals :: [Value] -> Maybe ((Integer, Integer), (Integer, Integer))
+ Clash.GHC.Evaluator: bitVectorLiterals' :: [Value] -> [(Integer, Integer)]
+ Clash.GHC.Evaluator: boolToBoolLiteral :: TyConMap -> Type -> Bool -> Term
+ Clash.GHC.Evaluator: boolToIntLiteral :: Bool -> Term
+ Clash.GHC.Evaluator: bvAppendPrim :: TyConName -> Term
+ Clash.GHC.Evaluator: bvAppendTy :: TyConName -> Type
+ Clash.GHC.Evaluator: bvConPrim :: Type -> Term
+ Clash.GHC.Evaluator: bvSplitPrim :: TyConName -> Term
+ Clash.GHC.Evaluator: bvSplitTy :: TyConName -> Type
+ Clash.GHC.Evaluator: charLiterals :: [Value] -> Maybe (Char, Char)
+ Clash.GHC.Evaluator: charLiterals' :: [Value] -> [Char]
+ Clash.GHC.Evaluator: charToCharLiteral :: Char -> Term
+ Clash.GHC.Evaluator: doubleLiterals' :: [Value] -> [Rational]
+ Clash.GHC.Evaluator: extractKnownNat :: TyConMap -> [Type] -> Maybe (Type, Integer)
+ Clash.GHC.Evaluator: extractKnownNatVal :: TyConMap -> [Type] -> Maybe Integer
+ Clash.GHC.Evaluator: extractKnownNatVals :: TyConMap -> [Type] -> [Integer]
+ Clash.GHC.Evaluator: extractKnownNats :: TyConMap -> [Type] -> [(Type, Integer)]
+ Clash.GHC.Evaluator: extractTySizeInfo :: TyConMap -> Type -> [Type] -> (Type, Type, Integer)
+ Clash.GHC.Evaluator: floatLiterals' :: [Value] -> [Rational]
+ Clash.GHC.Evaluator: foldSplitAtTy :: TyConName -> Type
+ Clash.GHC.Evaluator: getResultTy :: TyConMap -> Type -> [Type] -> Type
+ Clash.GHC.Evaluator: ghcTyconToTyConName :: TyCon -> TyConName
+ Clash.GHC.Evaluator: indexAddTy :: TyConName -> Type
+ Clash.GHC.Evaluator: indexConPrim :: Type -> Term
+ Clash.GHC.Evaluator: indexLiterals :: [Value] -> Maybe (Integer, Integer)
+ Clash.GHC.Evaluator: indexLiterals' :: [Value] -> [Integer]
+ Clash.GHC.Evaluator: instance Clash.Util.MonadUnique Clash.GHC.Evaluator.PrimEvalMonad
+ Clash.GHC.Evaluator: instance GHC.Base.Applicative Clash.GHC.Evaluator.PrimEvalMonad
+ Clash.GHC.Evaluator: instance GHC.Base.Functor Clash.GHC.Evaluator.PrimEvalMonad
+ Clash.GHC.Evaluator: instance GHC.Base.Monad Clash.GHC.Evaluator.PrimEvalMonad
+ Clash.GHC.Evaluator: intCLiteral :: Value -> Maybe Integer
+ Clash.GHC.Evaluator: intCLiterals :: [Value] -> Maybe (Integer, Integer)
+ Clash.GHC.Evaluator: intCLiterals' :: [Value] -> [Integer]
+ Clash.GHC.Evaluator: intLiterals :: [Value] -> Maybe (Integer, Integer)
+ Clash.GHC.Evaluator: intLiterals' :: [Value] -> [Integer]
+ Clash.GHC.Evaluator: integerLiterals :: [Value] -> Maybe (Integer, Integer)
+ Clash.GHC.Evaluator: integerLiterals' :: [Value] -> [Integer]
+ Clash.GHC.Evaluator: integerToIntLiteral :: Integer -> Term
+ Clash.GHC.Evaluator: integerToIntegerLiteral :: Integer -> Term
+ Clash.GHC.Evaluator: integerToWordLiteral :: Integer -> Term
+ Clash.GHC.Evaluator: liftBitVector2 :: KnownNat n => (BitVector n -> BitVector n -> BitVector n) -> Type -> TyConMap -> [Type] -> [Value] -> Proxy n -> Maybe Term
+ Clash.GHC.Evaluator: liftBitVector2Bool :: KnownNat n => (BitVector n -> BitVector n -> Bool) -> Type -> TyConMap -> [Value] -> Proxy n -> Maybe Term
+ Clash.GHC.Evaluator: liftDD :: (Double# -> Double#) -> [Value] -> Maybe Term
+ Clash.GHC.Evaluator: liftDDD :: (Double# -> Double# -> Double#) -> [Value] -> Maybe Term
+ Clash.GHC.Evaluator: liftDDI :: (Double# -> Double# -> Int#) -> [Value] -> Maybe Term
+ Clash.GHC.Evaluator: liftFF :: (Float# -> Float#) -> [Value] -> Maybe Term
+ Clash.GHC.Evaluator: liftFFF :: (Float# -> Float# -> Float#) -> [Value] -> Maybe Term
+ Clash.GHC.Evaluator: liftFFI :: (Float# -> Float# -> Int#) -> [Value] -> Maybe Term
+ Clash.GHC.Evaluator: liftSigned2 :: KnownNat n => (Signed n -> Signed n -> Signed n) -> Type -> TyConMap -> [Type] -> [Value] -> Proxy n -> Maybe Term
+ Clash.GHC.Evaluator: liftSized2 :: (KnownNat n, Integral (sized n)) => ([Value] -> [Integer]) -> (Type -> Type -> Integer -> Integer -> Term) -> (sized n -> sized n -> sized n) -> Type -> TyConMap -> [Type] -> [Value] -> Proxy n -> Maybe Term
+ Clash.GHC.Evaluator: liftUnsigned2 :: KnownNat n => (Unsigned n -> Unsigned n -> Unsigned n) -> Type -> TyConMap -> [Type] -> [Value] -> Proxy n -> Maybe Term
+ Clash.GHC.Evaluator: mkBitLit :: Type -> Integer -> Integer -> Term
+ Clash.GHC.Evaluator: mkBitVectorLit :: Type -> Type -> Integer -> Integer -> Integer -> Term
+ Clash.GHC.Evaluator: mkBitVectorLit' :: (Type, Type, Integer) -> Integer -> Integer -> Term
+ Clash.GHC.Evaluator: mkIndexLit :: Type -> Type -> Integer -> Integer -> Term
+ Clash.GHC.Evaluator: mkIndexLit' :: (Type, Type, Integer) -> Integer -> Term
+ Clash.GHC.Evaluator: mkIndexLitE :: Type -> Type -> Integer -> Integer -> Either Term Term
+ Clash.GHC.Evaluator: mkIntCLiteral :: HasCallStack => Value -> Integer -> Term
+ Clash.GHC.Evaluator: mkSignedLit :: Type -> Type -> Integer -> Integer -> Term
+ Clash.GHC.Evaluator: mkSignedLit' :: (Type, Type, Integer) -> Integer -> Term
+ Clash.GHC.Evaluator: mkSizedLit :: (Type -> Term) -> Type -> Type -> Integer -> Integer -> Term
+ Clash.GHC.Evaluator: mkSizedLit' :: (Type -> Term) -> (Type, Type, Integer) -> Integer -> Term
+ Clash.GHC.Evaluator: mkUnsignedLit :: Type -> Type -> Integer -> Integer -> Term
+ Clash.GHC.Evaluator: mkUnsignedLit' :: (Type, Type, Integer) -> Integer -> Term
+ Clash.GHC.Evaluator: mkVecCons :: DataCon -> Type -> Integer -> Term -> Term -> Term
+ Clash.GHC.Evaluator: mkVecNil :: DataCon -> Type -> Term
+ Clash.GHC.Evaluator: naturalLiterals :: [Value] -> Maybe (Integer, Integer)
+ Clash.GHC.Evaluator: naturalLiterals' :: [Value] -> [Integer]
+ Clash.GHC.Evaluator: naturalToNaturalLiteral :: Natural -> Term
+ Clash.GHC.Evaluator: newtype PrimEvalMonad a
+ Clash.GHC.Evaluator: reduceConstant :: PrimEvaluator
+ Clash.GHC.Evaluator: runDD :: (Double# -> Double#) -> Rational -> Term
+ Clash.GHC.Evaluator: runDDD :: (Double# -> Double# -> Double#) -> Rational -> Rational -> Term
+ Clash.GHC.Evaluator: runDDI :: (Double# -> Double# -> Int#) -> Rational -> Rational -> Term
+ Clash.GHC.Evaluator: runFF :: (Float# -> Float#) -> Rational -> Term
+ Clash.GHC.Evaluator: runFFF :: (Float# -> Float# -> Float#) -> Rational -> Rational -> Term
+ Clash.GHC.Evaluator: runFFI :: (Float# -> Float# -> Int#) -> Rational -> Rational -> Term
+ Clash.GHC.Evaluator: runSizedF :: (KnownNat n, Integral (sized n)) => (sized n -> sized n -> sized n) -> Integer -> Integer -> Proxy n -> Integer
+ Clash.GHC.Evaluator: signedConPrim :: Type -> Term
+ Clash.GHC.Evaluator: signedLitIntLit :: TyConMap -> [Type] -> [Value] -> Maybe (Type, Integer, Integer, Integer)
+ Clash.GHC.Evaluator: signedLiterals :: [Value] -> Maybe (Integer, Integer)
+ Clash.GHC.Evaluator: signedLiterals' :: [Value] -> [Integer]
+ Clash.GHC.Evaluator: sizedLitIntLit :: Text -> TyConMap -> [Type] -> [Value] -> Maybe (Type, Integer, Integer, Integer)
+ Clash.GHC.Evaluator: sizedLiteral :: Text -> Value -> Maybe Integer
+ Clash.GHC.Evaluator: sizedLiterals :: Text -> [Value] -> Maybe (Integer, Integer)
+ Clash.GHC.Evaluator: sizedLiterals' :: Text -> [Value] -> [Integer]
+ Clash.GHC.Evaluator: splitAtPrim :: TyConName -> TyConName -> Term
+ Clash.GHC.Evaluator: splitAtTy :: TyConName -> TyConName -> Type
+ Clash.GHC.Evaluator: splitBV :: BitVector n -> (Integer, Integer)
+ Clash.GHC.Evaluator: svoid :: (State# RealWorld -> State# RealWorld) -> IO ()
+ Clash.GHC.Evaluator: toBV :: (Integer, Integer) -> BitVector n
+ Clash.GHC.Evaluator: typeNatAdd :: TyConName
+ Clash.GHC.Evaluator: typeNatMul :: TyConName
+ Clash.GHC.Evaluator: typeNatSub :: TyConName
+ Clash.GHC.Evaluator: typedLiterals' :: (Value -> Maybe a) -> [Value] -> [a]
+ Clash.GHC.Evaluator: unsignedConPrim :: Type -> Term
+ Clash.GHC.Evaluator: unsignedLitIntLit :: TyConMap -> [Type] -> [Value] -> Maybe (Type, Integer, Integer, Integer)
+ Clash.GHC.Evaluator: unsignedLiterals :: [Value] -> Maybe (Integer, Integer)
+ Clash.GHC.Evaluator: unsignedLiterals' :: [Value] -> [Integer]
+ Clash.GHC.Evaluator: valArgs :: Value -> Maybe [Term]
+ Clash.GHC.Evaluator: vecAppendPrim :: TyConName -> Term
+ Clash.GHC.Evaluator: vecAppendTy :: TyConName -> Type
+ Clash.GHC.Evaluator: vecHeadPrim :: TyConName -> Term
+ Clash.GHC.Evaluator: vecHeadTy :: TyConName -> Type
+ Clash.GHC.Evaluator: vecImapGoTy :: TyConName -> TyConName -> Type
+ Clash.GHC.Evaluator: vecInitPrim :: TyConName -> Term
+ Clash.GHC.Evaluator: vecLastPrim :: TyConName -> Term
+ Clash.GHC.Evaluator: vecTailPrim :: TyConName -> Term
+ Clash.GHC.Evaluator: vecTailTy :: TyConName -> Type
+ Clash.GHC.Evaluator: vecZipWithPrim :: TyConName -> Term
+ Clash.GHC.Evaluator: vecZipWithTy :: TyConName -> Type
+ Clash.GHC.Evaluator: wordLiterals :: [Value] -> Maybe (Integer, Integer)
+ Clash.GHC.Evaluator: wordLiterals' :: [Value] -> [Integer]
+ Clash.GHC.GenerateBindings: generateBindings :: OverridingBool -> [FilePath] -> [FilePath] -> [FilePath] -> HDL -> String -> Maybe DynFlags -> IO (BindingMap, TyConMap, IntMap TyConName, [(Id, Maybe TopEntity, Maybe Id)], CompiledPrimMap, [DataRepr'])
+ Clash.GHC.LoadModules: ghcLibDir :: IO FilePath
+ Clash.GHC.LoadModules: loadModules :: OverridingBool -> HDL -> String -> Maybe DynFlags -> [FilePath] -> IO ([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs, [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)], [Either UnresolvedPrimitive FilePath], [DataRepr'], [(Text, PrimitiveGuard ())])
+ Clash.GHC.LoadModules: wantedLanguageExtensions :: DynFlags -> DynFlags
+ Clash.GHC.NetlistTypes: ghcTypeToHWType :: Int -> Bool -> CustomReprs -> TyConMap -> Type -> State HWMap (Maybe (Either String FilteredHWType))
+ Clash.GHCi.Common: checkImportDirs :: Foldable t => ClashOpts -> t FilePath -> IO ()
+ Clash.GHCi.Common: checkMonoLocalBinds :: DynFlags -> IO ()
+ Clash.GHCi.Common: checkMonoLocalBindsMod :: ModSummary -> IO ()
Files
- CHANGELOG.md +126/−0
- LICENSE +2/−2
- README.md +6/−6
- clash-ghc.cabal +73/−35
- src-bin-821/Clash/GHCi/HsVersions.h +68/−0
- src-bin-821/Clash/GHCi/UI.hs +3874/−0
- src-bin-821/Clash/GHCi/UI/Info.hs +366/−0
- src-bin-821/Clash/GHCi/UI/Monad.hs +454/−0
- src-bin-821/Clash/GHCi/UI/Tags.hs +215/−0
- src-bin-821/Clash/Main.hs +1016/−0
- src-bin-841/Clash/GHCi/UI.hs +58/−29
- src-bin-841/Clash/Main.hs +21/−93
- src-bin-861/Clash/GHCi/Leak.hs +59/−0
- src-bin-861/Clash/GHCi/UI.hs +3986/−0
- src-bin-861/Clash/GHCi/UI/Info.hs +368/−0
- src-bin-861/Clash/GHCi/UI/Monad.hs +470/−0
- src-bin-861/Clash/GHCi/UI/Tags.hs +215/−0
- src-bin-861/Clash/Main.hs +1024/−0
- src-bin-881/Clash/GHCi/Leak.hs +75/−0
- src-bin-881/Clash/GHCi/UI.hs +4104/−0
- src-bin-881/Clash/GHCi/UI/Info.hs +379/−0
- src-bin-881/Clash/GHCi/UI/Monad.hs +533/−0
- src-bin-881/Clash/GHCi/UI/Tags.hs +216/−0
- src-bin-881/Clash/GHCi/Util.hs +16/−0
- src-bin-881/Clash/Main.hs +1045/−0
- src-bin-common/Clash/GHCi/Common.hs +66/−0
- src-bin/Clash/GHCi/HsVersions.h +0/−68
- src-bin/Clash/GHCi/UI.hs +0/−3847
- src-bin/Clash/GHCi/UI/Info.hs +0/−366
- src-bin/Clash/GHCi/UI/Monad.hs +0/−454
- src-bin/Clash/GHCi/UI/Tags.hs +0/−215
- src-bin/Clash/Main.hs +0/−1088
- src-ghc/Clash/GHC/ClashFlags.hs +78/−19
- src-ghc/Clash/GHC/Evaluator.hs +4264/−3730
- src-ghc/Clash/GHC/GHC2Core.hs +1221/−857
- src-ghc/Clash/GHC/GenerateBindings.hs +213/−130
- src-ghc/Clash/GHC/LoadInterfaceFiles.hs +124/−107
- src-ghc/Clash/GHC/LoadModules.hs +355/−149
- src-ghc/Clash/GHC/NetlistTypes.hs +246/−114
- src-ghc/Clash/GHC/Util.hs +46/−0
- src-ghc/Interactive.hs +1/−1
CHANGELOG.md view
@@ -1,5 +1,131 @@ # Changelog for the [`clash-ghc`](http://hackage.haskell.org/package/clash-ghc) package +## 1.0.0 *September 3rd 2019*+* 10x - 50x faster compile times+* New features:+ * API changes: check the migration guide at the end of `Clash.Tutorial`+ * All memory elements now have an (implicit) enable line; "Gated" clocks have+ been removed as the clock wasn't actually gated, but implemented as an+ enable line.+ * Circuit domains are now configurable in:+ * (old) The clock period+ * (new) Clock edge on which memory elements latch their inputs+ (rising edge or falling edge)+ * (new) Whether the reset port of a memory element is level sensitive+ (asynchronous reset) or edge sensitive (synchronous reset)+ * (new) Whether the reset port of a memory element is active-high or+ active-low (negated reset)+ * (new) Whether memory element power on in a configurable/defined state+ (common on FPGAs) or in an undefined state (ASICs)++ * See the [blog post](https://clash-lang.org/blog/0005-synthesis-domain/) on this new feature+ * Data types can now be given custom bit-representations: http://hackage.haskell.org/package/clash-prelude/docs/Clash-Annotations-BitRepresentation.html+ * Annotate expressions with attributes that persist in the generated HDL,+ e.g. synthesis directives: http://hackage.haskell.org/package/clash-prelude/docs/Clash-Annotations-SynthesisAttributes.html+ * Control (System)Verilog module instance, and VHDL entity instantiation names+ in generated code: http://hackage.haskell.org/package/clash-prelude/docs/Clash-Magic.html+ * Much improved infrastructure for handling of unknown values: defined spine,+ but unknown leafs: http://hackage.haskell.org/package/clash-prelude/docs/Clash-XException.html#t:NFDataX+ * Experimental: Multiple hidden clocks. Can be enabled by compiling+ `clash-prelude` with `-fmultiple-hidden`+ * Experimental: Limited GADT support (pattern matching on vectors, or custom+ GADTs as longs as their usage can be statically removed; no support of+ recursive GADTs)+ * Experimental: Use regular Haskell functions to generate HDL black boxes for+ primitives (in an addition to existing string templates for HDL black boxes)+ See for example: http://hackage.haskell.org/package/clash-lib/docs/Clash-Primitives-Intel-ClockGen.html++* Fixes issues:+ * [#316](https://github.com/clash-lang/clash-prelude/issues/316)+ * [#319](https://github.com/clash-lang/clash-prelude/issues/319)+ * [#323](https://github.com/clash-lang/clash-prelude/issues/323)+ * [#324](https://github.com/clash-lang/clash-prelude/issues/324)+ * [#329](https://github.com/clash-lang/clash-prelude/issues/329)+ * [#331](https://github.com/clash-lang/clash-prelude/issues/331)+ * [#332](https://github.com/clash-lang/clash-prelude/issues/332)+ * [#335](https://github.com/clash-lang/clash-prelude/issues/335)+ * [#348](https://github.com/clash-lang/clash-prelude/issues/348)+ * [#349](https://github.com/clash-lang/clash-prelude/issues/349)+ * [#350](https://github.com/clash-lang/clash-prelude/issues/350)+ * [#351](https://github.com/clash-lang/clash-prelude/issues/351)+ * [#352](https://github.com/clash-lang/clash-prelude/issues/352)+ * [#353](https://github.com/clash-lang/clash-prelude/issues/353)+ * [#358](https://github.com/clash-lang/clash-prelude/issues/358)+ * [#359](https://github.com/clash-lang/clash-prelude/issues/359)+ * [#363](https://github.com/clash-lang/clash-prelude/issues/363)+ * [#364](https://github.com/clash-lang/clash-prelude/issues/364)+ * [#365](https://github.com/clash-lang/clash-prelude/issues/365)+ * [#371](https://github.com/clash-lang/clash-prelude/issues/371)+ * [#372](https://github.com/clash-lang/clash-prelude/issues/372)+ * [#373](https://github.com/clash-lang/clash-prelude/issues/373)+ * [#378](https://github.com/clash-lang/clash-prelude/issues/378)+ * [#380](https://github.com/clash-lang/clash-prelude/issues/380)+ * [#381](https://github.com/clash-lang/clash-prelude/issues/381)+ * [#382](https://github.com/clash-lang/clash-prelude/issues/382)+ * [#383](https://github.com/clash-lang/clash-prelude/issues/383)+ * [#387](https://github.com/clash-lang/clash-prelude/issues/387)+ * [#393](https://github.com/clash-lang/clash-prelude/issues/393)+ * [#396](https://github.com/clash-lang/clash-prelude/issues/396)+ * [#398](https://github.com/clash-lang/clash-prelude/issues/398)+ * [#399](https://github.com/clash-lang/clash-prelude/issues/399)+ * [#401](https://github.com/clash-lang/clash-prelude/issues/401)+ * [#403](https://github.com/clash-lang/clash-prelude/issues/403)+ * [#407](https://github.com/clash-lang/clash-prelude/issues/407)+ * [#412](https://github.com/clash-lang/clash-prelude/issues/412)+ * [#413](https://github.com/clash-lang/clash-prelude/issues/413)+ * [#420](https://github.com/clash-lang/clash-prelude/issues/420)+ * [#422](https://github.com/clash-lang/clash-prelude/issues/422)+ * [#423](https://github.com/clash-lang/clash-prelude/issues/423)+ * [#424](https://github.com/clash-lang/clash-prelude/issues/424)+ * [#438](https://github.com/clash-lang/clash-prelude/issues/438)+ * [#450](https://github.com/clash-lang/clash-prelude/issues/450)+ * [#452](https://github.com/clash-lang/clash-prelude/issues/452)+ * [#455](https://github.com/clash-lang/clash-prelude/issues/455)+ * [#460](https://github.com/clash-lang/clash-prelude/issues/460)+ * [#461](https://github.com/clash-lang/clash-prelude/issues/461)+ * [#463](https://github.com/clash-lang/clash-prelude/issues/463)+ * [#468](https://github.com/clash-lang/clash-prelude/issues/468)+ * [#475](https://github.com/clash-lang/clash-prelude/issues/475)+ * [#476](https://github.com/clash-lang/clash-prelude/issues/476)+ * [#500](https://github.com/clash-lang/clash-prelude/issues/500)+ * [#507](https://github.com/clash-lang/clash-prelude/issues/507)+ * [#512](https://github.com/clash-lang/clash-prelude/issues/512)+ * [#516](https://github.com/clash-lang/clash-prelude/issues/516)+ * [#517](https://github.com/clash-lang/clash-prelude/issues/517)+ * [#526](https://github.com/clash-lang/clash-prelude/issues/526)+ * [#556](https://github.com/clash-lang/clash-prelude/issues/556)+ * [#560](https://github.com/clash-lang/clash-prelude/issues/560)+ * [#566](https://github.com/clash-lang/clash-prelude/issues/566)+ * [#567](https://github.com/clash-lang/clash-prelude/issues/567)+ * [#569](https://github.com/clash-lang/clash-prelude/issues/569)+ * [#573](https://github.com/clash-lang/clash-prelude/issues/573)+ * [#575](https://github.com/clash-lang/clash-prelude/issues/575)+ * [#581](https://github.com/clash-lang/clash-prelude/issues/581)+ * [#582](https://github.com/clash-lang/clash-prelude/issues/582)+ * [#586](https://github.com/clash-lang/clash-prelude/issues/586)+ * [#588](https://github.com/clash-lang/clash-prelude/issues/588)+ * [#591](https://github.com/clash-lang/clash-prelude/issues/591)+ * [#596](https://github.com/clash-lang/clash-prelude/issues/596)+ * [#601](https://github.com/clash-lang/clash-prelude/issues/601)+ * [#607](https://github.com/clash-lang/clash-prelude/issues/607)+ * [#629](https://github.com/clash-lang/clash-prelude/issues/629)+ * [#637](https://github.com/clash-lang/clash-prelude/issues/637)+ * [#644](https://github.com/clash-lang/clash-prelude/issues/644)+ * [#647](https://github.com/clash-lang/clash-prelude/issues/647)+ * [#661](https://github.com/clash-lang/clash-prelude/issues/661)+ * [#668](https://github.com/clash-lang/clash-prelude/issues/668)+ * [#677](https://github.com/clash-lang/clash-prelude/issues/677)+ * [#678](https://github.com/clash-lang/clash-prelude/issues/678)+ * [#682](https://github.com/clash-lang/clash-prelude/issues/682)+ * [#691](https://github.com/clash-lang/clash-prelude/issues/691)+ * [#703](https://github.com/clash-lang/clash-prelude/issues/703)+ * [#713](https://github.com/clash-lang/clash-prelude/issues/713)+ * [#715](https://github.com/clash-lang/clash-prelude/issues/715)+ * [#727](https://github.com/clash-lang/clash-prelude/issues/727)+ * [#730](https://github.com/clash-lang/clash-prelude/issues/730)+ * [#736](https://github.com/clash-lang/clash-prelude/issues/736)+ * [#738](https://github.com/clash-lang/clash-prelude/issues/738)+ ## 0.99.3 *July 28th 2018* * Fixes bugs: * Evaluator recognizes `Bit` literals [#329](https://github.com/clash-lang/clash-compiler/issues/329)
LICENSE view
@@ -1,6 +1,6 @@ Copyright (c) 2012-2016, University of Twente,- 2016-2017, Myrtle Software Ltd,- 2017 , QBayLogic, Google Inc.+ 2016-2019, Myrtle Software Ltd,+ 2017-2019, QBayLogic B.V., Google Inc. All rights reserved. Redistribution and use in source and binary forms, with or without
README.md view
@@ -1,16 +1,16 @@-# `clash-ghc` - Haskell/GHC front-end for the CλaSH compiler+# `clash-ghc` - Haskell/GHC front-end for the Clash compiler * See the LICENSE file for license and copyright details * Contains code from the [GHC compiler](http://haskell.org/ghc), see the LICENSE_GHC file for license and copyright details pertaining to that code. -# CλaSH - A functional hardware description language-CλaSH (pronounced ‘clash’) is a functional hardware description language that-borrows both its syntax and semantics from the functional programming language-Haskell. The CλaSH compiler transforms these high-level descriptions to+# Clash - A functional hardware description language+Clash is a functional hardware description language that borrows both+its syntax and semantics from the functional programming language+Haskell. The Clash compiler transforms these high-level descriptions to low-level synthesizable VHDL, Verilog, or SystemVerilog. -Features of CλaSH:+Features of Clash: * Strongly typed (like VHDL), yet with a very high degree of type inference, enabling both safe and fast prototying using consise descriptions (like
clash-ghc.cabal view
@@ -1,13 +1,13 @@ Name: clash-ghc-Version: 0.99.3+Version: 1.0.0 Synopsis: CAES Language for Synchronous Hardware Description:- CλaSH (pronounced ‘clash’) is a functional hardware description language that- borrows both its syntax and semantics from the functional programming language- Haskell. The CλaSH compiler transforms these high-level descriptions to- low-level synthesizable VHDL, Verilog, or SystemVerilog.+ Clash is a functional hardware description language that borrows both its+ syntax and semantics from the functional programming language Haskell. The+ Clash compiler transforms these high-level descriptions to low-level+ synthesizable VHDL, Verilog, or SystemVerilog. .- Features of CλaSH:+ Features of Clash: . * Strongly typed, but with a very high degree of type inference, enabling both safe and fast prototyping using concise descriptions.@@ -26,7 +26,7 @@ . This package provides: .- * CλaSH Compiler binary using GHC/Haskell as a frontend+ * Clash Compiler binary using GHC/Haskell as a frontend . . Prelude library: <http://hackage.haskell.org/package/clash-prelude>@@ -34,11 +34,11 @@ bug-reports: http://github.com/clash-lang/clash-compiler/issues License: BSD2 License-file: LICENSE-Author: Christiaan Baaij-Maintainer: Christiaan Baaij <christiaan.baaij@gmail.com>+Author: The Clash Authors+Maintainer: QBayLogic B.V. <devops@qbaylogic.com> Copyright: Copyright © 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd,- 2017 , QBayLogic, Google Inc.+ 2017-2019, QBayLogic B.V., Google Inc. Category: Hardware Build-type: Simple @@ -46,7 +46,7 @@ CHANGELOG.md, LICENSE_GHC, cbits/PosixSource.h,- src-bin/Clash/GHCi/HsVersions.h+ src-bin-821/Clash/GHCi/HsVersions.h src-bin-841/Clash/GHCi/HsVersions.h Cabal-version: >=1.10@@ -55,10 +55,24 @@ type: git location: https://github.com/clash-lang/clash-compiler.git +flag dynamic+ description:+ Build Clash binaries with GHC flag `-dynamic`. This flag should only be used for packaging purposes. Installations using cabal should use `--enable-executable-dynamic`!+ default: False+ manual: True++flag use-ghc-paths+ description:+ Locate the GHC core libraries using the `ghc-paths` package. Note: this flag may make binaries less relocatable, by hard-coding an absolute path to the core libraries.+ default: False+ manual: True+ executable clash Main-Is: src-ghc/Batch.hs Build-Depends: base, clash-ghc GHC-Options: -Wall+ if flag(dynamic)+ GHC-Options: -dynamic extra-libraries: pthread default-language: Haskell2010 @@ -66,15 +80,25 @@ Main-Is: src-ghc/Interactive.hs Build-Depends: base, clash-ghc GHC-Options: -Wall+ if flag(dynamic)+ GHC-Options: -dynamic extra-libraries: pthread default-language: Haskell2010 library- HS-Source-Dirs: src-ghc- if impl(ghc >= 8.4.1)- HS-Source-Dirs: src-bin-841+ HS-Source-Dirs: src-ghc, src-bin-common+ -- when we move to `cabal-version: 2.2`, we can use elif instead of these nested ifs, but ghc-8.2 comes with cabal-2.0+ if impl(ghc >= 8.7.0)+ HS-Source-Dirs: src-bin-881 else- HS-Source-Dirs: src-bin+ if impl(ghc >= 8.6.0)+ HS-Source-Dirs: src-bin-861+ else+ if impl(ghc >= 8.4.1)+ HS-Source-Dirs: src-bin-841+ else+ if impl(ghc >= 8.2.1)+ HS-Source-Dirs: src-bin-821 default-language: Haskell2010 GHC-Options: -Wall -fno-warn-name-shadowing@@ -96,59 +120,73 @@ ViewPatterns Build-Depends: array >= 0.4 && < 0.6,- base >= 4.3.1.0 && < 5,- bifunctors >= 4.1.1 && < 5.6,+ base >= 4.10 && < 5,+ bifunctors >= 4.1.1 && < 6.0, bytestring >= 0.9 && < 0.11, containers >= 0.5.4.0 && < 0.7, directory >= 1.2 && < 1.4, filepath >= 1.3 && < 1.5,- ghc >= 8.2.0 && < 8.8,+ ghc >= 8.2.0 && < 8.9, process >= 1.2 && < 1.7,- hashable >= 1.1.2.3 && < 1.3,+ hashable >= 1.1.2.3 && < 1.4, haskeline >= 0.7.0.3 && < 0.8,- lens >= 4.0.5 && < 4.18,+ lens >= 4.0.5 && < 4.19, mtl >= 2.1.1 && < 2.3,- text >= 0.11.3.1 && < 1.3,- transformers >= 0.4.2 && < 0.6,- unbound-generics >= 0.1 && < 0.4,+ text >= 1.2.2 && < 1.3,+ transformers >= 0.5.2.0 && < 0.6, unordered-containers >= 0.2.1.0 && < 0.3, - clash-lib >= 0.7.1 && < 1.0,- clash-prelude >= 0.11.2 && < 1.0,+ clash-lib >= 1.0 && < 1.1,+ clash-prelude >= 1.0 && < 1.1, concurrent-supply >= 0.1.7 && < 0.2,- ghc-typelits-extra >= 0.2.5 && < 0.3,- ghc-typelits-knownnat >= 0.5 && < 0.6,- ghc-typelits-natnormalise >= 0.6 && < 0.7,+ ghc-typelits-extra >= 0.3.1 && < 0.4,+ ghc-typelits-knownnat >= 0.6 && < 0.8,+ ghc-typelits-natnormalise >= 0.6 && < 0.8, deepseq >= 1.3.0.2 && < 1.5, time >= 1.4.0.1 && < 1.10,- ghc-boot >= 8.0.2 && < 8.8,+ ghc-boot >= 8.2.0 && < 8.9, ghc-prim >= 0.3.1.0 && < 0.6,- ghci >= 8.2.0 && < 8.8,+ ghci >= 8.2.0 && < 8.9, uniplate >= 1.6.12 && < 1.8, reflection >= 2.1.2 && < 3.0, integer-gmp >= 1.0.1.0 && < 2.0, primitive >= 0.5.0.1 && < 1.0,+ template-haskell >= 2.8.0.0 && < 2.16,+ utf8-string >= 1.0.0.0 && < 1.1.0.0, vector >= 0.11 && < 1.0+ if flag(use-ghc-paths)+ Build-Depends: ghc-paths+ CPP-Options: -DUSE_GHC_PATHS=1 if os(windows) Build-Depends: Win32 >= 2.3.1 && < 2.9 else- Build-Depends: unix >= 2.7.1 && < 2.8+ Build-Depends: unix >= 2.7.1 && < 2.9 Include-dirs: cbits C-Sources: cbits/hschooks.c Exposed-Modules: Clash.Main++ -- exposed for use by the benchmarks+ Clash.GHC.Evaluator+ Clash.GHC.GenerateBindings+ Clash.GHC.LoadModules+ Clash.GHC.NetlistTypes++ Clash.GHCi.Common+ Other-Modules: Clash.GHCi.UI Clash.GHCi.UI.Info Clash.GHCi.UI.Monad Clash.GHCi.UI.Tags Clash.GHC.ClashFlags- Clash.GHC.Evaluator- Clash.GHC.GenerateBindings Clash.GHC.GHC2Core Clash.GHC.LoadInterfaceFiles- Clash.GHC.LoadModules- Clash.GHC.NetlistTypes+ Clash.GHC.Util Paths_clash_ghc+ if impl(ghc >= 8.6.0)+ Other-Modules: Clash.GHCi.Leak+ if impl(ghc >= 8.8.0)+ Other-Modules: Clash.GHCi.Util
+ src-bin-821/Clash/GHCi/HsVersions.h view
@@ -0,0 +1,68 @@+#ifndef HSVERSIONS_H+#define HSVERSIONS_H++#if 0++IMPORTANT! If you put extra tabs/spaces in these macro definitions,+you will screw up the layout where they are used in case expressions!++(This is cpp-dependent, of course)++#endif++/* Useful in the headers that we share with the RTS */+#define COMPILING_GHC 1++/* Pull in all the platform defines for this build (foo_TARGET_ARCH etc.) */+/* #include "ghc_boot_platform.h" */++/* Pull in the autoconf defines (HAVE_FOO), but don't include+ * ghcconfig.h, because that will include ghcplatform.h which has the+ * wrong platform settings for the compiler (it has the platform+ * settings for the target plat instead). */+/* #include "ghcautoconf.h" */++#define GLOBAL_VAR(name,value,ty) \+{-# NOINLINE name #-}; \+name :: IORef (ty); \+name = Util.global (value);++#define GLOBAL_VAR_M(name,value,ty) \+{-# NOINLINE name #-}; \+name :: IORef (ty); \+name = Util.globalM (value);+++#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \+{-# NOINLINE name #-}; \+name :: IORef (ty); \+name = Util.sharedGlobal (value) (accessor); \+foreign import ccall unsafe saccessor \+ accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));++#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty) \+{-# NOINLINE name #-}; \+name :: IORef (ty); \+name = Util.sharedGlobalM (value) (accessor); \+foreign import ccall unsafe saccessor \+ accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));+++#define ASSERT(e) if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else+#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else+#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $++-- Examples: Assuming flagSet :: String -> m Bool+--+-- do { c <- getChar; MASSERT( isUpper c ); ... }+-- do { c <- getChar; MASSERT2( isUpper c, text "Bad" ); ... }+-- do { str <- getStr; ASSERTM( flagSet str ); .. }+-- do { str <- getStr; ASSERTM2( flagSet str, text "Bad" ); .. }+-- do { str <- getStr; WARNM2( flagSet str, text "Flag is set" ); .. }+#define MASSERT(e) ASSERT(e) return ()+#define MASSERT2(e,msg) ASSERT2(e,msg) return ()+#define ASSERTM(e) do { bool <- e; MASSERT(bool) }+#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) }+#define WARNM2(e,msg) do { bool <- e; WARN(bool, msg) return () }++#endif /* HsVersions.h */
+ src-bin-821/Clash/GHCi/UI.hs view
@@ -0,0 +1,3874 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS -fno-cse #-}+-- -fno-cse is needed for GLOBAL_VAR's to behave properly++-----------------------------------------------------------------------------+--+-- GHC Interactive User Interface+--+-- (c) The GHC Team 2005-2006+--+-----------------------------------------------------------------------------++module Clash.GHCi.UI (+ interactiveUI,+ GhciSettings(..),+ defaultGhciSettings,+ ghciCommands,+ ghciWelcomeMsg,+ makeHDL+ ) where++#include "HsVersions.h"++-- GHCi+import qualified Clash.GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls )+import Clash.GHCi.UI.Monad hiding ( args, runStmt, runDecls )+import Clash.GHCi.UI.Tags+import Clash.GHCi.UI.Info+import Debugger++-- The GHC interface+import GHCi+import GHCi.RemoteTypes+import GHCi.BreakArray+import DynFlags+import ErrUtils+import GhcMonad ( modifySession )+import qualified GHC+import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..),+ TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,+ getModuleGraph, handleSourceError )+import HsImpExp+import HsSyn+import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,+ setInteractivePrintName, hsc_dflags, msObjFilePath )+import Module+import Name+import Packages ( trusted, getPackageDetails, getInstalledPackageDetails,+ listVisibleModuleNames, pprFlag )+import IfaceSyn ( showToHeader )+import PprTyThing+import PrelNames+import RdrName ( RdrName, getGRE_NameQualifier_maybes, getRdrName )+import SrcLoc+import qualified Lexer++import StringBuffer+import Outputable hiding ( printForUser, printForUserPartWay )++-- Other random utilities+import BasicTypes hiding ( isTopLevel )+import Digraph+import Encoding+import FastString+import Linker+import Maybes ( orElse, expectJust )+import NameSet+import Panic hiding ( showException )+import Util+import qualified GHC.LanguageExtensions as LangExt++-- Haskell Libraries+import System.Console.Haskeline as Haskeline++import Control.Applicative hiding (empty)+import Control.DeepSeq (deepseq)+import Control.Monad as Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except++import Data.Array+import qualified Data.ByteString.Char8 as BS+import Data.Char+import Data.Function+import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )+import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,+ partition, sort, sortBy )+import qualified Data.Set as S+import Data.Maybe+import qualified Data.Map as M+import Data.Time.LocalTime ( getZonedTime )+import Data.Time.Format ( formatTime, defaultTimeLocale )+import Data.Version ( showVersion )++import Exception hiding (catch)+import Foreign hiding (void)+import GHC.Stack hiding (SrcLoc(..))++import System.Directory+import System.Environment+import System.Exit ( exitWith, ExitCode(..) )+import System.FilePath+import System.Info+import System.IO+import System.IO.Error+import System.IO.Unsafe ( unsafePerformIO )+import System.Process+import Text.Printf+import Text.Read ( readMaybe )+import Text.Read.Lex (isSymbolChar)++import Unsafe.Coerce++#if !defined(mingw32_HOST_OS)+import System.Posix hiding ( getEnv )+#else+import qualified System.Win32+#endif++import GHC.IO.Exception ( IOErrorType(InvalidArgument) )+import GHC.IO.Handle ( hFlushAll )+import GHC.TopHandler ( topHandler )++-- clash additions+import qualified Clash.Backend+import Clash.Backend.SystemVerilog (SystemVerilogState)+import Clash.Backend.VHDL (VHDLState)+import Clash.Backend.Verilog (VerilogState)+import qualified Clash.Driver+import Clash.Driver.Types (ClashOpts (..))+import Clash.GHC.Evaluator+import Clash.GHC.GenerateBindings+import Clash.GHC.NetlistTypes+import Clash.GHCi.Common+import Clash.Netlist.BlackBox.Types (HdlSyn)+import Clash.Util (clashLibVersion, reportTimeDiff)+import qualified Data.Time.Clock as Clock+import qualified Paths_clash_ghc++import Clash.Annotations.BitRepresentation.Internal (buildCustomReprs)++-----------------------------------------------------------------------------++data GhciSettings = GhciSettings {+ availableCommands :: [Command],+ shortHelpText :: String,+ fullHelpText :: String,+ defPrompt :: PromptFunction,+ defPromptCont :: PromptFunction+ }++defaultGhciSettings :: IORef ClashOpts -> GhciSettings+defaultGhciSettings opts =+ GhciSettings {+ availableCommands = ghciCommands opts,+ shortHelpText = defShortHelpText,+ defPrompt = default_prompt,+ defPromptCont = default_prompt_cont,+ fullHelpText = defFullHelpText+ }++ghciWelcomeMsg :: String+ghciWelcomeMsg = "CLaSHi, version " ++ Data.Version.showVersion Paths_clash_ghc.version +++ " (using clash-lib, version " ++ Data.Version.showVersion clashLibVersion +++ "):\nhttp://www.clash-lang.org/ :? for help"++ghciCommands :: IORef ClashOpts -> [Command]+ghciCommands opts = map mkCmd [+ -- Hugs users are accustomed to :e, so make sure it doesn't overlap+ ("?", keepGoing help, noCompletion),+ ("add", keepGoingPaths addModule, completeFilename),+ ("abandon", keepGoing abandonCmd, noCompletion),+ ("break", keepGoing breakCmd, completeIdentifier),+ ("back", keepGoing backCmd, noCompletion),+ ("browse", keepGoing' (browseCmd False), completeModule),+ ("browse!", keepGoing' (browseCmd True), completeModule),+ ("cd", keepGoing' changeDirectory, completeFilename),+ ("check", keepGoing' checkModule, completeHomeModule),+ ("continue", keepGoing continueCmd, noCompletion),+ ("cmd", keepGoing cmdCmd, completeExpression),+ ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename),+ ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename),+ ("def", keepGoing (defineMacro False), completeExpression),+ ("def!", keepGoing (defineMacro True), completeExpression),+ ("delete", keepGoing deleteCmd, noCompletion),+ ("edit", keepGoing' editFile, completeFilename),+ ("etags", keepGoing createETagsFileCmd, completeFilename),+ ("force", keepGoing forceCmd, completeExpression),+ ("forward", keepGoing forwardCmd, noCompletion),+ ("help", keepGoing help, noCompletion),+ ("history", keepGoing historyCmd, noCompletion),+ ("info", keepGoing' (info False), completeIdentifier),+ ("info!", keepGoing' (info True), completeIdentifier),+ ("issafe", keepGoing' isSafeCmd, completeModule),+ ("kind", keepGoing' (kindOfType False), completeIdentifier),+ ("kind!", keepGoing' (kindOfType True), completeIdentifier),+ ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),+ ("load!", keepGoingPaths loadModuleDefer, completeHomeModuleOrFile),+ ("list", keepGoing' listCmd, noCompletion),+ ("module", keepGoing moduleCmd, completeSetModule),+ ("main", keepGoing runMain, completeFilename),+ ("print", keepGoing printCmd, completeExpression),+ ("quit", quit, noCompletion),+ ("reload", keepGoing' reloadModule, noCompletion),+ ("reload!", keepGoing' reloadModuleDefer, noCompletion),+ ("run", keepGoing runRun, completeFilename),+ ("script", keepGoing' scriptCmd, completeFilename),+ ("set", keepGoing setCmd, completeSetOptions),+ ("seti", keepGoing setiCmd, completeSeti),+ ("show", keepGoing showCmd, completeShowOptions),+ ("showi", keepGoing showiCmd, completeShowiOptions),+ ("sprint", keepGoing sprintCmd, completeExpression),+ ("step", keepGoing stepCmd, completeIdentifier),+ ("steplocal", keepGoing stepLocalCmd, completeIdentifier),+ ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),+ ("type", keepGoing' typeOfExpr, completeExpression),+ ("trace", keepGoing traceCmd, completeExpression),+ ("undef", keepGoing undefineMacro, completeMacro),+ ("unset", keepGoing unsetOptions, completeSetOptions),+ ("where", keepGoing whereCmd, noCompletion),+ ("vhdl", keepGoingPaths (makeVHDL opts), completeHomeModuleOrFile),+ ("verilog", keepGoingPaths (makeVerilog opts), completeHomeModuleOrFile),+ ("systemverilog", keepGoingPaths (makeSystemVerilog opts), completeHomeModuleOrFile)+ ] ++ map mkCmdHidden [ -- hidden commands+ ("all-types", keepGoing' allTypesCmd),+ ("complete", keepGoing completeCmd),+ ("loc-at", keepGoing' locAtCmd),+ ("type-at", keepGoing' typeAtCmd),+ ("uses", keepGoing' usesCmd)+ ]+ where+ mkCmd (n,a,c) = Command { cmdName = n+ , cmdAction = a+ , cmdHidden = False+ , cmdCompletionFunc = c+ }++ mkCmdHidden (n,a) = Command { cmdName = n+ , cmdAction = a+ , cmdHidden = True+ , cmdCompletionFunc = noCompletion+ }++-- We initialize readline (in the interactiveUI function) to use+-- word_break_chars as the default set of completion word break characters.+-- This can be overridden for a particular command (for example, filename+-- expansion shouldn't consider '/' to be a word break) by setting the third+-- entry in the Command tuple above.+--+-- NOTE: in order for us to override the default correctly, any custom entry+-- must be a SUBSET of word_break_chars.+word_break_chars :: String+word_break_chars = spaces ++ specials ++ symbols++symbols, specials, spaces :: String+symbols = "!#$%&*+/<=>?@\\^|-~"+specials = "(),;[]`{}"+spaces = " \t\n"++flagWordBreakChars :: String+flagWordBreakChars = " \t\n"+++keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)+keepGoing a str = keepGoing' (lift . a) str++keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool+keepGoing' a str = a str >> return False++keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)+keepGoingPaths a str+ = do case toArgs str of+ Left err -> liftIO $ hPutStrLn stderr err+ Right args -> a args+ return False++defShortHelpText :: String+defShortHelpText = "use :? for help.\n"++defFullHelpText :: String+defFullHelpText =+ " Commands available from the prompt:\n" +++ "\n" +++ " <statement> evaluate/run <statement>\n" +++ " : repeat last command\n" +++ " :{\\n ..lines.. \\n:}\\n multiline command\n" +++ " :add [*]<module> ... add module(s) to the current target set\n" +++ " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" +++ " (!: more details; *: all top-level names)\n" +++ " :cd <dir> change directory to <dir>\n" +++ " :cmd <expr> run the commands returned by <expr>::IO String\n" +++ " :complete <dom> [<rng>] <s> list completions for partial input string\n" +++ " :ctags[!] [<file>] create tags file <file> for Vi (default: \"tags\")\n" +++ " (!: use regex instead of line number)\n" +++ " :def <cmd> <expr> define command :<cmd> (later defined command has\n" +++ " precedence, ::<cmd> is always a builtin command)\n" +++ " :edit <file> edit file\n" +++ " :edit edit last module\n" +++ " :etags [<file>] create tags file <file> for Emacs (default: \"TAGS\")\n" +++ " :help, :? display this list of commands\n" +++ " :info[!] [<name> ...] display information about the given names\n" +++ " (!: do not filter instances)\n" +++ " :issafe [<mod>] display safe haskell information of module <mod>\n" +++ " :kind[!] <type> show the kind of <type>\n" +++ " (!: also print the normalised type)\n" +++ " :load[!] [*]<module> ... load module(s) and their dependents\n" +++ " (!: defer type errors)\n" +++ " :main [<arguments> ...] run the main function with the given arguments\n" +++ " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" +++ " :quit exit GHCi\n" +++ " :reload[!] reload the current module set\n" +++ " (!: defer type errors)\n" +++ " :run function [<arguments> ...] run the function with the given arguments\n" +++ " :script <file> run the script <file>\n" +++ " :type <expr> show the type of <expr>\n" +++ " :type +d <expr> show the type of <expr>, defaulting type variables\n" +++ " :type +v <expr> show the type of <expr>, with its specified tyvars\n" +++ " :undef <cmd> undefine user-defined command :<cmd>\n" +++ " :!<command> run the shell command <command>\n" +++ " :vhdl synthesize currently loaded module to vhdl\n" +++ " :vhdl [<module>] synthesize specified modules/files to vhdl\n" +++ " :verilog synthesize currently loaded module to verilog\n" +++ " :verilog [<module>] synthesize specified modules/files to verilog\n" +++ " :systemverilog synthesize currently loaded module to systemverilog\n" +++ " :systemverilog [<module>] synthesize specified modules/files to systemverilog\n" +++ "\n" +++ " -- Commands for debugging:\n" +++ "\n" +++ " :abandon at a breakpoint, abandon current computation\n" +++ " :back [<n>] go back in the history N steps (after :trace)\n" +++ " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" +++ " :break <name> set a breakpoint on the specified function\n" +++ " :continue resume after a breakpoint\n" +++ " :delete <number> delete the specified breakpoint\n" +++ " :delete * delete all breakpoints\n" +++ " :force <expr> print <expr>, forcing unevaluated parts\n" +++ " :forward [<n>] go forward in the history N step s(after :back)\n" +++ " :history [<n>] after :trace, show the execution history\n" +++ " :list show the source code around current breakpoint\n" +++ " :list <identifier> show the source code for <identifier>\n" +++ " :list [<module>] <line> show the source code around line number <line>\n" +++ " :print [<name> ...] show a value without forcing its computation\n" +++ " :sprint [<name> ...] simplified version of :print\n" +++ " :step single-step after stopping at a breakpoint\n"+++ " :step <expr> single-step into <expr>\n"+++ " :steplocal single-step within the current top-level binding\n"+++ " :stepmodule single-step restricted to the current module\n"+++ " :trace trace after stopping at a breakpoint\n"+++ " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++++ "\n" +++ " -- Commands for changing settings:\n" +++ "\n" +++ " :set <option> ... set options\n" +++ " :seti <option> ... set options for interactive evaluation only\n" +++ " :set args <arg> ... set the arguments returned by System.getArgs\n" +++ " :set prog <progname> set the value returned by System.getProgName\n" +++ " :set prompt <prompt> set the prompt used in GHCi\n" +++ " :set prompt-cont <prompt> set the continuation prompt used in GHCi\n" +++ " :set prompt-function <expr> set the function to handle the prompt\n" +++ " :set prompt-cont-function <expr>" +++ "set the function to handle the continuation prompt\n" +++ " :set editor <cmd> set the command used for :edit\n" +++ " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" +++ " :unset <option> ... unset options\n" +++ "\n" +++ " Options for ':set' and ':unset':\n" +++ "\n" +++ " +m allow multiline commands\n" +++ " +r revert top-level expressions after each evaluation\n" +++ " +s print timing/memory stats after each evaluation\n" +++ " +t print type after evaluation\n" +++ " +c collect type/location info after loading modules\n" +++ " -<flags> most GHC command line flags can also be set here\n" +++ " (eg. -v2, -XFlexibleInstances, etc.)\n" +++ " for GHCi-specific flags, see User's Guide,\n"+++ " Flag reference, Interactive-mode options\n" +++ "\n" +++ " -- Commands for displaying information:\n" +++ "\n" +++ " :show bindings show the current bindings made at the prompt\n" +++ " :show breaks show the active breakpoints\n" +++ " :show context show the breakpoint context\n" +++ " :show imports show the current imports\n" +++ " :show linker show current linker state\n" +++ " :show modules show the currently loaded modules\n" +++ " :show packages show the currently active package flags\n" +++ " :show paths show the currently active search paths\n" +++ " :show language show the currently active language flags\n" +++ " :show <setting> show value of <setting>, which is one of\n" +++ " [args, prog, editor, stop]\n" +++ " :showi language show language flags for interactive evaluation\n" +++ "\n"++findEditor :: IO String+findEditor = do+ getEnv "EDITOR"+ `catchIO` \_ -> do+#if defined(mingw32_HOST_OS)+ win <- System.Win32.getWindowsDirectory+ return (win </> "notepad.exe")+#else+ return ""+#endif++default_progname, default_stop :: String+default_progname = "<interactive>"+default_stop = ""++default_prompt, default_prompt_cont :: PromptFunction+default_prompt = generatePromptFunctionFromString "%s> "+default_prompt_cont = generatePromptFunctionFromString "%s| "++default_args :: [String]+default_args = []++interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]+ -> Ghc ()+interactiveUI config srcs maybe_exprs = do+ -- HACK! If we happen to get into an infinite loop (eg the user+ -- types 'let x=x in x' at the prompt), then the thread will block+ -- on a blackhole, and become unreachable during GC. The GC will+ -- detect that it is unreachable and send it the NonTermination+ -- exception. However, since the thread is unreachable, everything+ -- it refers to might be finalized, including the standard Handles.+ -- This sounds like a bug, but we don't have a good solution right+ -- now.+ _ <- liftIO $ newStablePtr stdin+ _ <- liftIO $ newStablePtr stdout+ _ <- liftIO $ newStablePtr stderr++ -- Initialise buffering for the *interpreted* I/O system+ (nobuffering, flush) <- initInterpBuffering++ -- The initial set of DynFlags used for interactive evaluation is the same+ -- as the global DynFlags, plus -XExtendedDefaultRules and+ -- -XNoMonomorphismRestriction.+ dflags <- getDynFlags+ let dflags' = (`xopt_set` LangExt.ExtendedDefaultRules)+ . (`xopt_unset` LangExt.MonomorphismRestriction)+ $ dflags+ GHC.setInteractiveDynFlags dflags'++ lastErrLocationsRef <- liftIO $ newIORef []+ progDynFlags <- GHC.getProgramDynFlags+ _ <- GHC.setProgramDynFlags $+ progDynFlags { log_action = ghciLogAction lastErrLocationsRef }++ when (isNothing maybe_exprs) $ do+ -- Only for GHCi (not runghc and ghc -e):++ -- Turn buffering off for the compiled program's stdout/stderr+ turnOffBuffering_ nobuffering+ -- Turn buffering off for GHCi's stdout+ liftIO $ hFlush stdout+ liftIO $ hSetBuffering stdout NoBuffering+ -- We don't want the cmd line to buffer any input that might be+ -- intended for the program, so unbuffer stdin.+ liftIO $ hSetBuffering stdin NoBuffering+ liftIO $ hSetBuffering stderr NoBuffering+#if defined(mingw32_HOST_OS)+ -- On Unix, stdin will use the locale encoding. The IO library+ -- doesn't do this on Windows (yet), so for now we use UTF-8,+ -- for consistency with GHC 6.10 and to make the tests work.+ liftIO $ hSetEncoding stdin utf8+#endif++ default_editor <- liftIO $ findEditor+ eval_wrapper <- mkEvalWrapper default_progname default_args+ let prelude_import = simpleImportDecl preludeModuleName+ startGHCi (runGHCi srcs maybe_exprs)+ GHCiState{ progname = default_progname,+ args = default_args,+ evalWrapper = eval_wrapper,+ prompt = default_prompt,+ prompt_cont = default_prompt_cont,+ stop = default_stop,+ editor = default_editor,+ options = [],+ -- We initialize line number as 0, not 1, because we use+ -- current line number while reporting errors which is+ -- incremented after reading a line.+ line_number = 0,+ break_ctr = 0,+ breaks = [],+ tickarrays = emptyModuleEnv,+ ghci_commands = availableCommands config,+ ghci_macros = [],+ last_command = Nothing,+ cmdqueue = [],+ remembered_ctx = [],+ transient_ctx = [],+ extra_imports = [],+ prelude_imports = [prelude_import],+ ghc_e = isJust maybe_exprs,+ short_help = shortHelpText config,+ long_help = fullHelpText config,+ lastErrorLocations = lastErrLocationsRef,+ mod_infos = M.empty,+ flushStdHandles = flush,+ noBuffering = nobuffering+ }++ return ()++resetLastErrorLocations :: GHCi ()+resetLastErrorLocations = do+ st <- getGHCiState+ liftIO $ writeIORef (lastErrorLocations st) []++ghciLogAction :: IORef [(FastString, Int)] -> LogAction+ghciLogAction lastErrLocations dflags flag severity srcSpan style msg = do+ defaultLogAction dflags flag severity srcSpan style msg+ case severity of+ SevError -> case srcSpan of+ RealSrcSpan rsp -> modifyIORef lastErrLocations+ (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])+ _ -> return ()+ _ -> return ()++withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a+withGhcAppData right left = do+ either_dir <- tryIO (getAppUserDataDirectory "clash")+ case either_dir of+ Right dir ->+ do createDirectoryIfMissing False dir `catchIO` \_ -> return ()+ right dir+ _ -> left++runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()+runGHCi paths maybe_exprs = do+ dflags <- getDynFlags+ let+ ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags++ current_dir = return (Just ".clashi")++ app_user_dir = liftIO $ withGhcAppData+ (\dir -> return (Just (dir </> "clashi.conf")))+ (return Nothing)++ home_dir = do+ either_dir <- liftIO $ tryIO (getEnv "HOME")+ case either_dir of+ Right home -> return (Just (home </> ".clashi"))+ _ -> return Nothing++ canonicalizePath' :: FilePath -> IO (Maybe FilePath)+ canonicalizePath' fp = liftM Just (canonicalizePath fp)+ `catchIO` \_ -> return Nothing++ sourceConfigFile :: FilePath -> GHCi ()+ sourceConfigFile file = do+ exists <- liftIO $ doesFileExist file+ when exists $ do+ either_hdl <- liftIO $ tryIO (openFile file ReadMode)+ case either_hdl of+ Left _e -> return ()+ -- NOTE: this assumes that runInputT won't affect the terminal;+ -- can we assume this will always be the case?+ -- This would be a good place for runFileInputT.+ Right hdl ->+ do runInputTWithPrefs defaultPrefs defaultSettings $+ runCommands $ fileLoop hdl+ liftIO (hClose hdl `catchIO` \_ -> return ())+ -- Don't print a message if this is really ghc -e (#11478).+ -- Also, let the user silence the message with -v0+ -- (the default verbosity in GHCi is 1).+ when (isNothing maybe_exprs && verbosity dflags > 0) $+ liftIO $ putStrLn ("Loaded Clashi configuration from " ++ file)++ --++ setGHCContextFromGHCiState++ dot_cfgs <- if ignore_dot_ghci then return [] else do+ dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]+ liftIO $ filterM checkFileAndDirPerms dot_files+ mdot_cfgs <- liftIO $ mapM canonicalizePath' dot_cfgs++ let arg_cfgs = reverse $ ghciScripts dflags+ -- -ghci-script are collected in reverse order+ -- We don't require that a script explicitly added by -ghci-script+ -- is owned by the current user. (#6017)+ mapM_ sourceConfigFile $ nub $ (catMaybes mdot_cfgs) ++ arg_cfgs+ -- nub, because we don't want to read .ghci twice if the CWD is $HOME.++ -- Perform a :load for files given on the GHCi command line+ -- When in -e mode, if the load fails then we want to stop+ -- immediately rather than going on to evaluate the expression.+ when (not (null paths)) $ do+ ok <- ghciHandle (\e -> do showException e; return Failed) $+ -- TODO: this is a hack.+ runInputTWithPrefs defaultPrefs defaultSettings $+ loadModule paths+ when (isJust maybe_exprs && failed ok) $+ liftIO (exitWith (ExitFailure 1))++ installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)++ -- if verbosity is greater than 0, or we are connected to a+ -- terminal, display the prompt in the interactive loop.+ is_tty <- liftIO (hIsTerminalDevice stdin)+ let show_prompt = verbosity dflags > 0 || is_tty++ -- reset line number+ modifyGHCiState $ \st -> st{line_number=0}++ case maybe_exprs of+ Nothing ->+ do+ -- enter the interactive loop+ runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty+ Just exprs -> do+ -- just evaluate the expression we were given+ enqueueCommands exprs+ let hdle e = do st <- getGHCiState+ -- flush the interpreter's stdout/stderr on exit (#3890)+ flushInterpBuffers+ -- Jump through some hoops to get the+ -- current progname in the exception text:+ -- <progname>: <exception>+ liftIO $ withProgName (progname st)+ $ topHandler e+ -- this used to be topHandlerFastExit, see #2228+ runInputTWithPrefs defaultPrefs defaultSettings $ do+ -- make `ghc -e` exit nonzero on invalid input, see Trac #7962+ _ <- runCommands' hdle+ (Just $ hdle (toException $ ExitFailure 1) >> return ())+ (return Nothing)+ return ()++ -- and finally, exit+ liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving Clashi."++runGHCiInput :: InputT GHCi a -> GHCi a+runGHCiInput f = do+ dflags <- getDynFlags+ let ghciHistory = gopt Opt_GhciHistory dflags+ let localGhciHistory = gopt Opt_LocalGhciHistory dflags+ currentDirectory <- liftIO $ getCurrentDirectory++ histFile <- case (ghciHistory, localGhciHistory) of+ (True, True) -> return (Just (currentDirectory </> ".clashi_history"))+ (True, _) -> liftIO $ withGhcAppData+ (\dir -> return (Just (dir </> "clashi_history"))) (return Nothing)+ _ -> return Nothing++ runInputT+ (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})+ f++-- | How to get the next input line from the user+nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)+nextInputLine show_prompt is_tty+ | is_tty = do+ prmpt <- if show_prompt then lift mkPrompt else return ""+ r <- getInputLine prmpt+ incrementLineNo+ return r+ | otherwise = do+ when show_prompt $ lift mkPrompt >>= liftIO . putStr+ fileLoop stdin++-- NOTE: We only read .ghci files if they are owned by the current user,+-- and aren't world writable (files owned by root are ok, see #9324).+-- Otherwise, we could be accidentally running code planted by+-- a malicious third party.++-- Furthermore, We only read ./.ghci if . is owned by the current user+-- and isn't writable by anyone else. I think this is sufficient: we+-- don't need to check .. and ../.. etc. because "." always refers to+-- the same directory while a process is running.++checkFileAndDirPerms :: FilePath -> IO Bool+checkFileAndDirPerms file = do+ file_ok <- checkPerms file+ -- Do not check dir perms when .ghci doesn't exist, otherwise GHCi will+ -- print some confusing and useless warnings in some cases (e.g. in+ -- travis). Note that we can't add a test for this, as all ghci tests should+ -- run with -ignore-dot-ghci, which means we never get here.+ if file_ok then checkPerms (getDirectory file) else return False+ where+ getDirectory f = case takeDirectory f of+ "" -> "."+ d -> d++checkPerms :: FilePath -> IO Bool+#if defined(mingw32_HOST_OS)+checkPerms _ = return True+#else+checkPerms file =+ handleIO (\_ -> return False) $ do+ st <- getFileStatus file+ me <- getRealUserID+ let mode = System.Posix.fileMode st+ ok = (fileOwner st == me || fileOwner st == 0) &&+ groupWriteMode /= mode `intersectFileModes` groupWriteMode &&+ otherWriteMode /= mode `intersectFileModes` otherWriteMode+ unless ok $+ -- #8248: Improving warning to include a possible fix.+ putStrLn $ "*** WARNING: " ++ file +++ " is writable by someone else, IGNORING!" +++ "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"+ return ok+#endif++incrementLineNo :: InputT GHCi ()+incrementLineNo = modifyGHCiState incLineNo+ where+ incLineNo st = st { line_number = line_number st + 1 }++fileLoop :: Handle -> InputT GHCi (Maybe String)+fileLoop hdl = do+ l <- liftIO $ tryIO $ hGetLine hdl+ case l of+ Left e | isEOFError e -> return Nothing+ | -- as we share stdin with the program, the program+ -- might have already closed it, so we might get a+ -- handle-closed exception. We therefore catch that+ -- too.+ isIllegalOperation e -> return Nothing+ | InvalidArgument <- etype -> return Nothing+ | otherwise -> liftIO $ ioError e+ where etype = ioeGetErrorType e+ -- treat InvalidArgument in the same way as EOF:+ -- this can happen if the user closed stdin, or+ -- perhaps did getContents which closes stdin at+ -- EOF.+ Right l' -> do+ incrementLineNo+ return (Just l')++formatCurrentTime :: String -> IO String+formatCurrentTime format =+ getZonedTime >>= return . (formatTime defaultTimeLocale format)++getUserName :: IO String+getUserName = do+#if defined(mingw32_HOST_OS)+ getEnv "USERNAME"+ `catchIO` \e -> do+ putStrLn $ show e+ return ""+#else+ getLoginName+#endif++getInfoForPrompt :: GHCi (SDoc, [String], Int)+getInfoForPrompt = do+ st <- getGHCiState+ imports <- GHC.getContext+ resumes <- GHC.getResumeContext++ context_bit <-+ case resumes of+ [] -> return empty+ r:_ -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (brackets (ppr (GHC.resumeSpan r)) <> space)+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ pan <- GHC.getHistorySpan hist+ return (brackets (ppr (negate ix) <> char ':'+ <+> ppr pan) <> space)++ let+ dots | _:rs <- resumes, not (null rs) = text "... "+ | otherwise = empty++ rev_imports = reverse imports -- rightmost are the most recent++ myIdeclName d | Just m <- ideclAs d = unLoc m+ | otherwise = unLoc (ideclName d)++ modules_names =+ ['*':(moduleNameString m) | IIModule m <- rev_imports] +++ [moduleNameString (myIdeclName d) | IIDecl d <- rev_imports]+ line = 1 + line_number st++ return (dots <> context_bit, modules_names, line)++parseCallEscape :: String -> (String, String)+parseCallEscape s+ | not (all isSpace beforeOpen) = ("", "")+ | null sinceOpen = ("", "")+ | null sinceClosed = ("", "")+ | null cmd = ("", "")+ | otherwise = (cmd, tail sinceClosed)+ where+ (beforeOpen, sinceOpen) = span (/='(') s+ (cmd, sinceClosed) = span (/=')') (tail sinceOpen)++checkPromptStringForErrors :: String -> Maybe String+checkPromptStringForErrors ('%':'c':'a':'l':'l':xs) =+ case parseCallEscape xs of+ ("", "") -> Just ("Incorrect %call syntax. " +++ "Should be %call(a command and arguments).")+ (_, afterClosed) -> checkPromptStringForErrors afterClosed+checkPromptStringForErrors ('%':'%':xs) = checkPromptStringForErrors xs+checkPromptStringForErrors (_:xs) = checkPromptStringForErrors xs+checkPromptStringForErrors "" = Nothing++generatePromptFunctionFromString :: String -> PromptFunction+generatePromptFunctionFromString promptS = \_ _ -> do+ (context, modules_names, line) <- getInfoForPrompt++ let+ processString :: String -> GHCi SDoc+ processString ('%':'s':xs) =+ liftM2 (<>) (return modules_list) (processString xs)+ where+ modules_list = context <> modules_bit+ modules_bit = hsep $ map text modules_names+ processString ('%':'l':xs) =+ liftM2 (<>) (return $ ppr line) (processString xs)+ processString ('%':'d':xs) =+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%a %b %d"+ processString ('%':'t':xs) =+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%H:%M:%S"+ processString ('%':'T':xs) = do+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%I:%M:%S"+ processString ('%':'@':xs) = do+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%I:%M %P"+ processString ('%':'A':xs) = do+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%H:%M"+ processString ('%':'u':xs) =+ liftM2 (<>) (liftM text user_name) (processString xs)+ where+ user_name = liftIO $ getUserName+ processString ('%':'w':xs) =+ liftM2 (<>) (liftM text current_directory) (processString xs)+ where+ current_directory = liftIO $ getCurrentDirectory+ processString ('%':'o':xs) =+ liftM ((text os) <>) (processString xs)+ processString ('%':'a':xs) =+ liftM ((text arch) <>) (processString xs)+ processString ('%':'N':xs) =+ liftM ((text compilerName) <>) (processString xs)+ processString ('%':'V':xs) =+ liftM ((text $ showVersion compilerVersion) <>) (processString xs)+ processString ('%':'c':'a':'l':'l':xs) = do+ respond <- liftIO $ do+ (code, out, err) <-+ readProcessWithExitCode+ (head list_words) (tail list_words) ""+ `catchIO` \e -> return (ExitFailure 1, "", show e)+ case code of+ ExitSuccess -> return out+ _ -> do+ hPutStrLn stderr err+ return ""+ liftM ((text respond) <>) (processString afterClosed)+ where+ (cmd, afterClosed) = parseCallEscape xs+ list_words = words cmd+ processString ('%':'%':xs) =+ liftM ((char '%') <>) (processString xs)+ processString (x:xs) =+ liftM (char x <>) (processString xs)+ processString "" =+ return empty++ processString promptS++mkPrompt :: GHCi String+mkPrompt = do+ st <- getGHCiState+ dflags <- getDynFlags+ (context, modules_names, line) <- getInfoForPrompt++ prompt_string <- (prompt st) modules_names line+ let prompt_doc = context <> prompt_string++ return (showSDoc dflags prompt_doc)++queryQueue :: GHCi (Maybe String)+queryQueue = do+ st <- getGHCiState+ case cmdqueue st of+ [] -> return Nothing+ c:cs -> do setGHCiState st{ cmdqueue = cs }+ return (Just c)++-- Reconfigurable pretty-printing Ticket #5461+installInteractivePrint :: Maybe String -> Bool -> GHCi ()+installInteractivePrint Nothing _ = return ()+installInteractivePrint (Just ipFun) exprmode = do+ ok <- trySuccess $ do+ (name:_) <- GHC.parseName ipFun+ modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name+ in he{hsc_IC = new_ic})+ return Succeeded++ when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))++-- | The main read-eval-print loop+runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()+runCommands gCmd = runCommands' handler Nothing gCmd >> return ()++runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler+ -> Maybe (GHCi ()) -- ^ Source error handler+ -> InputT GHCi (Maybe String)+ -> InputT GHCi (Maybe Bool)+ -- We want to return () here, but have to return (Maybe Bool)+ -- because gmask is not polymorphic enough: we want to use+ -- unmask at two different types.+runCommands' eh sourceErrorHandler gCmd = gmask $ \unmask -> do+ b <- ghandle (\e -> case fromException e of+ Just UserInterrupt -> return $ Just False+ _ -> case fromException e of+ Just ghce ->+ do liftIO (print (ghce :: GhcException))+ return Nothing+ _other ->+ liftIO (Exception.throwIO e))+ (unmask $ runOneCommand eh gCmd)+ case b of+ Nothing -> return Nothing+ Just success -> do+ unless success $ maybe (return ()) lift sourceErrorHandler+ unmask $ runCommands' eh sourceErrorHandler gCmd++-- | Evaluate a single line of user input (either :<command> or Haskell code).+-- A result of Nothing means there was no more input to process.+-- Otherwise the result is Just b where b is True if the command succeeded;+-- this is relevant only to ghc -e, which will exit with status 1+-- if the command was unsuccessful. GHCi will continue in either case.+runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)+ -> InputT GHCi (Maybe Bool)+runOneCommand eh gCmd = do+ -- run a previously queued command if there is one, otherwise get new+ -- input from user+ mb_cmd0 <- noSpace (lift queryQueue)+ mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0+ case mb_cmd1 of+ Nothing -> return Nothing+ Just c -> ghciHandle (\e -> lift $ eh e >>= return . Just) $+ handleSourceError printErrorAndFail+ (doCommand c)+ -- source error's are handled by runStmt+ -- is the handler necessary here?+ where+ printErrorAndFail err = do+ GHC.printException err+ return $ Just False -- Exit ghc -e, but not GHCi++ noSpace q = q >>= maybe (return Nothing)+ (\c -> case removeSpaces c of+ "" -> noSpace q+ ":{" -> multiLineCmd q+ _ -> return (Just c) )+ multiLineCmd q = do+ st <- getGHCiState+ let p = prompt st+ setGHCiState st{ prompt = prompt_cont st }+ mb_cmd <- collectCommand q "" `GHC.gfinally`+ modifyGHCiState (\st' -> st' { prompt = p })+ return mb_cmd+ -- we can't use removeSpaces for the sublines here, so+ -- multiline commands are somewhat more brittle against+ -- fileformat errors (such as \r in dos input on unix),+ -- we get rid of any extra spaces for the ":}" test;+ -- we also avoid silent failure if ":}" is not found;+ -- and since there is no (?) valid occurrence of \r (as+ -- opposed to its String representation, "\r") inside a+ -- ghci command, we replace any such with ' ' (argh:-(+ collectCommand q c = q >>=+ maybe (liftIO (ioError collectError))+ (\l->if removeSpaces l == ":}"+ then return (Just c)+ else collectCommand q (c ++ "\n" ++ map normSpace l))+ where normSpace '\r' = ' '+ normSpace x = x+ -- SDM (2007-11-07): is userError the one to use here?+ collectError = userError "unterminated multiline command :{ .. :}"++ -- | Handle a line of input+ doCommand :: String -> InputT GHCi (Maybe Bool)++ -- command+ doCommand stmt | (':' : cmd) <- removeSpaces stmt = do+ result <- specialCommand cmd+ case result of+ True -> return Nothing+ _ -> return $ Just True++ -- haskell+ doCommand stmt = do+ -- if 'stmt' was entered via ':{' it will contain '\n's+ let stmt_nl_cnt = length [ () | '\n' <- stmt ]+ ml <- lift $ isOptionSet Multiline+ if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input+ then do+ fst_line_num <- line_number <$> getGHCiState+ mb_stmt <- checkInputForLayout stmt gCmd+ case mb_stmt of+ Nothing -> return $ Just True+ Just ml_stmt -> do+ -- temporarily compensate line-number for multi-line input+ result <- timeIt runAllocs $ lift $+ runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion+ return $ Just (runSuccess result)+ else do -- single line input and :{ - multiline input+ last_line_num <- line_number <$> getGHCiState+ -- reconstruct first line num from last line num and stmt+ let fst_line_num | stmt_nl_cnt > 0 = last_line_num - (stmt_nl_cnt2 + 1)+ | otherwise = last_line_num -- single line input+ stmt_nl_cnt2 = length [ () | '\n' <- stmt' ]+ stmt' = dropLeadingWhiteLines stmt -- runStmt doesn't like leading empty lines+ -- temporarily compensate line-number for multi-line input+ result <- timeIt runAllocs $ lift $+ runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion+ return $ Just (runSuccess result)++ -- runStmt wrapper for temporarily overridden line-number+ runStmtWithLineNum :: Int -> String -> SingleStep+ -> GHCi (Maybe GHC.ExecResult)+ runStmtWithLineNum lnum stmt step = do+ st0 <- getGHCiState+ setGHCiState st0 { line_number = lnum }+ result <- runStmt stmt step+ -- restore original line_number+ getGHCiState >>= \st -> setGHCiState st { line_number = line_number st0 }+ return result++ -- note: this is subtly different from 'unlines . dropWhile (all isSpace) . lines'+ dropLeadingWhiteLines s | (l0,'\n':r) <- break (=='\n') s+ , all isSpace l0 = dropLeadingWhiteLines r+ | otherwise = s+++-- #4316+-- lex the input. If there is an unclosed layout context, request input+checkInputForLayout :: String -> InputT GHCi (Maybe String)+ -> InputT GHCi (Maybe String)+checkInputForLayout stmt getStmt = do+ dflags' <- getDynFlags+ let dflags = xopt_set dflags' LangExt.AlternativeLayoutRule+ st0 <- getGHCiState+ let buf' = stringToStringBuffer stmt+ loc = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1+ pstate = Lexer.mkPState dflags buf' loc+ case Lexer.unP goToEnd pstate of+ (Lexer.POk _ False) -> return $ Just stmt+ _other -> do+ st1 <- getGHCiState+ let p = prompt st1+ setGHCiState st1{ prompt = prompt_cont st1 }+ mb_stmt <- ghciHandle (\ex -> case fromException ex of+ Just UserInterrupt -> return Nothing+ _ -> case fromException ex of+ Just ghce ->+ do liftIO (print (ghce :: GhcException))+ return Nothing+ _other -> liftIO (Exception.throwIO ex))+ getStmt+ modifyGHCiState (\st' -> st' { prompt = p })+ -- the recursive call does not recycle parser state+ -- as we use a new string buffer+ case mb_stmt of+ Nothing -> return Nothing+ Just str -> if str == ""+ then return $ Just stmt+ else do+ checkInputForLayout (stmt++"\n"++str) getStmt+ where goToEnd = do+ eof <- Lexer.nextIsEOF+ if eof+ then Lexer.activeContext+ else Lexer.lexer False return >> goToEnd++enqueueCommands :: [String] -> GHCi ()+enqueueCommands cmds = do+ -- make sure we force any exceptions in the commands while we're+ -- still inside the exception handler, otherwise bad things will+ -- happen (see #10501)+ cmds `deepseq` return ()+ modifyGHCiState $ \st -> st{ cmdqueue = cmds ++ cmdqueue st }++-- | Entry point to execute some haskell code from user.+-- The return value True indicates success, as in `runOneCommand`.+runStmt :: String -> SingleStep -> GHCi (Maybe GHC.ExecResult)+runStmt stmt step = do+ dflags <- GHC.getInteractiveDynFlags+ if | GHC.isStmt dflags stmt -> run_stmt+ | GHC.isImport dflags stmt -> run_import+ -- Every import declaration should be handled by `run_import`. As GHCi+ -- in general only accepts one command at a time, we simply throw an+ -- exception when the input contains multiple commands of which at least+ -- one is an import command (see #10663).+ | GHC.hasImport dflags stmt -> throwGhcException+ (CmdLineError "error: expecting a single import declaration")+ -- Note: `GHC.isDecl` returns False on input like+ -- `data Infix a b = a :@: b; infixl 4 :@:`+ -- and should therefore not be used here.+ | otherwise -> run_decl++ where+ run_import = do+ addImportToContext stmt+ return (Just (GHC.ExecComplete (Right []) 0))++ run_decl =+ do _ <- liftIO $ tryIO $ hFlushAll stdin+ m_result <- GhciMonad.runDecls stmt+ case m_result of+ Nothing -> return Nothing+ Just result ->+ Just <$> afterRunStmt (const True)+ (GHC.ExecComplete (Right result) 0)++ run_stmt =+ do -- In the new IO library, read handles buffer data even if the Handle+ -- is set to NoBuffering. This causes problems for GHCi where there+ -- are really two stdin Handles. So we flush any bufferred data in+ -- GHCi's stdin Handle here (only relevant if stdin is attached to+ -- a file, otherwise the read buffer can't be flushed).+ _ <- liftIO $ tryIO $ hFlushAll stdin+ m_result <- GhciMonad.runStmt stmt step+ case m_result of+ Nothing -> return Nothing+ Just result -> Just <$> afterRunStmt (const True) result++-- | Clean up the GHCi environment after a statement has run+afterRunStmt :: (SrcSpan -> Bool) -> GHC.ExecResult -> GHCi GHC.ExecResult+afterRunStmt step_here run_result = do+ resumes <- GHC.getResumeContext+ case run_result of+ GHC.ExecComplete{..} ->+ case execResult of+ Left ex -> liftIO $ Exception.throwIO ex+ Right names -> do+ show_types <- isOptionSet ShowType+ when show_types $ printTypeOfNames names+ GHC.ExecBreak names mb_info+ | isNothing mb_info ||+ step_here (GHC.resumeSpan $ head resumes) -> do+ mb_id_loc <- toBreakIdAndLocation mb_info+ let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc+ if (null bCmd)+ then printStoppedAtBreakInfo (head resumes) names+ else enqueueCommands [bCmd]+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]+ return ()+ | otherwise -> resume step_here GHC.SingleStep >>=+ afterRunStmt step_here >> return ()++ flushInterpBuffers+ withSignalHandlers $ do+ b <- isOptionSet RevertCAFs+ when b revertCAFs++ return run_result++runSuccess :: Maybe GHC.ExecResult -> Bool+runSuccess run_result+ | Just (GHC.ExecComplete { execResult = Right _ }) <- run_result = True+ | otherwise = False++runAllocs :: Maybe GHC.ExecResult -> Maybe Integer+runAllocs m = do+ res <- m+ case res of+ GHC.ExecComplete{..} -> Just (fromIntegral execAllocation)+ _ -> Nothing++toBreakIdAndLocation ::+ Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))+toBreakIdAndLocation Nothing = return Nothing+toBreakIdAndLocation (Just inf) = do+ let md = GHC.breakInfo_module inf+ nm = GHC.breakInfo_number inf+ st <- getGHCiState+ return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,+ breakModule loc == md,+ breakTick loc == nm ]++printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()+printStoppedAtBreakInfo res names = do+ printForUser $ pprStopped res+ -- printTypeOfNames session names+ let namesSorted = sortBy compareNames names+ tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted+ docs <- mapM pprTypeAndContents [i | AnId i <- tythings]+ printForUserPartWay $ vcat docs++printTypeOfNames :: [Name] -> GHCi ()+printTypeOfNames names+ = mapM_ (printTypeOfName ) $ sortBy compareNames names++compareNames :: Name -> Name -> Ordering+n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2+ where compareWith n = (getOccString n, getSrcSpan n)++printTypeOfName :: Name -> GHCi ()+printTypeOfName n+ = do maybe_tything <- GHC.lookupName n+ case maybe_tything of+ Nothing -> return ()+ Just thing -> printTyThing thing+++data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand++-- | Entry point for execution a ':<command>' input from user+specialCommand :: String -> InputT GHCi Bool+specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)+specialCommand str = do+ let (cmd,rest) = break isSpace str+ maybe_cmd <- lift $ lookupCommand cmd+ htxt <- short_help <$> getGHCiState+ case maybe_cmd of+ GotCommand cmd -> (cmdAction cmd) (dropWhile isSpace rest)+ BadCommand ->+ do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"+ ++ htxt)+ return False+ NoLastCommand ->+ do liftIO $ hPutStr stdout ("there is no last command to perform\n"+ ++ htxt)+ return False++shellEscape :: String -> GHCi Bool+shellEscape str = liftIO (system str >> return False)++lookupCommand :: String -> GHCi (MaybeCommand)+lookupCommand "" = do+ st <- getGHCiState+ case last_command st of+ Just c -> return $ GotCommand c+ Nothing -> return NoLastCommand+lookupCommand str = do+ mc <- lookupCommand' str+ modifyGHCiState (\st -> st { last_command = mc })+ return $ case mc of+ Just c -> GotCommand c+ Nothing -> BadCommand++lookupCommand' :: String -> GHCi (Maybe Command)+lookupCommand' ":" = return Nothing+lookupCommand' str' = do+ macros <- ghci_macros <$> getGHCiState+ ghci_cmds <- ghci_commands <$> getGHCiState++ let ghci_cmds_nohide = filter (not . cmdHidden) ghci_cmds++ let (str, xcmds) = case str' of+ ':' : rest -> (rest, []) -- "::" selects a builtin command+ _ -> (str', macros) -- otherwise include macros in lookup++ lookupExact s = find $ (s ==) . cmdName+ lookupPrefix s = find $ (s `isPrefixOf`) . cmdName++ -- hidden commands can only be matched exact+ builtinPfxMatch = lookupPrefix str ghci_cmds_nohide++ -- first, look for exact match (while preferring macros); then, look+ -- for first prefix match (preferring builtins), *unless* a macro+ -- overrides the builtin; see #8305 for motivation+ return $ lookupExact str xcmds <|>+ lookupExact str ghci_cmds <|>+ (builtinPfxMatch >>= \c -> lookupExact (cmdName c) xcmds) <|>+ builtinPfxMatch <|>+ lookupPrefix str xcmds++getCurrentBreakSpan :: GHCi (Maybe SrcSpan)+getCurrentBreakSpan = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (Just (GHC.resumeSpan r))+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ pan <- GHC.getHistorySpan hist+ return (Just pan)++getCallStackAtCurrentBreakpoint :: GHCi (Maybe [String])+getCallStackAtCurrentBreakpoint = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ hsc_env <- GHC.getSession+ Just <$> liftIO (costCentreStackInfo hsc_env (GHC.resumeCCS r))++getCurrentBreakModule :: GHCi (Maybe Module)+getCurrentBreakModule = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ return $ Just $ GHC.getHistoryModule hist++-----------------------------------------------------------------------------+--+-- Commands+--+-----------------------------------------------------------------------------++noArgs :: GHCi () -> String -> GHCi ()+noArgs m "" = m+noArgs _ _ = liftIO $ putStrLn "This command takes no arguments"++withSandboxOnly :: String -> GHCi () -> GHCi ()+withSandboxOnly cmd this = do+ dflags <- getDynFlags+ if not (gopt Opt_GhciSandbox dflags)+ then printForUser (text cmd <+>+ ptext (sLit "is not supported with -fno-ghci-sandbox"))+ else this++-----------------------------------------------------------------------------+-- :help++help :: String -> GHCi ()+help _ = do+ txt <- long_help `fmap` getGHCiState+ liftIO $ putStr txt++-----------------------------------------------------------------------------+-- :info++info :: Bool -> String -> InputT GHCi ()+info _ "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'")+info allInfo s = handleSourceError GHC.printException $ do+ unqual <- GHC.getPrintUnqual+ dflags <- getDynFlags+ sdocs <- mapM (infoThing allInfo) (words s)+ mapM_ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs++infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc+infoThing allInfo str = do+ names <- GHC.parseName str+ mb_stuffs <- mapM (GHC.getInfo allInfo) names+ let filtered = filterOutChildren (\(t,_f,_ci,_fi) -> t) (catMaybes mb_stuffs)+ return $ vcat (intersperse (text "") $ map pprInfo filtered)++ -- Filter out names whose parent is also there Good+ -- example is '[]', which is both a type and data+ -- constructor in the same type+filterOutChildren :: (a -> TyThing) -> [a] -> [a]+filterOutChildren get_thing xs+ = filterOut has_parent xs+ where+ all_names = mkNameSet (map (getName . get_thing) xs)+ has_parent x = case tyThingParent_maybe (get_thing x) of+ Just p -> getName p `elemNameSet` all_names+ Nothing -> False++pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc+pprInfo (thing, fixity, cls_insts, fam_insts)+ = pprTyThingInContextLoc thing+ $$ show_fixity+ $$ vcat (map GHC.pprInstance cls_insts)+ $$ vcat (map GHC.pprFamInst fam_insts)+ where+ show_fixity+ | fixity == GHC.defaultFixity = empty+ | otherwise = ppr fixity <+> pprInfixName (GHC.getName thing)++-----------------------------------------------------------------------------+-- :main++runMain :: String -> GHCi ()+runMain s = case toArgs s of+ Left err -> liftIO (hPutStrLn stderr err)+ Right args ->+ do dflags <- getDynFlags+ let main = fromMaybe "main" (mainFunIs dflags)+ -- Wrap the main function in 'void' to discard its value instead+ -- of printing it (#9086). See Haskell 2010 report Chapter 5.+ doWithArgs args $ "Control.Monad.void (" ++ main ++ ")"++-----------------------------------------------------------------------------+-- :run++runRun :: String -> GHCi ()+runRun s = case toCmdArgs s of+ Left err -> liftIO (hPutStrLn stderr err)+ Right (cmd, args) -> doWithArgs args cmd++doWithArgs :: [String] -> String -> GHCi ()+doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " +++ show args ++ " (" ++ cmd ++ ")"]++-----------------------------------------------------------------------------+-- :cd++changeDirectory :: String -> InputT GHCi ()+changeDirectory "" = do+ -- :cd on its own changes to the user's home directory+ either_dir <- liftIO $ tryIO getHomeDirectory+ case either_dir of+ Left _e -> return ()+ Right dir -> changeDirectory dir+changeDirectory dir = do+ graph <- GHC.getModuleGraph+ when (not (null graph)) $+ liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."+ GHC.setTargets []+ _ <- GHC.load LoadAllTargets+ lift $ setContextAfterLoad False []+ GHC.workingDirectoryChanged+ dir' <- expandPath dir+ liftIO $ setCurrentDirectory dir'+ dflags <- getDynFlags+ -- With -fexternal-interpreter, we have to change the directory of the subprocess too.+ -- (this gives consistent behavior with and without -fexternal-interpreter)+ when (gopt Opt_ExternalInterpreter dflags) $+ lift $ enqueueCommands ["System.Directory.setCurrentDirectory " ++ show dir']++trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag+trySuccess act =+ handleSourceError (\e -> do GHC.printException e+ return Failed) $ do+ act++-----------------------------------------------------------------------------+-- :edit++editFile :: String -> InputT GHCi ()+editFile str =+ do file <- if null str then lift chooseEditFile else expandPath str+ st <- getGHCiState+ errs <- liftIO $ readIORef $ lastErrorLocations st+ let cmd = editor st+ when (null cmd)+ $ throwGhcException (CmdLineError "editor not set, use :set editor")+ lineOpt <- liftIO $ do+ let sameFile p1 p2 = liftA2 (==) (canonicalizePath p1) (canonicalizePath p2)+ `catchIO` (\_ -> return False)++ curFileErrs <- filterM (\(f, _) -> unpackFS f `sameFile` file) errs+ return $ case curFileErrs of+ (_, line):_ -> " +" ++ show line+ _ -> ""+ let cmdArgs = ' ':(file ++ lineOpt)+ code <- liftIO $ system (cmd ++ cmdArgs)++ when (code == ExitSuccess)+ $ reloadModule ""++-- The user didn't specify a file so we pick one for them.+-- Our strategy is to pick the first module that failed to load,+-- or otherwise the first target.+--+-- XXX: Can we figure out what happened if the depndecy analysis fails+-- (e.g., because the porgrammeer mistyped the name of a module)?+-- XXX: Can we figure out the location of an error to pass to the editor?+-- XXX: if we could figure out the list of errors that occured during the+-- last load/reaload, then we could start the editor focused on the first+-- of those.+chooseEditFile :: GHCi String+chooseEditFile =+ do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x++ graph <- GHC.getModuleGraph+ failed_graph <- filterM hasFailed graph+ let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing+ pick xs = case xs of+ x : _ -> GHC.ml_hs_file (GHC.ms_location x)+ _ -> Nothing++ case pick (order failed_graph) of+ Just file -> return file+ Nothing ->+ do targets <- GHC.getTargets+ case msum (map fromTarget targets) of+ Just file -> return file+ Nothing -> throwGhcException (CmdLineError "No files to edit.")++ where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f+ fromTarget _ = Nothing -- when would we get a module target?+++-----------------------------------------------------------------------------+-- :def++defineMacro :: Bool{-overwrite-} -> String -> GHCi ()+defineMacro _ (':':_) =+ liftIO $ putStrLn "macro name cannot start with a colon"+defineMacro overwrite s = do+ let (macro_name, definition) = break isSpace s+ macros <- ghci_macros <$> getGHCiState+ let defined = map cmdName macros+ if null macro_name+ then if null defined+ then liftIO $ putStrLn "no macros defined"+ else liftIO $ putStr ("the following macros are defined:\n" +++ unlines defined)+ else do+ if (not overwrite && macro_name `elem` defined)+ then throwGhcException (CmdLineError+ ("macro '" ++ macro_name ++ "' is already defined"))+ else do++ -- compile the expression+ handleSourceError GHC.printException $ do+ step <- getGhciStepIO+ expr <- GHC.parseExpr definition+ -- > ghciStepIO . definition :: String -> IO String+ let stringTy = nlHsTyVar stringTy_RDR+ ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy+ body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)+ `mkHsApp` (nlHsPar expr)+ tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM)+ new_expr = L (getLoc expr) $ ExprWithTySig body tySig+ hv <- GHC.compileParsedExprRemote new_expr++ let newCmd = Command { cmdName = macro_name+ , cmdAction = lift . runMacro hv+ , cmdHidden = False+ , cmdCompletionFunc = noCompletion+ }++ -- later defined macros have precedence+ modifyGHCiState $ \s ->+ let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]+ in s { ghci_macros = newCmd : filtered }++runMacro :: GHC.ForeignHValue{-String -> IO String-} -> String -> GHCi Bool+runMacro fun s = do+ hsc_env <- GHC.getSession+ str <- liftIO $ evalStringToIOString hsc_env fun s+ enqueueCommands (lines str)+ return False+++-----------------------------------------------------------------------------+-- :undef++undefineMacro :: String -> GHCi ()+undefineMacro str = mapM_ undef (words str)+ where undef macro_name = do+ cmds <- ghci_macros <$> getGHCiState+ if (macro_name `notElem` map cmdName cmds)+ then throwGhcException (CmdLineError+ ("macro '" ++ macro_name ++ "' is not defined"))+ else do+ -- This is a tad racy but really, it's a shell+ modifyGHCiState $ \s ->+ s { ghci_macros = filter ((/= macro_name) . cmdName)+ (ghci_macros s) }+++-----------------------------------------------------------------------------+-- :cmd++cmdCmd :: String -> GHCi ()+cmdCmd str = handleSourceError GHC.printException $ do+ step <- getGhciStepIO+ expr <- GHC.parseExpr str+ -- > ghciStepIO str :: IO String+ let new_expr = step `mkHsApp` expr+ hv <- GHC.compileParsedExprRemote new_expr++ hsc_env <- GHC.getSession+ cmds <- liftIO $ evalString hsc_env hv+ enqueueCommands (lines cmds)++-- | Generate a typed ghciStepIO expression+-- @ghciStepIO :: Ty String -> IO String@.+getGhciStepIO :: GHCi (LHsExpr RdrName)+getGhciStepIO = do+ ghciTyConName <- GHC.getGHCiMonad+ let stringTy = nlHsTyVar stringTy_RDR+ ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy+ ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy+ body = nlHsVar (getRdrName ghciStepIoMName)+ tySig = mkLHsSigWcType (ghciM `nlHsFunTy` ioM)+ return $ noLoc $ ExprWithTySig body tySig++-----------------------------------------------------------------------------+-- :check++checkModule :: String -> InputT GHCi ()+checkModule m = do+ let modl = GHC.mkModuleName m+ ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do+ r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl+ dflags <- getDynFlags+ liftIO $ putStrLn $ showSDoc dflags $+ case GHC.moduleInfo r of+ cm | Just scope <- GHC.modInfoTopLevelScope cm ->+ let+ (loc, glob) = ASSERT( all isExternalName scope )+ partition ((== modl) . GHC.moduleName . GHC.nameModule) scope+ in+ (text "global names: " <+> ppr glob) $$+ (text "local names: " <+> ppr loc)+ _ -> empty+ return True+ afterLoad (successIf ok) False+++-----------------------------------------------------------------------------+-- :load, :add, :reload++-- | Sets '-fdefer-type-errors' if 'defer' is true, executes 'load' and unsets+-- '-fdefer-type-errors' again if it has not been set before.+wrapDeferTypeErrors :: InputT GHCi a -> InputT GHCi a+wrapDeferTypeErrors load =+ gbracket+ (do+ -- Force originalFlags to avoid leaking the associated HscEnv+ !originalFlags <- getDynFlags+ void $ GHC.setProgramDynFlags $+ setGeneralFlag' Opt_DeferTypeErrors originalFlags+ return originalFlags)+ (\originalFlags -> void $ GHC.setProgramDynFlags originalFlags)+ (\_ -> load)++loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag+loadModule fs = timeIt (const Nothing) (loadModule' fs)++-- | @:load@ command+loadModule_ :: [FilePath] -> InputT GHCi ()+loadModule_ fs = void $ loadModule (zip fs (repeat Nothing))++loadModuleDefer :: [FilePath] -> InputT GHCi ()+loadModuleDefer = wrapDeferTypeErrors . loadModule_++loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag+loadModule' files = do+ let (filenames, phases) = unzip files+ exp_filenames <- mapM expandPath filenames+ let files' = zip exp_filenames phases+ targets <- mapM (uncurry GHC.guessTarget) files'++ -- NOTE: we used to do the dependency anal first, so that if it+ -- fails we didn't throw away the current set of modules. This would+ -- require some re-working of the GHC interface, so we'll leave it+ -- as a ToDo for now.++ -- unload first+ _ <- GHC.abandonAll+ lift discardActiveBreakPoints+ GHC.setTargets []+ _ <- GHC.load LoadAllTargets++ GHC.setTargets targets+ doLoadAndCollectInfo False LoadAllTargets++-- | @:add@ command+addModule :: [FilePath] -> InputT GHCi ()+addModule files = do+ lift revertCAFs -- always revert CAFs on load/add.+ files' <- mapM expandPath files+ targets <- mapM (\m -> GHC.guessTarget m Nothing) files'+ -- remove old targets with the same id; e.g. for :add *M+ mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]+ mapM_ GHC.addTarget targets+ _ <- doLoadAndCollectInfo False LoadAllTargets+ return ()++-- | @:reload@ command+reloadModule :: String -> InputT GHCi ()+reloadModule m = void $ doLoadAndCollectInfo True loadTargets+ where+ loadTargets | null m = LoadAllTargets+ | otherwise = LoadUpTo (GHC.mkModuleName m)++reloadModuleDefer :: String -> InputT GHCi ()+reloadModuleDefer = wrapDeferTypeErrors . reloadModule++-- | Load/compile targets and (optionally) collect module-info+--+-- This collects the necessary SrcSpan annotated type information (via+-- 'collectInfo') required by the @:all-types@, @:loc-at@, @:type-at@,+-- and @:uses@ commands.+--+-- Meta-info collection is not enabled by default and needs to be+-- enabled explicitly via @:set +c@. The reason is that collecting+-- the type-information for all sub-spans can be quite expensive, and+-- since those commands are designed to be used by editors and+-- tooling, it's useless to collect this data for normal GHCi+-- sessions.+doLoadAndCollectInfo :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag+doLoadAndCollectInfo retain_context howmuch = do+ doCollectInfo <- lift (isOptionSet CollectInfo)++ doLoad retain_context howmuch >>= \case+ Succeeded | doCollectInfo -> do+ loaded <- getModuleGraph >>= filterM GHC.isLoaded . map GHC.ms_mod_name+ v <- mod_infos <$> getGHCiState+ !newInfos <- collectInfo v loaded+ modifyGHCiState (\st -> st { mod_infos = newInfos })+ return Succeeded+ flag -> return flag++doLoad :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag+doLoad retain_context howmuch = do+ -- turn off breakpoints before we load: we can't turn them off later, because+ -- the ModBreaks will have gone away.+ lift discardActiveBreakPoints++ lift resetLastErrorLocations+ -- Enable buffering stdout and stderr as we're compiling. Keeping these+ -- handles unbuffered will just slow the compilation down, especially when+ -- compiling in parallel.+ gbracket (liftIO $ do hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering)+ (\_ ->+ liftIO $ do hSetBuffering stdout NoBuffering+ hSetBuffering stderr NoBuffering) $ \_ -> do+ ok <- trySuccess $ GHC.load howmuch+ afterLoad ok retain_context+ return ok+++afterLoad :: SuccessFlag+ -> Bool -- keep the remembered_ctx, as far as possible (:reload)+ -> InputT GHCi ()+afterLoad ok retain_context = do+ lift revertCAFs -- always revert CAFs on load.+ lift discardTickArrays+ loaded_mods <- getLoadedModules+ modulesLoadedMsg ok loaded_mods+ lift $ setContextAfterLoad retain_context loaded_mods++setContextAfterLoad :: Bool -> [GHC.ModSummary] -> GHCi ()+setContextAfterLoad keep_ctxt [] = do+ setContextKeepingPackageModules keep_ctxt []+setContextAfterLoad keep_ctxt ms = do+ -- load a target if one is available, otherwise load the topmost module.+ targets <- GHC.getTargets+ case [ m | Just m <- map (findTarget ms) targets ] of+ [] ->+ let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in+ load_this (last graph')+ (m:_) ->+ load_this m+ where+ findTarget mds t+ = case filter (`matches` t) mds of+ [] -> Nothing+ (m:_) -> Just m++ summary `matches` Target (TargetModule m) _ _+ = GHC.ms_mod_name summary == m+ summary `matches` Target (TargetFile f _) _ _+ | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'+ _ `matches` _+ = False++ load_this summary | m <- GHC.ms_mod summary = do+ is_interp <- GHC.moduleIsInterpreted m+ dflags <- getDynFlags+ let star_ok = is_interp && not (safeLanguageOn dflags)+ -- We import the module with a * iff+ -- - it is interpreted, and+ -- - -XSafe is off (it doesn't allow *-imports)+ let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)]+ | otherwise = [mkIIDecl (GHC.moduleName m)]+ setContextKeepingPackageModules keep_ctxt new_ctx+++-- | Keep any package modules (except Prelude) when changing the context.+setContextKeepingPackageModules+ :: Bool -- True <=> keep all of remembered_ctx+ -- False <=> just keep package imports+ -> [InteractiveImport] -- new context+ -> GHCi ()++setContextKeepingPackageModules keep_ctx trans_ctx = do++ st <- getGHCiState+ let rem_ctx = remembered_ctx st+ new_rem_ctx <- if keep_ctx then return rem_ctx+ else keepPackageImports rem_ctx+ setGHCiState st{ remembered_ctx = new_rem_ctx,+ transient_ctx = filterSubsumed new_rem_ctx trans_ctx }+ setGHCContextFromGHCiState++-- | Filters a list of 'InteractiveImport', clearing out any home package+-- imports so only imports from external packages are preserved. ('IIModule'+-- counts as a home package import, because we are only able to bring a+-- full top-level into scope when the source is available.)+keepPackageImports :: [InteractiveImport] -> GHCi [InteractiveImport]+keepPackageImports = filterM is_pkg_import+ where+ is_pkg_import :: InteractiveImport -> GHCi Bool+ is_pkg_import (IIModule _) = return False+ is_pkg_import (IIDecl d)+ = do e <- gtry $ GHC.findModule mod_name (fmap sl_fs $ ideclPkgQual d)+ case e :: Either SomeException Module of+ Left _ -> return False+ Right m -> return (not (isHomeModule m))+ where+ mod_name = unLoc (ideclName d)+++modulesLoadedMsg :: SuccessFlag -> [GHC.ModSummary] -> InputT GHCi ()+modulesLoadedMsg ok mods = do+ dflags <- getDynFlags+ unqual <- GHC.getPrintUnqual+ let mod_name mod = do+ is_interpreted <- GHC.moduleIsBootOrNotObjectLinkable mod+ return $ if is_interpreted+ then ppr (GHC.ms_mod mod)+ else ppr (GHC.ms_mod mod)+ <> text " ("+ <> text (normalise $ msObjFilePath mod)+ <> text ")" -- fix #9887+ mod_names <- mapM mod_name mods+ let mod_commas+ | null mods = text "none."+ | otherwise = hsep (punctuate comma mod_names) <> text "."+ status = case ok of+ Failed -> text "Failed"+ Succeeded -> text "Ok"++ msg = status <> text ", modules loaded:" <+> mod_commas++ when (verbosity dflags > 0) $+ liftIO $ putStrLn $ showSDocForUser dflags unqual msg+++-- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors+-- and printing 'throwE' strings to 'stderr'+runExceptGhcMonad :: GHC.GhcMonad m => ExceptT SDoc m () -> m ()+runExceptGhcMonad act = handleSourceError GHC.printException $+ either handleErr pure =<<+ runExceptT act+ where+ handleErr sdoc = do+ dflags <- getDynFlags+ liftIO . hPutStrLn stderr . showSDocForUser dflags alwaysQualify $ sdoc++-- | Inverse of 'runExceptT' for \"pure\" computations+-- (c.f. 'except' for 'Except')+exceptT :: Applicative m => Either e a -> ExceptT e m a+exceptT = ExceptT . pure++makeHDL' :: Clash.Backend.Backend backend+ => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)+ -> IORef ClashOpts+ -> [FilePath]+ -> InputT GHCi ()+makeHDL' backend opts lst = makeHDL backend opts =<< case lst of+ srcs@(_:_) -> return srcs+ [] -> do+ modGraph <- GHC.getModuleGraph+ let sortedGraph = GHC.topSortModuleGraph False modGraph Nothing+ return $ case (reverse sortedGraph) of+ ((AcyclicSCC top) : _) -> maybeToList $ (GHC.ml_hs_file . GHC.ms_location) top+ _ -> []++makeHDL :: GHC.GhcMonad m+ => Clash.Backend.Backend backend+ => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)+ -> IORef ClashOpts+ -> [FilePath]+ -> m ()+makeHDL backend optsRef srcs = do+ dflags <- GHC.getSessionDynFlags+ liftIO $ do startTime <- Clock.getCurrentTime+ opts0 <- readIORef optsRef+ let opts1 = opts0 { opt_color = useColor dflags }+ let iw = opt_intWidth opts1+ fp = opt_floatSupport opts1+ syn = opt_hdlSyn opts1+ color = opt_color opts1+ esc = opt_escapedIds opts1+ frcUdf = opt_forceUndefined opts1+ hdl = Clash.Backend.hdlKind backend'+ -- determine whether `-outputdir` was used+ outputDir = do odir <- objectDir dflags+ hidir <- hiDir dflags+ sdir <- stubDir dflags+ ddir <- dumpDir dflags+ if all (== odir) [hidir,sdir,ddir]+ then Just odir+ else Nothing+ idirs = importPaths dflags+ opts2 = opts1 { opt_hdlDir = maybe outputDir Just (opt_hdlDir opts1)+ , opt_importPaths = idirs}+ backend' = backend iw syn esc frcUdf++ checkMonoLocalBinds dflags+ checkImportDirs opts0 idirs++ primDirs <- Clash.Backend.primDirs backend'++ forM_ srcs $ \src -> do+ -- Generate bindings:+ let dbs = reverse [p | PackageDB (PkgConfFile p) <- packageDBFlags dflags]+ (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs) <-+ generateBindings color primDirs idirs dbs hdl src (Just dflags)+ prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime+ let prepStartDiff = reportTimeDiff prepTime startTime+ putStrLn $ "GHC+Clash: Loading modules cumulatively took " ++ prepStartDiff++ -- Generate HDL:+ Clash.Driver.generateHDL+ (buildCustomReprs reprs)+ bindingsMap+ (Just backend')+ primMap+ tcm+ tupTcm+ (ghcTypeToHWType iw fp)+ reduceConstant+ topEntities+ opts2+ (startTime,prepTime)++makeVHDL :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VHDLState)++makeVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VerilogState)++makeSystemVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> SystemVerilogState)++-----------------------------------------------------------------------------+-- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.++typeOfExpr :: String -> InputT GHCi ()+typeOfExpr str = handleSourceError GHC.printException $ do+ let (mode, expr_str) = case break isSpace str of+ ("+d", rest) -> (GHC.TM_Default, dropWhile isSpace rest)+ ("+v", rest) -> (GHC.TM_NoInst, dropWhile isSpace rest)+ _ -> (GHC.TM_Inst, str)+ ty <- GHC.exprType mode expr_str+ printForUser $ sep [text expr_str, nest 2 (dcolon <+> pprTypeForUser ty)]++-----------------------------------------------------------------------------+-- | @:type-at@ command++typeAtCmd :: String -> InputT GHCi ()+typeAtCmd str = runExceptGhcMonad $ do+ (span',sample) <- exceptT $ parseSpanArg str+ infos <- mod_infos <$> getGHCiState+ (info, ty) <- findType infos span' sample+ lift $ printForUserModInfo (modinfoInfo info)+ (sep [text sample,nest 2 (dcolon <+> ppr ty)])++-----------------------------------------------------------------------------+-- | @:uses@ command++usesCmd :: String -> InputT GHCi ()+usesCmd str = runExceptGhcMonad $ do+ (span',sample) <- exceptT $ parseSpanArg str+ infos <- mod_infos <$> getGHCiState+ uses <- findNameUses infos span' sample+ forM_ uses (liftIO . putStrLn . showSrcSpan)++-----------------------------------------------------------------------------+-- | @:loc-at@ command++locAtCmd :: String -> InputT GHCi ()+locAtCmd str = runExceptGhcMonad $ do+ (span',sample) <- exceptT $ parseSpanArg str+ infos <- mod_infos <$> getGHCiState+ (_,_,sp) <- findLoc infos span' sample+ liftIO . putStrLn . showSrcSpan $ sp++-----------------------------------------------------------------------------+-- | @:all-types@ command++allTypesCmd :: String -> InputT GHCi ()+allTypesCmd _ = runExceptGhcMonad $ do+ infos <- mod_infos <$> getGHCiState+ forM_ (M.elems infos) $ \mi ->+ forM_ (modinfoSpans mi) (lift . printSpan)+ where+ printSpan span'+ | Just ty <- spaninfoType span' = do+ df <- getDynFlags+ let tyInfo = unwords . words $+ showSDocForUser df alwaysQualify (pprTypeForUser ty)+ liftIO . putStrLn $+ showRealSrcSpan (spaninfoSrcSpan span') ++ ": " ++ tyInfo+ | otherwise = return ()++-----------------------------------------------------------------------------+-- Helpers for locAtCmd/typeAtCmd/usesCmd++-- | Parse a span: <module-name/filepath> <sl> <sc> <el> <ec> <string>+parseSpanArg :: String -> Either SDoc (RealSrcSpan,String)+parseSpanArg s = do+ (fp,s0) <- readAsString (skipWs s)+ s0' <- skipWs1 s0+ (sl,s1) <- readAsInt s0'+ s1' <- skipWs1 s1+ (sc,s2) <- readAsInt s1'+ s2' <- skipWs1 s2+ (el,s3) <- readAsInt s2'+ s3' <- skipWs1 s3+ (ec,s4) <- readAsInt s3'++ trailer <- case s4 of+ [] -> Right ""+ _ -> skipWs1 s4++ let fs = mkFastString fp+ span' = mkRealSrcSpan (mkRealSrcLoc fs sl sc)+ (mkRealSrcLoc fs el ec)++ return (span',trailer)+ where+ readAsInt :: String -> Either SDoc (Int,String)+ readAsInt "" = Left "Premature end of string while expecting Int"+ readAsInt s0 = case reads s0 of+ [s_rest] -> Right s_rest+ _ -> Left ("Couldn't read" <+> text (show s0) <+> "as Int")++ readAsString :: String -> Either SDoc (String,String)+ readAsString s0+ | '"':_ <- s0 = case reads s0 of+ [s_rest] -> Right s_rest+ _ -> leftRes+ | s_rest@(_:_,_) <- breakWs s0 = Right s_rest+ | otherwise = leftRes+ where+ leftRes = Left ("Couldn't read" <+> text (show s0) <+> "as String")++ skipWs1 :: String -> Either SDoc String+ skipWs1 (c:cs) | isWs c = Right (skipWs cs)+ skipWs1 s0 = Left ("Expected whitespace in" <+> text (show s0))++ isWs = (`elem` [' ','\t'])+ skipWs = dropWhile isWs+ breakWs = break isWs+++-- | Pretty-print \"real\" 'SrcSpan's as+-- @<filename>:(<line>,<col>)-(<line-end>,<col-end>)@+-- while simply unpacking 'UnhelpfulSpan's+showSrcSpan :: SrcSpan -> String+showSrcSpan (UnhelpfulSpan s) = unpackFS s+showSrcSpan (RealSrcSpan spn) = showRealSrcSpan spn++-- | Variant of 'showSrcSpan' for 'RealSrcSpan's+showRealSrcSpan :: RealSrcSpan -> String+showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc+ , ")-(", show el, ",", show ec, ")"+ ]+ where+ fp = unpackFS (srcSpanFile spn)+ sl = srcSpanStartLine spn+ sc = srcSpanStartCol spn+ el = srcSpanEndLine spn+ ec = srcSpanEndCol spn++-----------------------------------------------------------------------------+-- | @:kind@ command++kindOfType :: Bool -> String -> InputT GHCi ()+kindOfType norm str = handleSourceError GHC.printException $ do+ (ty, kind) <- GHC.typeKind norm str+ printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind+ , ppWhen norm $ equals <+> pprTypeForUser ty ]++-----------------------------------------------------------------------------+-- :quit++quit :: String -> InputT GHCi Bool+quit _ = return True+++-----------------------------------------------------------------------------+-- :script++-- running a script file #1363++scriptCmd :: String -> InputT GHCi ()+scriptCmd ws = do+ case words ws of+ [s] -> runScript s+ _ -> throwGhcException (CmdLineError "syntax: :script <filename>")++runScript :: String -- ^ filename+ -> InputT GHCi ()+runScript filename = do+ filename' <- expandPath filename+ either_script <- liftIO $ tryIO (openFile filename' ReadMode)+ case either_script of+ Left _err -> throwGhcException (CmdLineError $ "IO error: \""++filename++"\" "+ ++(ioeGetErrorString _err))+ Right script -> do+ st <- getGHCiState+ let prog = progname st+ line = line_number st+ setGHCiState st{progname=filename',line_number=0}+ scriptLoop script+ liftIO $ hClose script+ new_st <- getGHCiState+ setGHCiState new_st{progname=prog,line_number=line}+ where scriptLoop script = do+ res <- runOneCommand handler $ fileLoop script+ case res of+ Nothing -> return ()+ Just s -> if s+ then scriptLoop script+ else return ()++-----------------------------------------------------------------------------+-- :issafe++-- Displaying Safe Haskell properties of a module++isSafeCmd :: String -> InputT GHCi ()+isSafeCmd m =+ case words m of+ [s] | looksLikeModuleName s -> do+ md <- lift $ lookupModule s+ isSafeModule md+ [] -> do md <- guessCurrentModule "issafe"+ isSafeModule md+ _ -> throwGhcException (CmdLineError "syntax: :issafe <module>")++isSafeModule :: Module -> InputT GHCi ()+isSafeModule m = do+ mb_mod_info <- GHC.getModuleInfo m+ when (isNothing mb_mod_info)+ (throwGhcException $ CmdLineError $ "unknown module: " ++ mname)++ dflags <- getDynFlags+ let iface = GHC.modInfoIface $ fromJust mb_mod_info+ when (isNothing iface)+ (throwGhcException $ CmdLineError $ "can't load interface file for module: " +++ (GHC.moduleNameString $ GHC.moduleName m))++ (msafe, pkgs) <- GHC.moduleTrustReqs m+ let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface+ pkg = if packageTrusted dflags m then "trusted" else "untrusted"+ (good, bad) = tallyPkgs dflags pkgs++ -- print info to user...+ liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"+ liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")+ when (not $ S.null good)+ (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " +++ (intercalate ", " $ map (showPpr dflags) (S.toList good)))+ case msafe && S.null bad of+ True -> liftIO $ putStrLn $ mname ++ " is trusted!"+ False -> do+ when (not $ null bad)+ (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "+ ++ (intercalate ", " $ map (showPpr dflags) (S.toList bad)))+ liftIO $ putStrLn $ mname ++ " is NOT trusted!"++ where+ mname = GHC.moduleNameString $ GHC.moduleName m++ packageTrusted dflags md+ | thisPackage dflags == moduleUnitId md = True+ | otherwise = trusted $ getPackageDetails dflags (moduleUnitId md)++ tallyPkgs dflags deps | not (packageTrustOn dflags) = (S.empty, S.empty)+ | otherwise = S.partition part deps+ where part pkg = trusted $ getInstalledPackageDetails dflags pkg++-----------------------------------------------------------------------------+-- :browse++-- Browsing a module's contents++browseCmd :: Bool -> String -> InputT GHCi ()+browseCmd bang m =+ case words m of+ ['*':s] | looksLikeModuleName s -> do+ md <- lift $ wantInterpretedModule s+ browseModule bang md False+ [s] | looksLikeModuleName s -> do+ md <- lift $ lookupModule s+ browseModule bang md True+ [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")+ browseModule bang md True+ _ -> throwGhcException (CmdLineError "syntax: :browse <module>")++guessCurrentModule :: String -> InputT GHCi Module+-- Guess which module the user wants to browse. Pick+-- modules that are interpreted first. The most+-- recently-added module occurs last, it seems.+guessCurrentModule cmd+ = do imports <- GHC.getContext+ when (null imports) $ throwGhcException $+ CmdLineError (':' : cmd ++ ": no current module")+ case (head imports) of+ IIModule m -> GHC.findModule m Nothing+ IIDecl d -> GHC.findModule (unLoc (ideclName d))+ (fmap sl_fs $ ideclPkgQual d)++-- without bang, show items in context of their parents and omit children+-- with bang, show class methods and data constructors separately, and+-- indicate import modules, to aid qualifying unqualified names+-- with sorted, sort items alphabetically+browseModule :: Bool -> Module -> Bool -> InputT GHCi ()+browseModule bang modl exports_only = do+ -- :browse reports qualifiers wrt current context+ unqual <- GHC.getPrintUnqual++ mb_mod_info <- GHC.getModuleInfo modl+ case mb_mod_info of+ Nothing -> throwGhcException (CmdLineError ("unknown module: " +++ GHC.moduleNameString (GHC.moduleName modl)))+ Just mod_info -> do+ dflags <- getDynFlags+ let names+ | exports_only = GHC.modInfoExports mod_info+ | otherwise = GHC.modInfoTopLevelScope mod_info+ `orElse` []++ -- sort alphabetically name, but putting locally-defined+ -- identifiers first. We would like to improve this; see #1799.+ sorted_names = loc_sort local ++ occ_sort external+ where+ (local,external) = ASSERT( all isExternalName names )+ partition ((==modl) . nameModule) names+ occ_sort = sortBy (compare `on` nameOccName)+ -- try to sort by src location. If the first name in our list+ -- has a good source location, then they all should.+ loc_sort ns+ | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n)+ = sortBy (compare `on` nameSrcSpan) ns+ | otherwise+ = occ_sort ns++ mb_things <- mapM GHC.lookupName sorted_names+ let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)++ rdr_env <- GHC.getGRE++ let things | bang = catMaybes mb_things+ | otherwise = filtered_things+ pretty | bang = pprTyThing showToHeader+ | otherwise = pprTyThingInContext showToHeader++ labels [] = text "-- not currently imported"+ labels l = text $ intercalate "\n" $ map qualifier l++ qualifier :: Maybe [ModuleName] -> String+ qualifier = maybe "-- defined locally"+ (("-- imported via "++) . intercalate ", "+ . map GHC.moduleNameString)+ importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env++ modNames :: [[Maybe [ModuleName]]]+ modNames = map (importInfo . GHC.getName) things++ -- annotate groups of imports with their import modules+ -- the default ordering is somewhat arbitrary, so we group+ -- by header and sort groups; the names themselves should+ -- really come in order of source appearance.. (trac #1799)+ annotate mts = concatMap (\(m,ts)->labels m:ts)+ $ sortBy cmpQualifiers $ grp mts+ where cmpQualifiers =+ compare `on` (map (fmap (map moduleNameFS)) . fst)+ grp [] = []+ grp mts@((m,_):_) = (m,map snd g) : grp ng+ where (g,ng) = partition ((==m).fst) mts++ let prettyThings, prettyThings' :: [SDoc]+ prettyThings = map pretty things+ prettyThings' | bang = annotate $ zip modNames prettyThings+ | otherwise = prettyThings+ liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings')+ -- ToDo: modInfoInstances currently throws an exception for+ -- package modules. When it works, we can do this:+ -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))+++-----------------------------------------------------------------------------+-- :module++-- Setting the module context. For details on context handling see+-- "remembered_ctx" and "transient_ctx" in GhciMonad.++moduleCmd :: String -> GHCi ()+moduleCmd str+ | all sensible strs = cmd+ | otherwise = throwGhcException (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")+ where+ (cmd, strs) =+ case str of+ '+':stuff -> rest addModulesToContext stuff+ '-':stuff -> rest remModulesFromContext stuff+ stuff -> rest setContext stuff++ rest op stuff = (op as bs, stuffs)+ where (as,bs) = partitionWith starred stuffs+ stuffs = words stuff++ sensible ('*':m) = looksLikeModuleName m+ sensible m = looksLikeModuleName m++ starred ('*':m) = Left (GHC.mkModuleName m)+ starred m = Right (GHC.mkModuleName m)+++-- -----------------------------------------------------------------------------+-- Four ways to manipulate the context:+-- (a) :module +<stuff>: addModulesToContext+-- (b) :module -<stuff>: remModulesFromContext+-- (c) :module <stuff>: setContext+-- (d) import <module>...: addImportToContext++addModulesToContext :: [ModuleName] -> [ModuleName] -> GHCi ()+addModulesToContext starred unstarred = restoreContextOnFailure $ do+ addModulesToContext_ starred unstarred++addModulesToContext_ :: [ModuleName] -> [ModuleName] -> GHCi ()+addModulesToContext_ starred unstarred = do+ mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)+ setGHCContextFromGHCiState++remModulesFromContext :: [ModuleName] -> [ModuleName] -> GHCi ()+remModulesFromContext starred unstarred = do+ -- we do *not* call restoreContextOnFailure here. If the user+ -- is trying to fix up a context that contains errors by removing+ -- modules, we don't want GHC to silently put them back in again.+ mapM_ rm (starred ++ unstarred)+ setGHCContextFromGHCiState+ where+ rm :: ModuleName -> GHCi ()+ rm str = do+ m <- moduleName <$> lookupModuleName str+ let filt = filter ((/=) m . iiModuleName)+ modifyGHCiState $ \st ->+ st { remembered_ctx = filt (remembered_ctx st)+ , transient_ctx = filt (transient_ctx st) }++setContext :: [ModuleName] -> [ModuleName] -> GHCi ()+setContext starred unstarred = restoreContextOnFailure $ do+ modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }+ -- delete the transient context+ addModulesToContext_ starred unstarred++addImportToContext :: String -> GHCi ()+addImportToContext str = restoreContextOnFailure $ do+ idecl <- GHC.parseImportDecl str+ addII (IIDecl idecl) -- #5836+ setGHCContextFromGHCiState++-- Util used by addImportToContext and addModulesToContext+addII :: InteractiveImport -> GHCi ()+addII iidecl = do+ checkAdd iidecl+ modifyGHCiState $ \st ->+ st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st)+ , transient_ctx = filter (not . (iidecl `iiSubsumes`))+ (transient_ctx st)+ }++-- Sometimes we can't tell whether an import is valid or not until+-- we finally call 'GHC.setContext'. e.g.+--+-- import System.IO (foo)+--+-- will fail because System.IO does not export foo. In this case we+-- don't want to store the import in the context permanently, so we+-- catch the failure from 'setGHCContextFromGHCiState' and set the+-- context back to what it was.+--+-- See #6007+--+restoreContextOnFailure :: GHCi a -> GHCi a+restoreContextOnFailure do_this = do+ st <- getGHCiState+ let rc = remembered_ctx st; tc = transient_ctx st+ do_this `gonException` (modifyGHCiState $ \st' ->+ st' { remembered_ctx = rc, transient_ctx = tc })++-- -----------------------------------------------------------------------------+-- Validate a module that we want to add to the context++checkAdd :: InteractiveImport -> GHCi ()+checkAdd ii = do+ dflags <- getDynFlags+ let safe = safeLanguageOn dflags+ case ii of+ IIModule modname+ | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"+ | otherwise -> wantInterpretedModuleName modname >> return ()++ IIDecl d -> do+ let modname = unLoc (ideclName d)+ pkgqual = ideclPkgQual d+ m <- GHC.lookupModule modname (fmap sl_fs pkgqual)+ when safe $ do+ t <- GHC.isModuleTrusted m+ when (not t) $ throwGhcException $ ProgramError $ ""++-- -----------------------------------------------------------------------------+-- Update the GHC API's view of the context++-- | Sets the GHC context from the GHCi state. The GHC context is+-- always set this way, we never modify it incrementally.+--+-- We ignore any imports for which the ModuleName does not currently+-- exist. This is so that the remembered_ctx can contain imports for+-- modules that are not currently loaded, perhaps because we just did+-- a :reload and encountered errors.+--+-- Prelude is added if not already present in the list. Therefore to+-- override the implicit Prelude import you can say 'import Prelude ()'+-- at the prompt, just as in Haskell source.+--+setGHCContextFromGHCiState :: GHCi ()+setGHCContextFromGHCiState = do+ st <- getGHCiState+ -- re-use checkAdd to check whether the module is valid. If the+ -- module does not exist, we do *not* want to print an error+ -- here, we just want to silently keep the module in the context+ -- until such time as the module reappears again. So we ignore+ -- the actual exception thrown by checkAdd, using tryBool to+ -- turn it into a Bool.+ iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st)++ prel_iidecls <- getImplicitPreludeImports iidecls+ valid_prel_iidecls <- filterM (tryBool . checkAdd) prel_iidecls++ extra_imports <- filterM (tryBool . checkAdd) (map IIDecl (extra_imports st))++ GHC.setContext $ iidecls ++ extra_imports ++ valid_prel_iidecls+++getImplicitPreludeImports :: [InteractiveImport] -> GHCi [InteractiveImport]+getImplicitPreludeImports iidecls = do+ -- allow :seti to override -XNoImplicitPrelude+ st <- getGHCiState++ -- We add the prelude imports if there are no *-imports, and we also+ -- allow each prelude import to be subsumed by another explicit import+ -- of the same module. This means that you can override the prelude import+ -- with "import Prelude hiding (map)", for example.+ let prel_iidecls =+ if not (any isIIModule iidecls)+ then [ IIDecl imp+ | imp <- prelude_imports st+ , not (any (sameImpModule imp) iidecls) ]+ else []++ return prel_iidecls++-- -----------------------------------------------------------------------------+-- Utils on InteractiveImport++mkIIModule :: ModuleName -> InteractiveImport+mkIIModule = IIModule++mkIIDecl :: ModuleName -> InteractiveImport+mkIIDecl = IIDecl . simpleImportDecl++iiModules :: [InteractiveImport] -> [ModuleName]+iiModules is = [m | IIModule m <- is]++isIIModule :: InteractiveImport -> Bool+isIIModule (IIModule _) = True+isIIModule _ = False++iiModuleName :: InteractiveImport -> ModuleName+iiModuleName (IIModule m) = m+iiModuleName (IIDecl d) = unLoc (ideclName d)++preludeModuleName :: ModuleName+preludeModuleName = GHC.mkModuleName "Clash.Prelude"++sameImpModule :: ImportDecl RdrName -> InteractiveImport -> Bool+sameImpModule _ (IIModule _) = False -- we only care about imports here+sameImpModule imp (IIDecl d) = unLoc (ideclName d) == unLoc (ideclName imp)++addNotSubsumed :: InteractiveImport+ -> [InteractiveImport] -> [InteractiveImport]+addNotSubsumed i is+ | any (`iiSubsumes` i) is = is+ | otherwise = i : filter (not . (i `iiSubsumes`)) is++-- | @filterSubsumed is js@ returns the elements of @js@ not subsumed+-- by any of @is@.+filterSubsumed :: [InteractiveImport] -> [InteractiveImport]+ -> [InteractiveImport]+filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js++-- | Returns True if the left import subsumes the right one. Doesn't+-- need to be 100% accurate, conservatively returning False is fine.+-- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in+-- plusProv will ensue (#5904))+--+-- Note that an IIModule does not necessarily subsume an IIDecl,+-- because e.g. a module might export a name that is only available+-- qualified within the module itself.+--+-- Note that 'import M' does not necessarily subsume 'import M(foo)',+-- because M might not export foo and we want an error to be produced+-- in that case.+--+iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool+iiSubsumes (IIModule m1) (IIModule m2) = m1==m2+iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude+ = unLoc (ideclName d1) == unLoc (ideclName d2)+ && ideclAs d1 == ideclAs d2+ && (not (ideclQualified d1) || ideclQualified d2)+ && (ideclHiding d1 `hidingSubsumes` ideclHiding d2)+ where+ _ `hidingSubsumes` Just (False,L _ []) = True+ Just (False, L _ xs) `hidingSubsumes` Just (False,L _ ys)+ = all (`elem` xs) ys+ h1 `hidingSubsumes` h2 = h1 == h2+iiSubsumes _ _ = False+++----------------------------------------------------------------------------+-- :set++-- set options in the interpreter. Syntax is exactly the same as the+-- ghc command line, except that certain options aren't available (-C,+-- -E etc.)+--+-- This is pretty fragile: most options won't work as expected. ToDo:+-- figure out which ones & disallow them.++setCmd :: String -> GHCi ()+setCmd "" = showOptions False+setCmd "-a" = showOptions True+setCmd str+ = case getCmd str of+ Right ("args", rest) ->+ case toArgs rest of+ Left err -> liftIO (hPutStrLn stderr err)+ Right args -> setArgs args+ Right ("prog", rest) ->+ case toArgs rest of+ Right [prog] -> setProg prog+ _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")++ Right ("prompt", rest) ->+ setPromptString setPrompt (dropWhile isSpace rest)+ "syntax: set prompt <string>"+ Right ("prompt-function", rest) ->+ setPromptFunc setPrompt $ dropWhile isSpace rest+ Right ("prompt-cont", rest) ->+ setPromptString setPromptCont (dropWhile isSpace rest)+ "syntax: :set prompt-cont <string>"+ Right ("prompt-cont-function", rest) ->+ setPromptFunc setPromptCont $ dropWhile isSpace rest++ Right ("editor", rest) -> setEditor $ dropWhile isSpace rest+ Right ("stop", rest) -> setStop $ dropWhile isSpace rest+ _ -> case toArgs str of+ Left err -> liftIO (hPutStrLn stderr err)+ Right wds -> setOptions wds++setiCmd :: String -> GHCi ()+setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False+setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True+setiCmd str =+ case toArgs str of+ Left err -> liftIO (hPutStrLn stderr err)+ Right wds -> newDynFlags True wds++showOptions :: Bool -> GHCi ()+showOptions show_all+ = do st <- getGHCiState+ dflags <- getDynFlags+ let opts = options st+ liftIO $ putStrLn (showSDoc dflags (+ text "options currently set: " <>+ if null opts+ then text "none."+ else hsep (map (\o -> char '+' <> text (optToStr o)) opts)+ ))+ getDynFlags >>= liftIO . showDynFlags show_all+++showDynFlags :: Bool -> DynFlags -> IO ()+showDynFlags show_all dflags = do+ showLanguages' show_all dflags+ putStrLn $ showSDoc dflags $+ text "GHCi-specific dynamic flag settings:" $$+ nest 2 (vcat (map (setting "-f" "-fno-" gopt) ghciFlags))+ putStrLn $ showSDoc dflags $+ text "other dynamic, non-language, flag settings:" $$+ nest 2 (vcat (map (setting "-f" "-fno-" gopt) others))+ putStrLn $ showSDoc dflags $+ text "warning settings:" $$+ nest 2 (vcat (map (setting "-W" "-Wno-" wopt) DynFlags.wWarningFlags))+ where+ setting prefix noPrefix test flag+ | quiet = empty+ | is_on = text prefix <> text name+ | otherwise = text noPrefix <> text name+ where name = flagSpecName flag+ f = flagSpecFlag flag+ is_on = test f dflags+ quiet = not show_all && test f default_dflags == is_on++ default_dflags = defaultDynFlags (settings dflags)++ (ghciFlags,others) = partition (\f -> flagSpecFlag f `elem` flgs)+ DynFlags.fFlags+ flgs = [ Opt_PrintExplicitForalls+ , Opt_PrintExplicitKinds+ , Opt_PrintUnicodeSyntax+ , Opt_PrintBindResult+ , Opt_BreakOnException+ , Opt_BreakOnError+ , Opt_PrintEvldWithShow+ ]++setArgs, setOptions :: [String] -> GHCi ()+setProg, setEditor, setStop :: String -> GHCi ()++setArgs args = do+ st <- getGHCiState+ wrapper <- mkEvalWrapper (progname st) args+ setGHCiState st { GhciMonad.args = args, evalWrapper = wrapper }++setProg prog = do+ st <- getGHCiState+ wrapper <- mkEvalWrapper prog (GhciMonad.args st)+ setGHCiState st { progname = prog, evalWrapper = wrapper }++setEditor cmd = modifyGHCiState (\st -> st { editor = cmd })++setStop str@(c:_) | isDigit c+ = do let (nm_str,rest) = break (not.isDigit) str+ nm = read nm_str+ st <- getGHCiState+ let old_breaks = breaks st+ if all ((/= nm) . fst) old_breaks+ then printForUser (text "Breakpoint" <+> ppr nm <+>+ text "does not exist")+ else do+ let new_breaks = map fn old_breaks+ fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })+ | otherwise = (i,loc)+ setGHCiState st{ breaks = new_breaks }+setStop cmd = modifyGHCiState (\st -> st { stop = cmd })++setPrompt :: PromptFunction -> GHCi ()+setPrompt v = modifyGHCiState (\st -> st {prompt = v})++setPromptCont :: PromptFunction -> GHCi ()+setPromptCont v = modifyGHCiState (\st -> st {prompt_cont = v})++setPromptFunc :: (PromptFunction -> GHCi ()) -> String -> GHCi ()+setPromptFunc fSetPrompt s = do+ -- We explicitly annotate the type of the expression to ensure+ -- that unsafeCoerce# is passed the exact type necessary rather+ -- than a more general one+ let exprStr = "(" ++ s ++ ") :: [String] -> Int -> IO String"+ (HValue funValue) <- GHC.compileExpr exprStr+ fSetPrompt (convertToPromptFunction $ unsafeCoerce funValue)+ where+ convertToPromptFunction :: ([String] -> Int -> IO String)+ -> PromptFunction+ convertToPromptFunction func = (\mods line -> liftIO $+ liftM text (func mods line))++setPromptString :: (PromptFunction -> GHCi ()) -> String -> String -> GHCi ()+setPromptString fSetPrompt value err = do+ if null value+ then liftIO $ hPutStrLn stderr $ err+ else case value of+ ('\"':_) ->+ case reads value of+ [(value', xs)] | all isSpace xs ->+ setParsedPromptString fSetPrompt value'+ _ -> liftIO $ hPutStrLn stderr+ "Can't parse prompt string. Use Haskell syntax."+ _ ->+ setParsedPromptString fSetPrompt value++setParsedPromptString :: (PromptFunction -> GHCi ()) -> String -> GHCi ()+setParsedPromptString fSetPrompt s = do+ case (checkPromptStringForErrors s) of+ Just err ->+ liftIO $ hPutStrLn stderr err+ Nothing ->+ fSetPrompt $ generatePromptFunctionFromString s++setOptions wds =+ do -- first, deal with the GHCi opts (+s, +t, etc.)+ let (plus_opts, minus_opts) = partitionWith isPlus wds+ mapM_ setOpt plus_opts+ -- then, dynamic flags+ when (not (null minus_opts)) $ newDynFlags False minus_opts++newDynFlags :: Bool -> [String] -> GHCi ()+newDynFlags interactive_only minus_opts = do+ let lopts = map noLoc minus_opts++ idflags0 <- GHC.getInteractiveDynFlags+ (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts++ liftIO $ handleFlagWarnings idflags1 warns+ when (not $ null leftovers)+ (throwGhcException . CmdLineError+ $ "Some flags have not been recognized: "+ ++ (concat . intersperse ", " $ map unLoc leftovers))++ when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do+ liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"+ GHC.setInteractiveDynFlags idflags1+ installInteractivePrint (interactivePrint idflags1) False++ dflags0 <- getDynFlags+ when (not interactive_only) $ do+ (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts+ new_pkgs <- GHC.setProgramDynFlags dflags1++ -- if the package flags changed, reset the context and link+ -- the new packages.+ hsc_env <- GHC.getSession+ let dflags2 = hsc_dflags hsc_env+ when (packageFlagsChanged dflags2 dflags0) $ do+ when (verbosity dflags2 > 0) $+ liftIO . putStrLn $+ "package flags have changed, resetting and loading new packages..."+ GHC.setTargets []+ _ <- GHC.load LoadAllTargets+ liftIO $ linkPackages hsc_env new_pkgs+ -- package flags changed, we can't re-use any of the old context+ setContextAfterLoad False []+ -- and copy the package state to the interactive DynFlags+ idflags <- GHC.getInteractiveDynFlags+ GHC.setInteractiveDynFlags+ idflags{ pkgState = pkgState dflags2+ , pkgDatabase = pkgDatabase dflags2+ , packageFlags = packageFlags dflags2 }++ let ld0length = length $ ldInputs dflags0+ fmrk0length = length $ cmdlineFrameworks dflags0++ newLdInputs = drop ld0length (ldInputs dflags2)+ newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)++ hsc_env' = hsc_env { hsc_dflags =+ dflags2 { ldInputs = newLdInputs+ , cmdlineFrameworks = newCLFrameworks } }++ when (not (null newLdInputs && null newCLFrameworks)) $+ liftIO $ linkCmdLineLibs hsc_env'++ return ()+++unsetOptions :: String -> GHCi ()+unsetOptions str+ = -- first, deal with the GHCi opts (+s, +t, etc.)+ let opts = words str+ (minus_opts, rest1) = partition isMinus opts+ (plus_opts, rest2) = partitionWith isPlus rest1+ (other_opts, rest3) = partition (`elem` map fst defaulters) rest2++ defaulters =+ [ ("args" , setArgs default_args)+ , ("prog" , setProg default_progname)+ , ("prompt" , setPrompt default_prompt)+ , ("prompt-cont", setPromptCont default_prompt_cont)+ , ("editor" , liftIO findEditor >>= setEditor)+ , ("stop" , setStop default_stop)+ ]++ no_flag ('-':'f':rest) = return ("-fno-" ++ rest)+ no_flag ('-':'X':rest) = return ("-XNo" ++ rest)+ no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f))++ in if (not (null rest3))+ then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))+ else do+ mapM_ (fromJust.flip lookup defaulters) other_opts++ mapM_ unsetOpt plus_opts++ no_flags <- mapM no_flag minus_opts+ when (not (null no_flags)) $ newDynFlags False no_flags++isMinus :: String -> Bool+isMinus ('-':_) = True+isMinus _ = False++isPlus :: String -> Either String String+isPlus ('+':opt) = Left opt+isPlus other = Right other++setOpt, unsetOpt :: String -> GHCi ()++setOpt str+ = case strToGHCiOpt str of+ Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))+ Just o -> setOption o++unsetOpt str+ = case strToGHCiOpt str of+ Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))+ Just o -> unsetOption o++strToGHCiOpt :: String -> (Maybe GHCiOption)+strToGHCiOpt "m" = Just Multiline+strToGHCiOpt "s" = Just ShowTiming+strToGHCiOpt "t" = Just ShowType+strToGHCiOpt "r" = Just RevertCAFs+strToGHCiOpt "c" = Just CollectInfo+strToGHCiOpt _ = Nothing++optToStr :: GHCiOption -> String+optToStr Multiline = "m"+optToStr ShowTiming = "s"+optToStr ShowType = "t"+optToStr RevertCAFs = "r"+optToStr CollectInfo = "c"+++-- ---------------------------------------------------------------------------+-- :show++showCmd :: String -> GHCi ()+showCmd "" = showOptions False+showCmd "-a" = showOptions True+showCmd str = do+ st <- getGHCiState+ dflags <- getDynFlags++ let lookupCmd :: String -> Maybe (GHCi ())+ lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds++ -- (show in help?, command name, action)+ action :: String -> GHCi () -> (Bool, String, GHCi ())+ action name m = (True, name, m)++ hidden :: String -> GHCi () -> (Bool, String, GHCi ())+ hidden name m = (False, name, m)++ cmds =+ [ action "args" $ liftIO $ putStrLn (show (GhciMonad.args st))+ , action "prog" $ liftIO $ putStrLn (show (progname st))+ , action "editor" $ liftIO $ putStrLn (show (editor st))+ , action "stop" $ liftIO $ putStrLn (show (stop st))+ , action "imports" $ showImports+ , action "modules" $ showModules+ , action "bindings" $ showBindings+ , action "linker" $ getDynFlags >>= liftIO . showLinkerState+ , action "breaks" $ showBkptTable+ , action "context" $ showContext+ , action "packages" $ showPackages+ , action "paths" $ showPaths+ , action "language" $ showLanguages+ , hidden "languages" $ showLanguages -- backwards compat+ , hidden "lang" $ showLanguages -- useful abbreviation+ ]++ case words str of+ [w] | Just action <- lookupCmd w -> action++ _ -> let helpCmds = [ text name | (True, name, _) <- cmds ]+ in throwGhcException $ CmdLineError $ showSDoc dflags+ $ hang (text "syntax:") 4+ $ hang (text ":show") 6+ $ brackets (fsep $ punctuate (text " |") helpCmds)++showiCmd :: String -> GHCi ()+showiCmd str = do+ case words str of+ ["languages"] -> showiLanguages -- backwards compat+ ["language"] -> showiLanguages+ ["lang"] -> showiLanguages -- useful abbreviation+ _ -> throwGhcException (CmdLineError ("syntax: :showi language"))++showImports :: GHCi ()+showImports = do+ st <- getGHCiState+ dflags <- getDynFlags+ let rem_ctx = reverse (remembered_ctx st)+ trans_ctx = transient_ctx st++ show_one (IIModule star_m)+ = ":module +*" ++ moduleNameString star_m+ show_one (IIDecl imp) = showPpr dflags imp++ prel_iidecls <- getImplicitPreludeImports (rem_ctx ++ trans_ctx)++ let show_prel p = show_one p ++ " -- implicit"+ show_extra p = show_one (IIDecl p) ++ " -- fixed"++ trans_comment s = s ++ " -- added automatically" :: String+ --+ liftIO $ mapM_ putStrLn (map show_one rem_ctx +++ map (trans_comment . show_one) trans_ctx +++ map show_prel prel_iidecls +++ map show_extra (extra_imports st))++showModules :: GHCi ()+showModules = do+ loaded_mods <- getLoadedModules+ -- we want *loaded* modules only, see #1734+ let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)+ mapM_ show_one loaded_mods++getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]+getLoadedModules = do+ graph <- GHC.getModuleGraph+ filterM (GHC.isLoaded . GHC.ms_mod_name) graph++showBindings :: GHCi ()+showBindings = do+ bindings <- GHC.getBindings+ (insts, finsts) <- GHC.getInsts+ docs <- mapM makeDoc (reverse bindings)+ -- reverse so the new ones come last+ let idocs = map GHC.pprInstanceHdr insts+ fidocs = map GHC.pprFamInst finsts+ mapM_ printForUserPartWay (docs ++ idocs ++ fidocs)+ where+ makeDoc (AnId i) = pprTypeAndContents i+ makeDoc tt = do+ mb_stuff <- GHC.getInfo False (getName tt)+ return $ maybe (text "") pprTT mb_stuff++ pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc+ pprTT (thing, fixity, _cls_insts, _fam_insts)+ = pprTyThing showToHeader thing+ $$ show_fixity+ where+ show_fixity+ | fixity == GHC.defaultFixity = empty+ | otherwise = ppr fixity <+> ppr (GHC.getName thing)+++printTyThing :: TyThing -> GHCi ()+printTyThing tyth = printForUser (pprTyThing showToHeader tyth)++showBkptTable :: GHCi ()+showBkptTable = do+ st <- getGHCiState+ printForUser $ prettyLocations (breaks st)++showContext :: GHCi ()+showContext = do+ resumes <- GHC.getResumeContext+ printForUser $ vcat (map pp_resume (reverse resumes))+ where+ pp_resume res =+ ptext (sLit "--> ") <> text (GHC.resumeStmt res)+ $$ nest 2 (pprStopped res)++pprStopped :: GHC.Resume -> SDoc+pprStopped res =+ ptext (sLit "Stopped in")+ <+> ((case mb_mod_name of+ Nothing -> empty+ Just mod_name -> text (moduleNameString mod_name) <> char '.')+ <> text (GHC.resumeDecl res))+ <> char ',' <+> ppr (GHC.resumeSpan res)+ where+ mb_mod_name = moduleName <$> GHC.breakInfo_module <$> GHC.resumeBreakInfo res++showPackages :: GHCi ()+showPackages = do+ dflags <- getDynFlags+ let pkg_flags = packageFlags dflags+ liftIO $ putStrLn $ showSDoc dflags $+ text ("active package flags:"++if null pkg_flags then " none" else "") $$+ nest 2 (vcat (map pprFlag pkg_flags))++showPaths :: GHCi ()+showPaths = do+ dflags <- getDynFlags+ liftIO $ do+ cwd <- getCurrentDirectory+ putStrLn $ showSDoc dflags $+ text "current working directory: " $$+ nest 2 (text cwd)+ let ipaths = importPaths dflags+ putStrLn $ showSDoc dflags $+ text ("module import search paths:"++if null ipaths then " none" else "") $$+ nest 2 (vcat (map text ipaths))++showLanguages :: GHCi ()+showLanguages = getDynFlags >>= liftIO . showLanguages' False++showiLanguages :: GHCi ()+showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False++showLanguages' :: Bool -> DynFlags -> IO ()+showLanguages' show_all dflags =+ putStrLn $ showSDoc dflags $ vcat+ [ text "base language is: " <>+ case language dflags of+ Nothing -> text "Haskell2010"+ Just Haskell98 -> text "Haskell98"+ Just Haskell2010 -> text "Haskell2010"+ , (if show_all then text "all active language options:"+ else text "with the following modifiers:") $$+ nest 2 (vcat (map (setting xopt) DynFlags.xFlags))+ ]+ where+ setting test flag+ | quiet = empty+ | is_on = text "-X" <> text name+ | otherwise = text "-XNo" <> text name+ where name = flagSpecName flag+ f = flagSpecFlag flag+ is_on = test f dflags+ quiet = not show_all && test f default_dflags == is_on++ default_dflags =+ defaultDynFlags (settings dflags) `lang_set`+ case language dflags of+ Nothing -> Just Haskell2010+ other -> other++-- -----------------------------------------------------------------------------+-- Completion++completeCmd :: String -> GHCi ()+completeCmd argLine0 = case parseLine argLine0 of+ Just ("repl", resultRange, left) -> do+ (unusedLine,compls) <- ghciCompleteWord (reverse left,"")+ let compls' = takeRange resultRange compls+ liftIO . putStrLn $ unwords [ show (length compls'), show (length compls), show (reverse unusedLine) ]+ forM_ (takeRange resultRange compls) $ \(Completion r _ _) -> do+ liftIO $ print r+ _ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>")+ where+ parseLine argLine+ | null argLine = Nothing+ | null rest1 = Nothing+ | otherwise = (,,) dom <$> resRange <*> s+ where+ (dom, rest1) = breakSpace argLine+ (rng, rest2) = breakSpace rest1+ resRange | head rest1 == '"' = parseRange ""+ | otherwise = parseRange rng+ s | head rest1 == '"' = readMaybe rest1 :: Maybe String+ | otherwise = readMaybe rest2+ breakSpace = fmap (dropWhile isSpace) . break isSpace++ takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub++ -- syntax: [n-][m] with semantics "drop (n-1) . take m"+ parseRange :: String -> Maybe (Maybe Int,Maybe Int)+ parseRange s = case span isDigit s of+ (_, "") ->+ -- upper limit only+ Just (Nothing, bndRead s)+ (s1, '-' : s2)+ | all isDigit s2 ->+ Just (bndRead s1, bndRead s2)+ _ ->+ Nothing+ where+ bndRead x = if null x then Nothing else Just (read x)++++completeGhciCommand, completeMacro, completeIdentifier, completeModule,+ completeSetModule, completeSeti, completeShowiOptions,+ completeHomeModule, completeSetOptions, completeShowOptions,+ completeHomeModuleOrFile, completeExpression+ :: CompletionFunc GHCi++-- | Provide completions for last word in a given string.+--+-- Takes a tuple of two strings. First string is a reversed line to be+-- completed. Second string is likely unused, 'completeCmd' always passes an+-- empty string as second item in tuple.+ghciCompleteWord :: CompletionFunc GHCi+ghciCompleteWord line@(left,_) = case firstWord of+ -- If given string starts with `:` colon, and there is only one following+ -- word then provide REPL command completions. If there is more than one+ -- word complete either filename or builtin ghci commands or macros.+ ':':cmd | null rest -> completeGhciCommand line+ | otherwise -> do+ completion <- lookupCompletion cmd+ completion line+ -- If given string starts with `import` keyword provide module name+ -- completions+ "import" -> completeModule line+ -- otherwise provide identifier completions+ _ -> completeExpression line+ where+ (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left+ lookupCompletion ('!':_) = return completeFilename+ lookupCompletion c = do+ maybe_cmd <- lookupCommand' c+ case maybe_cmd of+ Just cmd -> return (cmdCompletionFunc cmd)+ Nothing -> return completeFilename++completeGhciCommand = wrapCompleter " " $ \w -> do+ macros <- ghci_macros <$> getGHCiState+ cmds <- ghci_commands `fmap` getGHCiState+ let macro_names = map (':':) . map cmdName $ macros+ let command_names = map (':':) . map cmdName $ filter (not . cmdHidden) cmds+ let{ candidates = case w of+ ':' : ':' : _ -> map (':':) command_names+ _ -> nub $ macro_names ++ command_names }+ return $ filter (w `isPrefixOf`) candidates++completeMacro = wrapIdentCompleter $ \w -> do+ cmds <- ghci_macros <$> getGHCiState+ return (filter (w `isPrefixOf`) (map cmdName cmds))++completeIdentifier line@(left, _) =+ -- Note: `left` is a reversed input+ case left of+ (x:_) | isSymbolChar x -> wrapCompleter (specials ++ spaces) complete line+ _ -> wrapIdentCompleter complete line+ where+ complete w = do+ rdrs <- GHC.getRdrNamesInScope+ dflags <- GHC.getSessionDynFlags+ return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))++completeModule = wrapIdentCompleter $ \w -> do+ dflags <- GHC.getSessionDynFlags+ let pkg_mods = allVisibleModules dflags+ loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules+ return $ filter (w `isPrefixOf`)+ $ map (showPpr dflags) $ loaded_mods ++ pkg_mods++completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do+ dflags <- GHC.getSessionDynFlags+ modules <- case m of+ Just '-' -> do+ imports <- GHC.getContext+ return $ map iiModuleName imports+ _ -> do+ let pkg_mods = allVisibleModules dflags+ loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules+ return $ loaded_mods ++ pkg_mods+ return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules++completeHomeModule = wrapIdentCompleter listHomeModules++listHomeModules :: String -> GHCi [String]+listHomeModules w = do+ g <- GHC.getModuleGraph+ let home_mods = map GHC.ms_mod_name g+ dflags <- getDynFlags+ return $ sort $ filter (w `isPrefixOf`)+ $ map (showPpr dflags) home_mods++completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) opts)+ where opts = "args":"prog":"prompt":"prompt-cont":"prompt-function":+ "prompt-cont-function":"editor":"stop":flagList+ flagList = map head $ group $ sort allNonDeprecatedFlags++completeSeti = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) flagList)+ where flagList = map head $ group $ sort allNonDeprecatedFlags++completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) opts)+ where opts = ["args", "prog", "editor", "stop",+ "modules", "bindings", "linker", "breaks",+ "context", "packages", "paths", "language", "imports"]++completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) ["language"])++completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars+ $ unionComplete (fmap (map simpleCompletion) . listHomeModules)+ listFiles++unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]+unionComplete f1 f2 line = do+ cs1 <- f1 line+ cs2 <- f2 line+ return (cs1 ++ cs2)++wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi+wrapCompleter breakChars fun = completeWord Nothing breakChars+ $ fmap (map simpleCompletion . nubSort) . fun++wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi+wrapIdentCompleter = wrapCompleter word_break_chars++wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi+wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars+ $ \rest -> fmap (map simpleCompletion . nubSort) . fun (getModifier rest)+ where+ getModifier = find (`elem` modifChars)++-- | Return a list of visible module names for autocompletion.+-- (NB: exposed != visible)+allVisibleModules :: DynFlags -> [ModuleName]+allVisibleModules dflags = listVisibleModuleNames dflags++completeExpression = completeQuotedWord (Just '\\') "\"" listFiles+ completeIdentifier+++-- -----------------------------------------------------------------------------+-- commands for debugger++sprintCmd, printCmd, forceCmd :: String -> GHCi ()+sprintCmd = pprintCommand False False+printCmd = pprintCommand True False+forceCmd = pprintCommand False True++pprintCommand :: Bool -> Bool -> String -> GHCi ()+pprintCommand bind force str = do+ pprintClosureCommand bind force str++stepCmd :: String -> GHCi ()+stepCmd arg = withSandboxOnly ":step" $ step arg+ where+ step [] = doContinue (const True) GHC.SingleStep+ step expression = runStmt expression GHC.SingleStep >> return ()++stepLocalCmd :: String -> GHCi ()+stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg+ where+ step expr+ | not (null expr) = stepCmd expr+ | otherwise = do+ mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing -> stepCmd []+ Just loc -> do+ Just md <- getCurrentBreakModule+ current_toplevel_decl <- enclosingTickSpan md loc+ doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep++stepModuleCmd :: String -> GHCi ()+stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg+ where+ step expr+ | not (null expr) = stepCmd expr+ | otherwise = do+ mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing -> stepCmd []+ Just pan -> do+ let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span+ doContinue f GHC.SingleStep++-- | Returns the span of the largest tick containing the srcspan given+enclosingTickSpan :: Module -> SrcSpan -> GHCi RealSrcSpan+enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"+enclosingTickSpan md (RealSrcSpan src) = do+ ticks <- getTickArray md+ let line = srcSpanStartLine src+ ASSERT(inRange (bounds ticks) line) do+ let enclosing_spans = [ pan | (_,pan) <- ticks ! line+ , realSrcSpanEnd pan >= realSrcSpanEnd src]+ return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans+ where++leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering+leftmostLargestRealSrcSpan a b =+ (realSrcSpanStart a `compare` realSrcSpanStart b)+ `thenCmp`+ (realSrcSpanEnd b `compare` realSrcSpanEnd a)++traceCmd :: String -> GHCi ()+traceCmd arg+ = withSandboxOnly ":trace" $ tr arg+ where+ tr [] = doContinue (const True) GHC.RunAndLogSteps+ tr expression = runStmt expression GHC.RunAndLogSteps >> return ()++continueCmd :: String -> GHCi ()+continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion++-- doContinue :: SingleStep -> GHCi ()+doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()+doContinue pre step = do+ runResult <- resume pre step+ _ <- afterRunStmt pre runResult+ return ()++abandonCmd :: String -> GHCi ()+abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do+ b <- GHC.abandon -- the prompt will change to indicate the new context+ when (not b) $ liftIO $ putStrLn "There is no computation running."++deleteCmd :: String -> GHCi ()+deleteCmd argLine = withSandboxOnly ":delete" $ do+ deleteSwitch $ words argLine+ where+ deleteSwitch :: [String] -> GHCi ()+ deleteSwitch [] =+ liftIO $ putStrLn "The delete command requires at least one argument."+ -- delete all break points+ deleteSwitch ("*":_rest) = discardActiveBreakPoints+ deleteSwitch idents = do+ mapM_ deleteOneBreak idents+ where+ deleteOneBreak :: String -> GHCi ()+ deleteOneBreak str+ | all isDigit str = deleteBreak (read str)+ | otherwise = return ()++historyCmd :: String -> GHCi ()+historyCmd arg+ | null arg = history 20+ | all isDigit arg = history (read arg)+ | otherwise = liftIO $ putStrLn "Syntax: :history [num]"+ where+ history num = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> liftIO $ putStrLn "Not stopped at a breakpoint"+ (r:_) -> do+ let hist = GHC.resumeHistory r+ (took,rest) = splitAt num hist+ case hist of+ [] -> liftIO $ putStrLn $+ "Empty history. Perhaps you forgot to use :trace?"+ _ -> do+ pans <- mapM GHC.getHistorySpan took+ let nums = map (printf "-%-3d:") [(1::Int)..]+ names = map GHC.historyEnclosingDecls took+ printForUser (vcat(zipWith3+ (\x y z -> x <+> y <+> z)+ (map text nums)+ (map (bold . hcat . punctuate colon . map text) names)+ (map (parens . ppr) pans)))+ liftIO $ putStrLn $ if null rest then "<end of history>" else "..."++bold :: SDoc -> SDoc+bold c | do_bold = text start_bold <> c <> text end_bold+ | otherwise = c++backCmd :: String -> GHCi ()+backCmd arg+ | null arg = back 1+ | all isDigit arg = back (read arg)+ | otherwise = liftIO $ putStrLn "Syntax: :back [num]"+ where+ back num = withSandboxOnly ":back" $ do+ (names, _, pan, _) <- GHC.back num+ printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan+ printTypeOfNames names+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]++forwardCmd :: String -> GHCi ()+forwardCmd arg+ | null arg = forward 1+ | all isDigit arg = forward (read arg)+ | otherwise = liftIO $ putStrLn "Syntax: :back [num]"+ where+ forward num = withSandboxOnly ":forward" $ do+ (names, ix, pan, _) <- GHC.forward num+ printForUser $ (if (ix == 0)+ then ptext (sLit "Stopped at")+ else ptext (sLit "Logged breakpoint at")) <+> ppr pan+ printTypeOfNames names+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]++-- handle the "break" command+breakCmd :: String -> GHCi ()+breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine++breakSwitch :: [String] -> GHCi ()+breakSwitch [] = do+ liftIO $ putStrLn "The break command requires at least one argument."+breakSwitch (arg1:rest)+ | looksLikeModuleName arg1 && not (null rest) = do+ md <- wantInterpretedModule arg1+ breakByModule md rest+ | all isDigit arg1 = do+ imports <- GHC.getContext+ case iiModules imports of+ (mn : _) -> do+ md <- lookupModuleName mn+ breakByModuleLine md (read arg1) rest+ [] -> do+ liftIO $ putStrLn "No modules are loaded with debugging support."+ | otherwise = do -- try parsing it as an identifier+ wantNameFromInterpretedModule noCanDo arg1 $ \name -> do+ maybe_info <- GHC.getModuleInfo (GHC.nameModule name)+ case maybe_info of+ Nothing -> noCanDo name (ptext (sLit "cannot get module info"))+ Just minf ->+ ASSERT( isExternalName name )+ findBreakAndSet (GHC.nameModule name) $+ findBreakForBind name (GHC.modInfoModBreaks minf)+ where+ noCanDo n why = printForUser $+ text "cannot set breakpoint on " <> ppr n <> text ": " <> why++breakByModule :: Module -> [String] -> GHCi ()+breakByModule md (arg1:rest)+ | all isDigit arg1 = do -- looks like a line number+ breakByModuleLine md (read arg1) rest+breakByModule _ _+ = breakSyntax++breakByModuleLine :: Module -> Int -> [String] -> GHCi ()+breakByModuleLine md line args+ | [] <- args = findBreakAndSet md $ maybeToList . findBreakByLine line+ | [col] <- args, all isDigit col =+ findBreakAndSet md $ maybeToList . findBreakByCoord Nothing (line, read col)+ | otherwise = breakSyntax++breakSyntax :: a+breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")++findBreakAndSet :: Module -> (TickArray -> [(Int, RealSrcSpan)]) -> GHCi ()+findBreakAndSet md lookupTickTree = do+ tickArray <- getTickArray md+ (breakArray, _) <- getModBreak md+ case lookupTickTree tickArray of+ [] -> liftIO $ putStrLn $ "No breakpoints found at that location."+ some -> mapM_ (breakAt breakArray) some+ where+ breakAt breakArray (tick, pan) = do+ setBreakFlag True breakArray tick+ (alreadySet, nm) <-+ recordBreak $ BreakLocation+ { breakModule = md+ , breakLoc = RealSrcSpan pan+ , breakTick = tick+ , onBreakCmd = ""+ }+ printForUser $+ text "Breakpoint " <> ppr nm <>+ if alreadySet+ then text " was already set at " <> ppr pan+ else text " activated at " <> ppr pan++-- When a line number is specified, the current policy for choosing+-- the best breakpoint is this:+-- - the leftmost complete subexpression on the specified line, or+-- - the leftmost subexpression starting on the specified line, or+-- - the rightmost subexpression enclosing the specified line+--+findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan)+findBreakByLine line arr+ | not (inRange (bounds arr) line) = Nothing+ | otherwise =+ listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd) comp) `mplus`+ listToMaybe (sortBy (compare `on` snd) incomp) `mplus`+ listToMaybe (sortBy (flip compare `on` snd) ticks)+ where+ ticks = arr ! line++ starts_here = [ (ix,pan) | (ix, pan) <- ticks,+ GHC.srcSpanStartLine pan == line ]++ (comp, incomp) = partition ends_here starts_here+ where ends_here (_,pan) = GHC.srcSpanEndLine pan == line++-- The aim is to find the breakpoints for all the RHSs of the+-- equations corresponding to a binding. So we find all breakpoints+-- for+-- (a) this binder only (not a nested declaration)+-- (b) that do not have an enclosing breakpoint+findBreakForBind :: Name -> GHC.ModBreaks -> TickArray+ -> [(BreakIndex,RealSrcSpan)]+findBreakForBind name modbreaks _ = filter (not . enclosed) ticks+ where+ ticks = [ (index, span)+ | (index, [n]) <- assocs (GHC.modBreaks_decls modbreaks),+ n == occNameString (nameOccName name),+ RealSrcSpan span <- [GHC.modBreaks_locs modbreaks ! index] ]+ enclosed (_,sp0) = any subspan ticks+ where subspan (_,sp) = sp /= sp0 &&+ realSrcSpanStart sp <= realSrcSpanStart sp0 &&+ realSrcSpanEnd sp0 <= realSrcSpanEnd sp++findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray+ -> Maybe (BreakIndex,RealSrcSpan)+findBreakByCoord mb_file (line, col) arr+ | not (inRange (bounds arr) line) = Nothing+ | otherwise =+ listToMaybe (sortBy (flip compare `on` snd) contains +++ sortBy (compare `on` snd) after_here)+ where+ ticks = arr ! line++ -- the ticks that span this coordinate+ contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan `spans` (line,col),+ is_correct_file pan ]++ is_correct_file pan+ | Just f <- mb_file = GHC.srcSpanFile pan == f+ | otherwise = True++ after_here = [ tick | tick@(_,pan) <- ticks,+ GHC.srcSpanStartLine pan == line,+ GHC.srcSpanStartCol pan >= col ]++-- For now, use ANSI bold on terminals that we know support it.+-- Otherwise, we add a line of carets under the active expression instead.+-- In particular, on Windows and when running the testsuite (which sets+-- TERM to vt100 for other reasons) we get carets.+-- We really ought to use a proper termcap/terminfo library.+do_bold :: Bool+do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]+ where mTerm = System.Environment.getEnv "TERM"+ `catchIO` \_ -> return "TERM not set"++start_bold :: String+start_bold = "\ESC[1m"+end_bold :: String+end_bold = "\ESC[0m"++-----------------------------------------------------------------------------+-- :where++whereCmd :: String -> GHCi ()+whereCmd = noArgs $ do+ mstrs <- getCallStackAtCurrentBreakpoint+ case mstrs of+ Nothing -> return ()+ Just strs -> liftIO $ putStrLn (renderStack strs)++-----------------------------------------------------------------------------+-- :list++listCmd :: String -> InputT GHCi ()+listCmd c = listCmd' c++listCmd' :: String -> InputT GHCi ()+listCmd' "" = do+ mb_span <- lift getCurrentBreakSpan+ case mb_span of+ Nothing ->+ printForUser $ text "Not stopped at a breakpoint; nothing to list"+ Just (RealSrcSpan pan) ->+ listAround pan True+ Just pan@(UnhelpfulSpan _) ->+ do resumes <- GHC.getResumeContext+ case resumes of+ [] -> panic "No resumes"+ (r:_) ->+ do let traceIt = case GHC.resumeHistory r of+ [] -> text "rerunning with :trace,"+ _ -> empty+ doWhat = traceIt <+> text ":back then :list"+ printForUser (text "Unable to list source for" <+>+ ppr pan+ $$ text "Try" <+> doWhat)+listCmd' str = list2 (words str)++list2 :: [String] -> InputT GHCi ()+list2 [arg] | all isDigit arg = do+ imports <- GHC.getContext+ case iiModules imports of+ [] -> liftIO $ putStrLn "No module to list"+ (mn : _) -> do+ md <- lift $ lookupModuleName mn+ listModuleLine md (read arg)+list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do+ md <- wantInterpretedModule arg1+ listModuleLine md (read arg2)+list2 [arg] = do+ wantNameFromInterpretedModule noCanDo arg $ \name -> do+ let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)+ case loc of+ RealSrcLoc l ->+ do tickArray <- ASSERT( isExternalName name )+ lift $ getTickArray (GHC.nameModule name)+ let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))+ (GHC.srcLocLine l, GHC.srcLocCol l)+ tickArray+ case mb_span of+ Nothing -> listAround (realSrcLocSpan l) False+ Just (_, pan) -> listAround pan False+ UnhelpfulLoc _ ->+ noCanDo name $ text "can't find its location: " <>+ ppr loc+ where+ noCanDo n why = printForUser $+ text "cannot list source code for " <> ppr n <> text ": " <> why+list2 _other =+ liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"++listModuleLine :: Module -> Int -> InputT GHCi ()+listModuleLine modl line = do+ graph <- GHC.getModuleGraph+ let this = filter ((== modl) . GHC.ms_mod) graph+ case this of+ [] -> panic "listModuleLine"+ summ:_ -> do+ let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))+ loc = mkRealSrcLoc (mkFastString (filename)) line 0+ listAround (realSrcLocSpan loc) False++-- | list a section of a source file around a particular SrcSpan.+-- If the highlight flag is True, also highlight the span using+-- start_bold\/end_bold.++-- GHC files are UTF-8, so we can implement this by:+-- 1) read the file in as a BS and syntax highlight it as before+-- 2) convert the BS to String using utf-string, and write it out.+-- It would be better if we could convert directly between UTF-8 and the+-- console encoding, of course.+listAround :: MonadIO m => RealSrcSpan -> Bool -> InputT m ()+listAround pan do_highlight = do+ contents <- liftIO $ BS.readFile (unpackFS file)+ -- Drop carriage returns to avoid duplicates, see #9367.+ let ls = BS.split '\n' $ BS.filter (/= '\r') contents+ ls' = take (line2 - line1 + 1 + pad_before + pad_after) $+ drop (line1 - 1 - pad_before) $ ls+ fst_line = max 1 (line1 - pad_before)+ line_nos = [ fst_line .. ]++ highlighted | do_highlight = zipWith highlight line_nos ls'+ | otherwise = [\p -> BS.concat[p,l] | l <- ls']++ bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]+ prefixed = zipWith ($) highlighted bs_line_nos+ output = BS.intercalate (BS.pack "\n") prefixed++ let utf8Decoded = utf8DecodeByteString output+ liftIO $ putStrLn utf8Decoded+ where+ file = GHC.srcSpanFile pan+ line1 = GHC.srcSpanStartLine pan+ col1 = GHC.srcSpanStartCol pan - 1+ line2 = GHC.srcSpanEndLine pan+ col2 = GHC.srcSpanEndCol pan - 1++ pad_before | line1 == 1 = 0+ | otherwise = 1+ pad_after = 1++ highlight | do_bold = highlight_bold+ | otherwise = highlight_carets++ highlight_bold no line prefix+ | no == line1 && no == line2+ = let (a,r) = BS.splitAt col1 line+ (b,c) = BS.splitAt (col2-col1) r+ in+ BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]+ | no == line1+ = let (a,b) = BS.splitAt col1 line in+ BS.concat [prefix, a, BS.pack start_bold, b]+ | no == line2+ = let (a,b) = BS.splitAt col2 line in+ BS.concat [prefix, a, BS.pack end_bold, b]+ | otherwise = BS.concat [prefix, line]++ highlight_carets no line prefix+ | no == line1 && no == line2+ = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',+ BS.replicate (col2-col1) '^']+ | no == line1+ = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,+ prefix, line]+ | no == line2+ = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',+ BS.pack "^^"]+ | otherwise = BS.concat [prefix, line]+ where+ indent = BS.pack (" " ++ replicate (length (show no)) ' ')+ nl = BS.singleton '\n'+++-- --------------------------------------------------------------------------+-- Tick arrays++getTickArray :: Module -> GHCi TickArray+getTickArray modl = do+ st <- getGHCiState+ let arrmap = tickarrays st+ case lookupModuleEnv arrmap modl of+ Just arr -> return arr+ Nothing -> do+ (_breakArray, ticks) <- getModBreak modl+ let arr = mkTickArray (assocs ticks)+ setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}+ return arr++discardTickArrays :: GHCi ()+discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})++mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray+mkTickArray ticks+ = accumArray (flip (:)) [] (1, max_line)+ [ (line, (nm,pan)) | (nm,RealSrcSpan pan) <- ticks, line <- srcSpanLines pan ]+ where+ max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp) <- ticks ]+ srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]++-- don't reset the counter back to zero?+discardActiveBreakPoints :: GHCi ()+discardActiveBreakPoints = do+ st <- getGHCiState+ mapM_ (turnOffBreak.snd) (breaks st)+ setGHCiState $ st { breaks = [] }++deleteBreak :: Int -> GHCi ()+deleteBreak identity = do+ st <- getGHCiState+ let oldLocations = breaks st+ (this,rest) = partition (\loc -> fst loc == identity) oldLocations+ if null this+ then printForUser (text "Breakpoint" <+> ppr identity <+>+ text "does not exist")+ else do+ mapM_ (turnOffBreak.snd) this+ setGHCiState $ st { breaks = rest }++turnOffBreak :: BreakLocation -> GHCi ()+turnOffBreak loc = do+ (arr, _) <- getModBreak (breakModule loc)+ hsc_env <- GHC.getSession+ liftIO $ enableBreakpoint hsc_env arr (breakTick loc) False++getModBreak :: Module -> GHCi (ForeignRef BreakArray, Array Int SrcSpan)+getModBreak m = do+ Just mod_info <- GHC.getModuleInfo m+ let modBreaks = GHC.modInfoModBreaks mod_info+ let arr = GHC.modBreaks_flags modBreaks+ let ticks = GHC.modBreaks_locs modBreaks+ return (arr, ticks)++setBreakFlag :: Bool -> ForeignRef BreakArray -> Int -> GHCi ()+setBreakFlag toggle arr i = do+ hsc_env <- GHC.getSession+ liftIO $ enableBreakpoint hsc_env arr i toggle++-- ---------------------------------------------------------------------------+-- User code exception handling++-- This is the exception handler for exceptions generated by the+-- user's code and exceptions coming from children sessions;+-- it normally just prints out the exception. The+-- handler must be recursive, in case showing the exception causes+-- more exceptions to be raised.+--+-- Bugfix: if the user closed stdout or stderr, the flushing will fail,+-- raising another exception. We therefore don't put the recursive+-- handler arond the flushing operation, so if stderr is closed+-- GHCi will just die gracefully rather than going into an infinite loop.+handler :: SomeException -> GHCi Bool++handler exception = do+ flushInterpBuffers+ withSignalHandlers $+ ghciHandle handler (showException exception >> return False)++showException :: SomeException -> GHCi ()+showException se =+ liftIO $ case fromException se of+ -- omit the location for CmdLineError:+ Just (CmdLineError s) -> putException s+ -- ditto:+ Just other_ghc_ex -> putException (show other_ghc_ex)+ Nothing ->+ case fromException se of+ Just UserInterrupt -> putException "Interrupted."+ _ -> putException ("*** Exception: " ++ show se)+ where+ putException = hPutStrLn stderr+++-----------------------------------------------------------------------------+-- recursive exception handlers++-- Don't forget to unblock async exceptions in the handler, or if we're+-- in an exception loop (eg. let a = error a in a) the ^C exception+-- may never be delivered. Thanks to Marcin for pointing out the bug.++ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a+ghciHandle h m = gmask $ \restore -> do+ -- Force dflags to avoid leaking the associated HscEnv+ !dflags <- getDynFlags+ gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)++ghciTry :: GHCi a -> GHCi (Either SomeException a)+ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)++tryBool :: GHCi a -> GHCi Bool+tryBool m = do+ r <- ghciTry m+ case r of+ Left _ -> return False+ Right _ -> return True++-- ----------------------------------------------------------------------------+-- Utils++lookupModule :: GHC.GhcMonad m => String -> m Module+lookupModule mName = lookupModuleName (GHC.mkModuleName mName)++lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module+lookupModuleName mName = GHC.lookupModule mName Nothing++isHomeModule :: Module -> Bool+isHomeModule m = GHC.moduleUnitId m == mainUnitId++-- TODO: won't work if home dir is encoded.+-- (changeDirectory may not work either in that case.)+expandPath :: MonadIO m => String -> InputT m String+expandPath = liftIO . expandPathIO++expandPathIO :: String -> IO String+expandPathIO p =+ case dropWhile isSpace p of+ ('~':d) -> do+ tilde <- getHomeDirectory -- will fail if HOME not defined+ return (tilde ++ '/':d)+ other ->+ return other++wantInterpretedModule :: GHC.GhcMonad m => String -> m Module+wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)++wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module+wantInterpretedModuleName modname = do+ modl <- lookupModuleName modname+ let str = moduleNameString modname+ dflags <- getDynFlags+ when (GHC.moduleUnitId modl /= thisPackage dflags) $+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))+ is_interpreted <- GHC.moduleIsInterpreted modl+ when (not is_interpreted) $+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))+ return modl++wantNameFromInterpretedModule :: GHC.GhcMonad m+ => (Name -> SDoc -> m ())+ -> String+ -> (Name -> m ())+ -> m ()+wantNameFromInterpretedModule noCanDo str and_then =+ handleSourceError GHC.printException $ do+ names <- GHC.parseName str+ case names of+ [] -> return ()+ (n:_) -> do+ let modl = ASSERT( isExternalName n ) GHC.nameModule n+ if not (GHC.isExternalName n)+ then noCanDo n $ ppr n <>+ text " is not defined in an interpreted module"+ else do+ is_interpreted <- GHC.moduleIsInterpreted modl+ if not is_interpreted+ then noCanDo n $ text "module " <> ppr modl <>+ text " is not interpreted"+ else and_then n
+ src-bin-821/Clash/GHCi/UI/Info.hs view
@@ -0,0 +1,366 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Get information on modules, expreesions, and identifiers+module Clash.GHCi.UI.Info+ ( ModInfo(..)+ , SpanInfo(..)+ , spanInfoFromRealSrcSpan+ , collectInfo+ , findLoc+ , findNameUses+ , findType+ , getModInfo+ ) where++import Control.Exception+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+import Control.Monad.Trans.Maybe+import Data.Data+import Data.Function+import Data.List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Time+import Prelude hiding (mod)+import System.Directory++import qualified CoreUtils+import Desugar+import DynFlags (HasDynFlags(..))+import FastString+import GHC+import GhcMonad+import Name+import NameSet+import Outputable+import SrcLoc+import TcHsSyn+import Var++-- | Info about a module. This information is generated every time a+-- module is loaded.+data ModInfo = ModInfo+ { modinfoSummary :: !ModSummary+ -- ^ Summary generated by GHC. Can be used to access more+ -- information about the module.+ , modinfoSpans :: [SpanInfo]+ -- ^ Generated set of information about all spans in the+ -- module that correspond to some kind of identifier for+ -- which there will be type info and/or location info.+ , modinfoInfo :: !ModuleInfo+ -- ^ Again, useful from GHC for accessing information+ -- (exports, instances, scope) from a module.+ , modinfoLastUpdate :: !UTCTime+ }++-- | Type of some span of source code. Most of these fields are+-- unboxed but Haddock doesn't show that.+data SpanInfo = SpanInfo+ { spaninfoSrcSpan :: {-# UNPACK #-} !RealSrcSpan+ -- ^ The span we associate information with+ , spaninfoType :: !(Maybe Type)+ -- ^ The 'Type' associated with the span+ , spaninfoVar :: !(Maybe Id)+ -- ^ The actual 'Var' associated with the span, if+ -- any. This can be useful for accessing a variety of+ -- information about the identifier such as module,+ -- locality, definition location, etc.+ }++-- | Test whether second span is contained in (or equal to) first span.+-- This is basically 'containsSpan' for 'SpanInfo'+containsSpanInfo :: SpanInfo -> SpanInfo -> Bool+containsSpanInfo = containsSpan `on` spaninfoSrcSpan++-- | Filter all 'SpanInfo' which are contained in 'SpanInfo'+spaninfosWithin :: [SpanInfo] -> SpanInfo -> [SpanInfo]+spaninfosWithin spans' si = filter (si `containsSpanInfo`) spans'++-- | Construct a 'SpanInfo' from a 'RealSrcSpan' and optionally a+-- 'Type' and an 'Id' (for 'spaninfoType' and 'spaninfoVar'+-- respectively)+spanInfoFromRealSrcSpan :: RealSrcSpan -> Maybe Type -> Maybe Id -> SpanInfo+spanInfoFromRealSrcSpan spn mty mvar =+ SpanInfo spn mty mvar++-- | Convenience wrapper around 'spanInfoFromRealSrcSpan' which needs+-- only a 'RealSrcSpan'+spanInfoFromRealSrcSpan' :: RealSrcSpan -> SpanInfo+spanInfoFromRealSrcSpan' s = spanInfoFromRealSrcSpan s Nothing Nothing++-- | Convenience wrapper around 'srcSpanFile' which results in a 'FilePath'+srcSpanFilePath :: RealSrcSpan -> FilePath+srcSpanFilePath = unpackFS . srcSpanFile++-- | Try to find the location of the given identifier at the given+-- position in the module.+findLoc :: GhcMonad m+ => Map ModuleName ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT SDoc m (ModInfo,Name,SrcSpan)+findLoc infos span0 string = do+ name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $+ guessModule infos (srcSpanFilePath span0)++ info <- maybeToExceptT "No module info for current file! Try loading it?" $+ MaybeT $ pure $ M.lookup name infos++ name' <- findName infos span0 info string++ case getSrcSpan name' of+ UnhelpfulSpan{} -> do+ throwE ("Found a name, but no location information." <+>+ "The module is:" <+>+ maybe "<unknown>" (ppr . moduleName)+ (nameModule_maybe name'))++ span' -> return (info,name',span')++-- | Find any uses of the given identifier in the codebase.+findNameUses :: (GhcMonad m)+ => Map ModuleName ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT SDoc m [SrcSpan]+findNameUses infos span0 string =+ locToSpans <$> findLoc infos span0 string+ where+ locToSpans (modinfo,name',span') =+ stripSurrounding (span' : map toSrcSpan spans)+ where+ toSrcSpan = RealSrcSpan . spaninfoSrcSpan+ spans = filter ((== Just name') . fmap getName . spaninfoVar)+ (modinfoSpans modinfo)++-- | Filter out redundant spans which surround/contain other spans.+stripSurrounding :: [SrcSpan] -> [SrcSpan]+stripSurrounding xs = filter (not . isRedundant) xs+ where+ isRedundant x = any (x `strictlyContains`) xs++ (RealSrcSpan s1) `strictlyContains` (RealSrcSpan s2)+ = s1 /= s2 && s1 `containsSpan` s2+ _ `strictlyContains` _ = False++-- | Try to resolve the name located at the given position, or+-- otherwise resolve based on the current module's scope.+findName :: GhcMonad m+ => Map ModuleName ModInfo+ -> RealSrcSpan+ -> ModInfo+ -> String+ -> ExceptT SDoc m Name+findName infos span0 mi string =+ case resolveName (modinfoSpans mi) (spanInfoFromRealSrcSpan' span0) of+ Nothing -> tryExternalModuleResolution+ Just name ->+ case getSrcSpan name of+ UnhelpfulSpan {} -> tryExternalModuleResolution+ RealSrcSpan {} -> return (getName name)+ where+ tryExternalModuleResolution =+ case find (matchName $ mkFastString string)+ (fromMaybe [] (modInfoTopLevelScope (modinfoInfo mi))) of+ Nothing -> throwE "Couldn't resolve to any modules."+ Just imported -> resolveNameFromModule infos imported++ matchName :: FastString -> Name -> Bool+ matchName str name =+ str ==+ occNameFS (getOccName name)++-- | Try to resolve the name from another (loaded) module's exports.+resolveNameFromModule :: GhcMonad m+ => Map ModuleName ModInfo+ -> Name+ -> ExceptT SDoc m Name+resolveNameFromModule infos name = do+ modL <- maybe (throwE $ "No module for" <+> ppr name) return $+ nameModule_maybe name++ info <- maybe (throwE (ppr (moduleUnitId modL) <> ":" <>+ ppr modL)) return $+ M.lookup (moduleName modL) infos++ maybe (throwE "No matching export in any local modules.") return $+ find (matchName name) (modInfoExports (modinfoInfo info))+ where+ matchName :: Name -> Name -> Bool+ matchName x y = occNameFS (getOccName x) ==+ occNameFS (getOccName y)++-- | Try to resolve the type display from the given span.+resolveName :: [SpanInfo] -> SpanInfo -> Maybe Var+resolveName spans' si = listToMaybe $ mapMaybe spaninfoVar $+ reverse spans' `spaninfosWithin` si++-- | Try to find the type of the given span.+findType :: GhcMonad m+ => Map ModuleName ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT SDoc m (ModInfo, Type)+findType infos span0 string = do+ name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $+ guessModule infos (srcSpanFilePath span0)++ info <- maybeToExceptT "No module info for current file! Try loading it?" $+ MaybeT $ pure $ M.lookup name infos++ case resolveType (modinfoSpans info) (spanInfoFromRealSrcSpan' span0) of+ Nothing -> (,) info <$> lift (exprType TM_Inst string)+ Just ty -> return (info, ty)+ where+ -- | Try to resolve the type display from the given span.+ resolveType :: [SpanInfo] -> SpanInfo -> Maybe Type+ resolveType spans' si = listToMaybe $ mapMaybe spaninfoType $+ reverse spans' `spaninfosWithin` si++-- | Guess a module name from a file path.+guessModule :: GhcMonad m+ => Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName+guessModule infos fp = do+ target <- lift $ guessTarget fp Nothing+ case targetId target of+ TargetModule mn -> return mn+ TargetFile fp' _ -> guessModule' fp'+ where+ guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName+ guessModule' fp' = case findModByFp fp' of+ Just mn -> return mn+ Nothing -> do+ fp'' <- liftIO (makeRelativeToCurrentDirectory fp')++ target' <- lift $ guessTarget fp'' Nothing+ case targetId target' of+ TargetModule mn -> return mn+ _ -> MaybeT . pure $ findModByFp fp''++ findModByFp :: FilePath -> Maybe ModuleName+ findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos)+ where+ mifp :: (ModuleName, ModInfo) -> Maybe FilePath+ mifp = ml_hs_file . ms_location . modinfoSummary . snd+++-- | Collect type info data for the loaded modules.+collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]+ -> m (Map ModuleName ModInfo)+collectInfo ms loaded = do+ df <- getDynFlags+ liftIO (filterM cacheInvalid loaded) >>= \case+ [] -> return ms+ invalidated -> do+ liftIO (putStrLn ("Collecting type info for " +++ show (length invalidated) +++ " module(s) ... "))++ foldM (go df) ms invalidated+ where+ go df m name = do { info <- getModInfo name; return (M.insert name info m) }+ `gcatch`+ (\(e :: SomeException) -> do+ liftIO $ putStrLn+ $ showSDocForUser df alwaysQualify+ $ "Error while getting type info from" <+>+ ppr name <> ":" <+> text (show e)+ return m)++ cacheInvalid name = case M.lookup name ms of+ Nothing -> return True+ Just mi -> do+ let fp = ml_obj_file (ms_location (modinfoSummary mi))+ last' = modinfoLastUpdate mi+ exists <- doesFileExist fp+ if exists+ then (> last') <$> getModificationTime fp+ else return True++-- | Get info about the module: summary, types, etc.+getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo+getModInfo name = do+ m <- getModSummary name+ p <- parseModule m+ typechecked <- typecheckModule p+ allTypes <- processAllTypeCheckedModule typechecked+ let i = tm_checked_module_info typechecked+ now <- liftIO getCurrentTime+ return (ModInfo m allTypes i now)++-- | Get ALL source spans in the module.+processAllTypeCheckedModule :: forall m . GhcMonad m => TypecheckedModule+ -> m [SpanInfo]+processAllTypeCheckedModule tcm = do+ bts <- mapM getTypeLHsBind $ listifyAllSpans tcs+ ets <- mapM getTypeLHsExpr $ listifyAllSpans tcs+ pts <- mapM getTypeLPat $ listifyAllSpans tcs+ return $ mapMaybe toSpanInfo+ $ sortBy cmpSpan+ $ catMaybes (bts ++ ets ++ pts)+ where+ tcs = tm_typechecked_source tcm++ -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's+ getTypeLHsBind :: LHsBind Id -> m (Maybe (Maybe Id,SrcSpan,Type))+ getTypeLHsBind (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _typ _})+ = pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid))+ getTypeLHsBind _ = pure Nothing++ -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's+ getTypeLHsExpr :: LHsExpr Id -> m (Maybe (Maybe Id,SrcSpan,Type))+ getTypeLHsExpr e = do+ hs_env <- getSession+ (_,mbe) <- liftIO $ deSugarExpr hs_env e+ return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe+ where+ mid :: Maybe Id+ mid | HsVar (L _ i) <- unwrapVar (unLoc e) = Just i+ | otherwise = Nothing++ unwrapVar (HsWrap _ var) = var+ unwrapVar e' = e'++ -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's+ getTypeLPat :: LPat Id -> m (Maybe (Maybe Id,SrcSpan,Type))+ getTypeLPat (L spn pat) =+ pure (Just (getMaybeId pat,spn,hsPatType pat))+ where+ getMaybeId (VarPat (L _ vid)) = Just vid+ getMaybeId _ = Nothing++ -- | Get ALL source spans in the source.+ listifyAllSpans :: Typeable a => TypecheckedSource -> [Located a]+ listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x]))+ where+ p (L spn _) = isGoodSrcSpan spn++ -- | Variant of @syb@'s @everything@ (which summarises all nodes+ -- in top-down, left-to-right order) with a stop-condition on 'NameSet's+ everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r+ everythingAllSpans k z f x+ | (False `mkQ` (const True :: NameSet -> Bool)) x = z+ | otherwise = foldl k (f x) (gmapQ (everythingAllSpans k z f) x)++ cmpSpan (_,a,_) (_,b,_)+ | a `isSubspanOf` b = LT+ | b `isSubspanOf` a = GT+ | otherwise = EQ++ -- | Pretty print the types into a 'SpanInfo'.+ toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo+ toSpanInfo (n,RealSrcSpan spn,typ)+ = Just $ spanInfoFromRealSrcSpan spn (Just typ) n+ toSpanInfo _ = Nothing++-- helper stolen from @syb@ package+type GenericQ r = forall a. Data a => a -> r++mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r+(r `mkQ` br) a = maybe r br (cast a)
+ src-bin-821/Clash/GHCi/UI/Monad.hs view
@@ -0,0 +1,454 @@+{-# LANGUAGE CPP, FlexibleInstances, UnboxedTuples, MagicHash #-}+{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}+-- -fno-cse is needed for GLOBAL_VAR's to behave properly++-----------------------------------------------------------------------------+--+-- Monadery code used in InteractiveUI+--+-- (c) The GHC Team 2005-2006+--+-----------------------------------------------------------------------------++module Clash.GHCi.UI.Monad (+ GHCi(..), startGHCi,+ GHCiState(..), setGHCiState, getGHCiState, modifyGHCiState,+ GHCiOption(..), isOptionSet, setOption, unsetOption,+ Command(..),+ PromptFunction,+ BreakLocation(..),+ TickArray,+ getDynFlags,++ runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs,++ printForUserNeverQualify, printForUserModInfo,+ printForUser, printForUserPartWay, prettyLocations,+ initInterpBuffering,+ turnOffBuffering, turnOffBuffering_,+ flushInterpBuffers,+ mkEvalWrapper+ ) where++#include "../HsVersions.h"++import Clash.GHCi.UI.Info (ModInfo)+import qualified GHC+import GhcMonad hiding (liftIO)+import Outputable hiding (printForUser, printForUserPartWay)+import qualified Outputable+import DynFlags+import FastString+import HscTypes+import SrcLoc+import Module+import GHCi+import GHCi.RemoteTypes+import HsSyn (ImportDecl)+import RdrName (RdrName)++import Exception+import Numeric+import Data.Array+import Data.IORef+import Data.Time+import System.Environment+import System.IO+import Control.Monad++import System.Console.Haskeline (CompletionFunc, InputT)+import qualified System.Console.Haskeline as Haskeline+import Control.Monad.Trans.Class+import Control.Monad.IO.Class+import Data.Map.Strict (Map)++-----------------------------------------------------------------------------+-- GHCi monad++data GHCiState = GHCiState+ {+ progname :: String,+ args :: [String],+ evalWrapper :: ForeignHValue, -- ^ of type @IO a -> IO a@+ prompt :: PromptFunction,+ prompt_cont :: PromptFunction,+ editor :: String,+ stop :: String,+ options :: [GHCiOption],+ line_number :: !Int, -- ^ input line+ break_ctr :: !Int,+ breaks :: ![(Int, BreakLocation)],+ tickarrays :: ModuleEnv TickArray,+ -- ^ 'tickarrays' caches the 'TickArray' for loaded modules,+ -- so that we don't rebuild it each time the user sets+ -- a breakpoint.+ ghci_commands :: [Command],+ -- ^ available ghci commands+ ghci_macros :: [Command],+ -- ^ user-defined macros+ last_command :: Maybe Command,+ -- ^ @:@ at the GHCi prompt repeats the last command, so we+ -- remember it here+ cmdqueue :: [String],++ remembered_ctx :: [InteractiveImport],+ -- ^ The imports that the user has asked for, via import+ -- declarations and :module commands. This list is+ -- persistent over :reloads (but any imports for modules+ -- that are not loaded are temporarily ignored). After a+ -- :load, all the home-package imports are stripped from+ -- this list.+ --+ -- See bugs #2049, #1873, #1360++ transient_ctx :: [InteractiveImport],+ -- ^ An import added automatically after a :load, usually of+ -- the most recently compiled module. May be empty if+ -- there are no modules loaded. This list is replaced by+ -- :load, :reload, and :add. In between it may be modified+ -- by :module.++ extra_imports :: [ImportDecl RdrName],+ -- ^ These are "always-on" imports, added to the+ -- context regardless of what other imports we have.+ -- This is useful for adding imports that are required+ -- by setGHCiMonad. Be careful adding things here:+ -- you can create ambiguities if these imports overlap+ -- with other things in scope.+ --+ -- NB. although this is not currently used by GHCi itself,+ -- it was added to support other front-ends that are based+ -- on the GHCi code. Potentially we could also expose+ -- this functionality via GHCi commands.++ prelude_imports :: [ImportDecl RdrName],+ -- ^ These imports are added to the context when+ -- -XImplicitPrelude is on and we don't have a *-module+ -- in the context. They can also be overridden by another+ -- import for the same module, e.g.+ -- "import Prelude hiding (map)"++ ghc_e :: Bool, -- ^ True if this is 'ghc -e' (or runghc)++ short_help :: String,+ -- ^ help text to display to a user+ long_help :: String,+ lastErrorLocations :: IORef [(FastString, Int)],++ mod_infos :: !(Map ModuleName ModInfo),++ flushStdHandles :: ForeignHValue,+ -- ^ @hFlush stdout; hFlush stderr@ in the interpreter+ noBuffering :: ForeignHValue+ -- ^ @hSetBuffering NoBuffering@ for stdin/stdout/stderr+ }++type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]++-- | A GHCi command+data Command+ = Command+ { cmdName :: String+ -- ^ Name of GHCi command (e.g. "exit")+ , cmdAction :: String -> InputT GHCi Bool+ -- ^ The 'Bool' value denotes whether to exit GHCi+ , cmdHidden :: Bool+ -- ^ Commands which are excluded from default completion+ -- and @:help@ summary. This is usually set for commands not+ -- useful for interactive use but rather for IDEs.+ , cmdCompletionFunc :: CompletionFunc GHCi+ -- ^ 'CompletionFunc' for arguments+ }++type PromptFunction = [String]+ -> Int+ -> GHCi SDoc++data GHCiOption+ = ShowTiming -- show time/allocs after evaluation+ | ShowType -- show the type of expressions+ | RevertCAFs -- revert CAFs after every evaluation+ | Multiline -- use multiline commands+ | CollectInfo -- collect and cache information about+ -- modules after load+ deriving Eq++data BreakLocation+ = BreakLocation+ { breakModule :: !GHC.Module+ , breakLoc :: !SrcSpan+ , breakTick :: {-# UNPACK #-} !Int+ , onBreakCmd :: String+ }++instance Eq BreakLocation where+ loc1 == loc2 = breakModule loc1 == breakModule loc2 &&+ breakTick loc1 == breakTick loc2++prettyLocations :: [(Int, BreakLocation)] -> SDoc+prettyLocations [] = text "No active breakpoints."+prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs++instance Outputable BreakLocation where+ ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>+ if null (onBreakCmd loc)+ then Outputable.empty+ else doubleQuotes (text (onBreakCmd loc))++recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)+recordBreak brkLoc = do+ st <- getGHCiState+ let oldActiveBreaks = breaks st+ -- don't store the same break point twice+ case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of+ (nm:_) -> return (True, nm)+ [] -> do+ let oldCounter = break_ctr st+ newCounter = oldCounter + 1+ setGHCiState $ st { break_ctr = newCounter,+ breaks = (oldCounter, brkLoc) : oldActiveBreaks+ }+ return (False, oldCounter)++newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }++reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a+reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s++reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a+reifyGHCi f = GHCi f'+ where+ -- f' :: IORef GHCiState -> Ghc a+ f' gs = reifyGhc (f'' gs)+ -- f'' :: IORef GHCiState -> Session -> IO a+ f'' gs s = f (s, gs)++startGHCi :: GHCi a -> GHCiState -> Ghc a+startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref++instance Functor GHCi where+ fmap = liftM++instance Applicative GHCi where+ pure a = GHCi $ \_ -> pure a+ (<*>) = ap++instance Monad GHCi where+ (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s++class HasGhciState m where+ getGHCiState :: m GHCiState+ setGHCiState :: GHCiState -> m ()+ modifyGHCiState :: (GHCiState -> GHCiState) -> m ()++instance HasGhciState GHCi where+ getGHCiState = GHCi $ \r -> liftIO $ readIORef r+ setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s+ modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f++instance (MonadTrans t, Monad m, HasGhciState m) => HasGhciState (t m) where+ getGHCiState = lift getGHCiState+ setGHCiState = lift . setGHCiState+ modifyGHCiState = lift . modifyGHCiState++liftGhc :: Ghc a -> GHCi a+liftGhc m = GHCi $ \_ -> m++instance MonadIO GHCi where+ liftIO = liftGhc . liftIO++instance HasDynFlags GHCi where+ getDynFlags = getSessionDynFlags++instance GhcMonad GHCi where+ setSession s' = liftGhc $ setSession s'+ getSession = liftGhc $ getSession++instance HasDynFlags (InputT GHCi) where+ getDynFlags = lift getDynFlags++instance GhcMonad (InputT GHCi) where+ setSession = lift . setSession+ getSession = lift getSession++instance ExceptionMonad GHCi where+ gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)+ gmask f =+ GHCi $ \s -> gmask $ \io_restore ->+ let+ g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')+ in+ unGHCi (f g_restore) s++instance Haskeline.MonadException Ghc where+ controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let+ run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)+ in fmap (flip unGhc s) $ f run'++instance Haskeline.MonadException GHCi where+ controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let+ run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)+ in fmap (flip unGHCi s) $ f run'++instance ExceptionMonad (InputT GHCi) where+ gcatch = Haskeline.catch+ gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)++isOptionSet :: GHCiOption -> GHCi Bool+isOptionSet opt+ = do st <- getGHCiState+ return (opt `elem` options st)++setOption :: GHCiOption -> GHCi ()+setOption opt+ = do st <- getGHCiState+ setGHCiState (st{ options = opt : filter (/= opt) (options st) })++unsetOption :: GHCiOption -> GHCi ()+unsetOption opt+ = do st <- getGHCiState+ setGHCiState (st{ options = filter (/= opt) (options st) })++printForUserNeverQualify :: GhcMonad m => SDoc -> m ()+printForUserNeverQualify doc = do+ dflags <- getDynFlags+ liftIO $ Outputable.printForUser dflags stdout neverQualify doc++printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()+printForUserModInfo info doc = do+ dflags <- getDynFlags+ mUnqual <- GHC.mkPrintUnqualifiedForModule info+ unqual <- maybe GHC.getPrintUnqual return mUnqual+ liftIO $ Outputable.printForUser dflags stdout unqual doc++printForUser :: GhcMonad m => SDoc -> m ()+printForUser doc = do+ unqual <- GHC.getPrintUnqual+ dflags <- getDynFlags+ liftIO $ Outputable.printForUser dflags stdout unqual doc++printForUserPartWay :: SDoc -> GHCi ()+printForUserPartWay doc = do+ unqual <- GHC.getPrintUnqual+ dflags <- getDynFlags+ liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc++-- | Run a single Haskell expression+runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult)+runStmt expr step = do+ st <- getGHCiState+ GHC.handleSourceError (\e -> do GHC.printException e; return Nothing) $ do+ let opts = GHC.execOptions+ { GHC.execSourceFile = progname st+ , GHC.execLineNumber = line_number st+ , GHC.execSingleStep = step+ , GHC.execWrap = \fhv -> EvalApp (EvalThis (evalWrapper st))+ (EvalThis fhv) }+ Just <$> GHC.execStmt expr opts++runDecls :: String -> GHCi (Maybe [GHC.Name])+runDecls decls = do+ st <- getGHCiState+ reifyGHCi $ \x ->+ withProgName (progname st) $+ withArgs (args st) $+ reflectGHCi x $ do+ GHC.handleSourceError (\e -> do GHC.printException e;+ return Nothing) $ do+ r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls+ return (Just r)++resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.ExecResult+resume canLogSpan step = do+ st <- getGHCiState+ reifyGHCi $ \x ->+ withProgName (progname st) $+ withArgs (args st) $+ reflectGHCi x $ do+ GHC.resumeExec canLogSpan step++-- --------------------------------------------------------------------------+-- timing & statistics++timeIt :: (a -> Maybe Integer) -> InputT GHCi a -> InputT GHCi a+timeIt getAllocs action+ = do b <- lift $ isOptionSet ShowTiming+ if not b+ then action+ else do time1 <- liftIO $ getCurrentTime+ a <- action+ let allocs = getAllocs a+ time2 <- liftIO $ getCurrentTime+ dflags <- getDynFlags+ let period = time2 `diffUTCTime` time1+ liftIO $ printTimes dflags allocs (realToFrac period)+ return a++printTimes :: DynFlags -> Maybe Integer -> Double -> IO ()+printTimes dflags mallocs secs+ = do let secs_str = showFFloat (Just 2) secs+ putStrLn (showSDoc dflags (+ parens (text (secs_str "") <+> text "secs" <> comma <+>+ case mallocs of+ Nothing -> empty+ Just allocs ->+ text (separateThousands allocs) <+> text "bytes")))+ where+ separateThousands n = reverse . sep . reverse . show $ n+ where sep n'+ | length n' <= 3 = n'+ | otherwise = take 3 n' ++ "," ++ sep (drop 3 n')++-----------------------------------------------------------------------------+-- reverting CAFs++revertCAFs :: GHCi ()+revertCAFs = do+ liftIO rts_revertCAFs+ s <- getGHCiState+ when (not (ghc_e s)) turnOffBuffering+ -- Have to turn off buffering again, because we just+ -- reverted stdout, stderr & stdin to their defaults.++foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()+ -- Make it "safe", just in case++-----------------------------------------------------------------------------+-- To flush buffers for the *interpreted* computation we need+-- to refer to *its* stdout/stderr handles++-- | Compile "hFlush stdout; hFlush stderr" once, so we can use it repeatedly+initInterpBuffering :: Ghc (ForeignHValue, ForeignHValue)+initInterpBuffering = do+ nobuf <- GHC.compileExprRemote $+ "do { System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering; " +++ " System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering; " +++ " System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering }"+ flush <- GHC.compileExprRemote $+ "do { System.IO.hFlush System.IO.stdout; " +++ " System.IO.hFlush System.IO.stderr }"+ return (nobuf, flush)++-- | Invoke "hFlush stdout; hFlush stderr" in the interpreter+flushInterpBuffers :: GHCi ()+flushInterpBuffers = do+ st <- getGHCiState+ hsc_env <- GHC.getSession+ liftIO $ evalIO hsc_env (flushStdHandles st)++-- | Turn off buffering for stdin, stdout, and stderr in the interpreter+turnOffBuffering :: GHCi ()+turnOffBuffering = do+ st <- getGHCiState+ turnOffBuffering_ (noBuffering st)++turnOffBuffering_ :: GhcMonad m => ForeignHValue -> m ()+turnOffBuffering_ fhv = do+ hsc_env <- getSession+ liftIO $ evalIO hsc_env fhv++mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue+mkEvalWrapper progname args =+ GHC.compileExprRemote $+ "\\m -> System.Environment.withProgName " ++ show progname +++ "(System.Environment.withArgs " ++ show args ++ " m)"
+ src-bin-821/Clash/GHCi/UI/Tags.hs view
@@ -0,0 +1,215 @@+-----------------------------------------------------------------------------+--+-- GHCi's :ctags and :etags commands+--+-- (c) The GHC Team 2005-2007+--+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+module Clash.GHCi.UI.Tags (+ createCTagsWithLineNumbersCmd,+ createCTagsWithRegExesCmd,+ createETagsFileCmd+) where++import Exception+import GHC+import Clash.GHCi.UI.Monad+import Outputable++-- ToDo: figure out whether we need these, and put something appropriate+-- into the GHC API instead+import Name (nameOccName)+import OccName (pprOccName)+import ConLike+import MonadUtils++import Data.Function+import Data.Maybe+import Data.Ord+import DriverPhases+import Panic+import Data.List+import Control.Monad+import System.Directory+import System.IO+import System.IO.Error++-----------------------------------------------------------------------------+-- create tags file for currently loaded modules.++createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd,+ createETagsFileCmd :: String -> GHCi ()++createCTagsWithLineNumbersCmd "" =+ ghciCreateTagsFile CTagsWithLineNumbers "tags"+createCTagsWithLineNumbersCmd file =+ ghciCreateTagsFile CTagsWithLineNumbers file++createCTagsWithRegExesCmd "" =+ ghciCreateTagsFile CTagsWithRegExes "tags"+createCTagsWithRegExesCmd file =+ ghciCreateTagsFile CTagsWithRegExes file++createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"+createETagsFileCmd file = ghciCreateTagsFile ETags file++data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes++ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()+ghciCreateTagsFile kind file = do+ createTagsFile kind file++-- ToDo:+-- - remove restriction that all modules must be interpreted+-- (problem: we don't know source locations for entities unless+-- we compiled the module.+--+-- - extract createTagsFile so it can be used from the command-line+-- (probably need to fix first problem before this is useful).+--+createTagsFile :: TagsKind -> FilePath -> GHCi ()+createTagsFile tagskind tagsFile = do+ graph <- GHC.getModuleGraph+ mtags <- mapM listModuleTags (map GHC.ms_mod graph)+ either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags+ case either_res of+ Left e -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e+ Right _ -> return ()+++listModuleTags :: GHC.Module -> GHCi [TagInfo]+listModuleTags m = do+ is_interpreted <- GHC.moduleIsInterpreted m+ -- should we just skip these?+ when (not is_interpreted) $+ let mName = GHC.moduleNameString (GHC.moduleName m) in+ throwGhcException (CmdLineError ("module '" ++ mName ++ "' is not interpreted"))+ mbModInfo <- GHC.getModuleInfo m+ case mbModInfo of+ Nothing -> return []+ Just mInfo -> do+ dflags <- getDynFlags+ mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo+ let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual+ let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo+ let localNames = filter ((m==) . nameModule) names+ mbTyThings <- mapM GHC.lookupName localNames+ return $! [ tagInfo dflags unqual exported kind name realLoc+ | tyThing <- catMaybes mbTyThings+ , let name = getName tyThing+ , let exported = GHC.modInfoIsExportedName mInfo name+ , let kind = tyThing2TagKind tyThing+ , let loc = srcSpanStart (nameSrcSpan name)+ , RealSrcLoc realLoc <- [loc]+ ]++ where+ tyThing2TagKind (AnId _) = 'v'+ tyThing2TagKind (AConLike RealDataCon{}) = 'd'+ tyThing2TagKind (AConLike PatSynCon{}) = 'p'+ tyThing2TagKind (ATyCon _) = 't'+ tyThing2TagKind (ACoAxiom _) = 'x'+++data TagInfo = TagInfo+ { tagExported :: Bool -- is tag exported+ , tagKind :: Char -- tag kind+ , tagName :: String -- tag name+ , tagFile :: String -- file name+ , tagLine :: Int -- line number+ , tagCol :: Int -- column number+ , tagSrcInfo :: Maybe (String,Integer) -- source code line and char offset+ }+++-- get tag info, for later translation into Vim or Emacs style+tagInfo :: DynFlags -> PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc+ -> TagInfo+tagInfo dflags unqual exported kind name loc+ = TagInfo exported kind+ (showSDocForUser dflags unqual $ pprOccName (nameOccName name))+ (showSDocForUser dflags unqual $ ftext (srcLocFile loc))+ (srcLocLine loc) (srcLocCol loc) Nothing++-- throw an exception when someone tries to overwrite existing source file (fix for #10989)+writeTagsSafely :: FilePath -> String -> IO ()+writeTagsSafely file str = do+ dfe <- doesFileExist file+ if dfe && isSourceFilename file+ then throwGhcException (CmdLineError (file ++ " is existing source file. " +++ "Please specify another file name to store tags data"))+ else writeFile file str++collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())+-- ctags style with the Ex exresion being just the line number, Vim et al+collateAndWriteTags CTagsWithLineNumbers file tagInfos = do+ let tags = unlines $ sort $ map showCTag tagInfos+ tryIO (writeTagsSafely file tags)++-- ctags style with the Ex exresion being a regex searching the line, Vim et al+collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al+ tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos+ let tags = unlines $ sort $ map showCTag $concat tagInfoGroups+ tryIO (writeTagsSafely file tags)++collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs+ tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos+ let tagGroups = map processGroup tagInfoGroups+ tryIO (writeTagsSafely file $ concat tagGroups)++ where+ processGroup [] = throwGhcException (CmdLineError "empty tag file group??")+ processGroup group@(tagInfo:_) =+ let tags = unlines $ map showETag group in+ "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags+++makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]]+makeTagGroupsWithSrcInfo tagInfos = do+ let groups = groupBy ((==) `on` tagFile) $ sortBy (comparing tagFile) tagInfos+ mapM addTagSrcInfo groups++ where+ addTagSrcInfo [] = throwGhcException (CmdLineError "empty tag file group??")+ addTagSrcInfo group@(tagInfo:_) = do+ file <- readFile $tagFile tagInfo+ let sortedGroup = sortBy (comparing tagLine) group+ return $ perFile sortedGroup 1 0 $ lines file++ perFile allTags@(tag:tags) cnt pos allLs@(l:ls)+ | tagLine tag > cnt =+ perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls+ | tagLine tag == cnt =+ tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs+ perFile _ _ _ _ = []+++-- ctags format, for Vim et al+showCTag :: TagInfo -> String+showCTag ti =+ tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" +++ tagKind ti : ( if tagExported ti then "" else "\tfile:" )++ where+ tagCmd =+ case tagSrcInfo ti of+ Nothing -> show $tagLine ti+ Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/"++ where+ escapeSlashes '/' r = '\\' : '/' : r+ escapeSlashes '\\' r = '\\' : '\\' : r+ escapeSlashes c r = c : r+++-- etags format, for Emacs/XEmacs+showETag :: TagInfo -> String+showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo,+ tagSrcInfo = Just (srcLine,charPos) }+ = take (colNo - 1) srcLine ++ tag+ ++ "\x7f" ++ tag+ ++ "\x01" ++ show lineNo+ ++ "," ++ show charPos+showETag _ = throwGhcException (CmdLineError "missing source file info in showETag")
+ src-bin-821/Clash/Main.hs view
@@ -0,0 +1,1016 @@+{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables, TupleSections #-}+{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}++-----------------------------------------------------------------------------+--+-- GHC Driver program+--+-- (c) The University of Glasgow 2005+--+-----------------------------------------------------------------------------++module Clash.Main (defaultMain) where++-- For Int/Word size+#include "MachDeps.h"++-- The official GHC API+import qualified GHC+import GHC ( -- DynFlags(..), HscTarget(..),+ -- GhcMode(..), GhcLink(..),+ Ghc, GhcMonad(..),+ LoadHowMuch(..) )+import CmdLineParser++-- Implementations of the various modes (--show-iface, mkdependHS. etc.)+import LoadIface ( showIface )+import HscMain ( newHscEnv )+import DriverPipeline ( oneShot, compileFile )+import DriverMkDepend ( doMkDependHS )+import DriverBkp ( doBackpack )+#if defined(GHCI)+import Clash.GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )+#endif++-- Frontend plugins+#if defined(GHCI)+import DynamicLoading ( loadFrontendPlugin )+import Plugins+#else+import DynamicLoading ( pluginError )+#endif+import Module ( ModuleName )+++-- Various other random stuff that we need+import Config+import Constants+import HscTypes+import Packages ( pprPackages, pprPackagesSimple )+import DriverPhases+import BasicTypes ( failed )+import DynFlags+import ErrUtils+import FastString+import Outputable+import SrcLoc+import Util+import Panic+import UniqSupply+import MonadUtils ( liftIO )++-- Imports for --abi-hash+import LoadIface ( loadUserInterface )+import Module ( mkModuleName )+import Finder ( findImportedModule, cannotFindModule )+import TcRnMonad ( initIfaceCheck )+import Binary ( openBinMem, put_ )+import BinFingerprint ( fingerprintBinMem )++-- Standard Haskell libraries+import System.IO+import System.Environment+import System.Exit+import System.FilePath+import Control.Monad+import Data.Char+import Data.List+import Data.Maybe++-- clash additions+import Paths_clash_ghc+import Clash.GHCi.UI (makeHDL)+import Exception (gcatch)+import Data.IORef (IORef, newIORef, readIORef)+import qualified Data.Version (showVersion)++import qualified Clash.Backend+import Clash.Backend.SystemVerilog (SystemVerilogState)+import Clash.Backend.VHDL (VHDLState)+import Clash.Backend.Verilog (VerilogState)+import Clash.Driver.Types (ClashOpts (..), defClashOpts)+import Clash.GHC.ClashFlags+import Clash.Netlist.BlackBox.Types (HdlSyn (..))+import Clash.Util (clashLibVersion)+import Clash.GHC.LoadModules (ghcLibDir, wantedLanguageExtensions)+import Clash.GHC.Util (handleClashException)++-----------------------------------------------------------------------------+-- ToDo:++-- time commands when run with -v+-- user ways+-- Win32 support: proper signal handling+-- reading the package configuration file is too slow+-- -K<size>++-----------------------------------------------------------------------------+-- GHC's command-line interface++defaultMain :: [String] -> IO ()+defaultMain = flip withArgs $ do+ initGCStatistics -- See Note [-Bsymbolic and hooks]+ hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering++ -- Handle GHC-specific character encoding flags, allowing us to control how+ -- GHC produces output regardless of OS.+ env <- getEnvironment+ case lookup "GHC_CHARENC" env of+ Just "UTF-8" -> do+ hSetEncoding stdout utf8+ hSetEncoding stderr utf8+ _ -> do+ -- Avoid GHC erroring out when trying to display unhandled characters+ hSetTranslit stdout+ hSetTranslit stderr++ GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do+ argv0 <- getArgs+ libDir <- ghcLibDir++ let argv1 = map (mkGeneralLocated "on the commandline") argv0+ r <- newIORef defClashOpts+ (argv2, clashFlagWarnings) <- parseClashFlags r argv1++ -- 2. Parse the "mode" flags (--make, --interactive etc.)+ (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2+ let flagWarnings = modeFlagWarnings ++ clashFlagWarnings++ -- If all we want to do is something like showing the version number+ -- then do it now, before we start a GHC session etc. This makes+ -- getting basic information much more resilient.++ -- In particular, if we wait until later before giving the version+ -- number then bootstrapping gets confused, as it tries to find out+ -- what version of GHC it's using before package.conf exists, so+ -- starting the session fails.+ case mode of+ Left preStartupMode ->+ do case preStartupMode of+ ShowSupportedExtensions -> showSupportedExtensions+ ShowVersion -> showVersion+ ShowNumVersion -> putStrLn cProjectVersion+ ShowOptions isInteractive -> showOptions isInteractive+ Right postStartupMode ->+ -- start our GHC session+ GHC.runGhc (Just libDir) $ do++ dflags <- GHC.getSessionDynFlags+ let dflagsExtra = wantedLanguageExtensions dflags++ ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise"+ ghcTyLitExtrPlugin = GHC.mkModuleName "GHC.TypeLits.Extra.Solver"+ ghcTyLitKNPlugin = GHC.mkModuleName "GHC.TypeLits.KnownNat.Solver"+ dflagsExtra1 = dflagsExtra+ { DynFlags.pluginModNames = nub $+ ghcTyLitNormPlugin : ghcTyLitExtrPlugin :+ ghcTyLitKNPlugin :+ DynFlags.pluginModNames dflagsExtra+ }++ case postStartupMode of+ Left preLoadMode ->+ liftIO $ do+ case preLoadMode of+ ShowInfo -> showInfo dflagsExtra1+ ShowGhcUsage -> showGhcUsage dflagsExtra1+ ShowGhciUsage -> showGhciUsage dflagsExtra1+ PrintWithDynFlags f -> putStrLn (f dflagsExtra1)+ Right postLoadMode ->+ main' postLoadMode dflagsExtra1 argv3 flagWarnings r+++main' :: PostLoadMode -> DynFlags -> [Located String] -> [Located String]+ -> IORef ClashOpts+ -> Ghc ()+main' postLoadMode dflags0 args flagWarnings clashOpts = do+ -- set the default GhcMode, HscTarget and GhcLink. The HscTarget+ -- can be further adjusted on a module by module basis, using only+ -- the -fvia-C and -fasm flags. If the default HscTarget is not+ -- HscC or HscAsm, -fvia-C and -fasm have no effect.+ let dflt_target = hscTarget dflags0+ (mode, lang, link)+ = case postLoadMode of+ DoInteractive -> (CompManager, HscInterpreted, LinkInMemory)+ DoEval _ -> (CompManager, HscInterpreted, LinkInMemory)+ DoMake -> (CompManager, dflt_target, LinkBinary)+ DoBackpack -> (CompManager, dflt_target, LinkBinary)+ DoMkDependHS -> (MkDepend, dflt_target, LinkBinary)+ DoAbiHash -> (OneShot, dflt_target, LinkBinary)+ DoVHDL -> (CompManager, HscNothing, NoLink)+ DoVerilog -> (CompManager, HscNothing, NoLink)+ DoSystemVerilog -> (CompManager, HscNothing, NoLink)+ _ -> (OneShot, dflt_target, LinkBinary)++ let dflags1 = dflags0{ ghcMode = mode,+ hscTarget = lang,+ ghcLink = link,+ verbosity = case postLoadMode of+ DoEval _ -> 0+ _other -> 1+ }++ -- turn on -fimplicit-import-qualified for GHCi now, so that it+ -- can be overriden from the command-line+ -- XXX: this should really be in the interactive DynFlags, but+ -- we don't set that until later in interactiveUI+ dflags2 | DoInteractive <- postLoadMode = imp_qual_enabled+ | DoEval _ <- postLoadMode = imp_qual_enabled+ | otherwise = dflags1+ where imp_qual_enabled = dflags1 `gopt_set` Opt_ImplicitImportQualified++ -- The rest of the arguments are "dynamic"+ -- Leftover ones are presumably files+ (dflags3, fileish_args, dynamicFlagWarnings) <-+ GHC.parseDynamicFlags dflags2 args++ let dflags4 = case lang of+ HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) ->+ let platform = targetPlatform dflags3+ dflags3a = updateWays $ dflags3 { ways = interpWays }+ dflags3b = foldl gopt_set dflags3a+ $ concatMap (wayGeneralFlags platform)+ interpWays+ dflags3c = foldl gopt_unset dflags3b+ $ concatMap (wayUnsetGeneralFlags platform)+ interpWays+ in dflags3c+ _ ->+ dflags3++ GHC.prettyPrintGhcErrors dflags4 $ do++ let flagWarnings' = flagWarnings ++ dynamicFlagWarnings++ handleSourceError (\e -> do+ GHC.printException e+ liftIO $ exitWith (ExitFailure 1)) $ do+ liftIO $ handleFlagWarnings dflags4 flagWarnings'++ liftIO $ showBanner postLoadMode dflags4++ let+ -- To simplify the handling of filepaths, we normalise all filepaths right+ -- away - e.g., for win32 platforms, backslashes are converted+ -- into forward slashes.+ normal_fileish_paths = map (normalise . unLoc) fileish_args+ (srcs, objs) = partition_args normal_fileish_paths [] []++ dflags5 = dflags4 { ldInputs = map (FileOption "") objs+ ++ ldInputs dflags4 }++ -- we've finished manipulating the DynFlags, update the session+ _ <- GHC.setSessionDynFlags dflags5+ dflags6 <- GHC.getSessionDynFlags+ hsc_env <- GHC.getSession++ ---------------- Display configuration -----------+ case verbosity dflags6 of+ v | v == 4 -> liftIO $ dumpPackagesSimple dflags6+ | v >= 5 -> liftIO $ dumpPackages dflags6+ | otherwise -> return ()++ liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6)+ ---------------- Final sanity checking -----------+ liftIO $ checkOptions postLoadMode dflags6 srcs objs++ ---------------- Do the business -----------+ handleSourceError (\e -> do+ GHC.printException e+ liftIO $ exitWith (ExitFailure 1)) $ do+ clashOpts' <- liftIO (readIORef clashOpts)+ let clash fun = gcatch (fun clashOpts srcs) (handleClashException dflags6 clashOpts')+ case postLoadMode of+ ShowInterface f -> liftIO $ doShowIface dflags6 f+ DoMake -> doMake srcs+ DoMkDependHS -> doMkDependHS (map fst srcs)+ StopBefore p -> liftIO (oneShot hsc_env p srcs)+ DoInteractive -> ghciUI clashOpts srcs Nothing+ DoEval exprs -> ghciUI clashOpts srcs $ Just $ reverse exprs+ DoAbiHash -> abiHash (map fst srcs)+ ShowPackages -> liftIO $ showPackages dflags6+ DoFrontend f -> doFrontend f srcs+ DoVHDL -> clash makeVHDL+ DoVerilog -> clash makeVerilog+ DoSystemVerilog -> clash makeSystemVerilog+ DoBackpack -> doBackpack (map fst srcs)++ liftIO $ dumpFinalStats dflags6++ghciUI :: IORef ClashOpts -> [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()+#if !defined(GHCI)+ghciUI _ _ _ = throwGhcException (CmdLineError "not built for interactive use")+#else+ghciUI opts = interactiveUI (defaultGhciSettings opts)+#endif++-- -----------------------------------------------------------------------------+-- Splitting arguments into source files and object files. This is where we+-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source+-- file indicating the phase specified by the -x option in force, if any.++partition_args :: [String] -> [(String, Maybe Phase)] -> [String]+ -> ([(String, Maybe Phase)], [String])+partition_args [] srcs objs = (reverse srcs, reverse objs)+partition_args ("-x":suff:args) srcs objs+ | "none" <- suff = partition_args args srcs objs+ | StopLn <- phase = partition_args args srcs (slurp ++ objs)+ | otherwise = partition_args rest (these_srcs ++ srcs) objs+ where phase = startPhase suff+ (slurp,rest) = break (== "-x") args+ these_srcs = zip slurp (repeat (Just phase))+partition_args (arg:args) srcs objs+ | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs+ | otherwise = partition_args args srcs (arg:objs)++ {-+ We split out the object files (.o, .dll) and add them+ to ldInputs for use by the linker.++ The following things should be considered compilation manager inputs:++ - haskell source files (strings ending in .hs, .lhs or other+ haskellish extension),++ - module names (not forgetting hierarchical module names),++ - things beginning with '-' are flags that were not recognised by+ the flag parser, and we want them to generate errors later in+ checkOptions, so we class them as source files (#5921)++ - and finally we consider everything without an extension to be+ a comp manager input, as shorthand for a .hs or .lhs filename.++ Everything else is considered to be a linker object, and passed+ straight through to the linker.+ -}+looks_like_an_input :: String -> Bool+looks_like_an_input m = isSourceFilename m+ || looksLikeModuleName m+ || "-" `isPrefixOf` m+ || not (hasExtension m)++-- -----------------------------------------------------------------------------+-- Option sanity checks++-- | Ensure sanity of options.+--+-- Throws 'UsageError' or 'CmdLineError' if not.+checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()+ -- Final sanity checking before kicking off a compilation (pipeline).+checkOptions mode dflags srcs objs = do+ -- Complain about any unknown flags+ let unknown_opts = [ f | (f@('-':_), _) <- srcs ]+ when (notNull unknown_opts) (unknownFlagsErr unknown_opts)++ when (notNull (filter wayRTSOnly (ways dflags))+ && isInterpretiveMode mode) $+ hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")++ -- -prof and --interactive are not a good combination+ when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays)+ && isInterpretiveMode mode+ && not (gopt Opt_ExternalInterpreter dflags)) $+ do throwGhcException (UsageError+ "-fexternal-interpreter is required when using --interactive with a non-standard way (-prof, -static, or -dynamic).")+ -- -ohi sanity check+ if (isJust (outputHi dflags) &&+ (isCompManagerMode mode || srcs `lengthExceeds` 1))+ then throwGhcException (UsageError "-ohi can only be used when compiling a single source file")+ else do++ -- -o sanity checking+ if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)+ && not (isLinkMode mode))+ then throwGhcException (UsageError "can't apply -o to multiple source files")+ else do++ let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)++ when (not_linking && not (null objs)) $+ hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)++ -- Check that there are some input files+ -- (except in the interactive case)+ if null srcs && (null objs || not_linking) && needsInputsMode mode+ then throwGhcException (UsageError "no input files")+ else do++ case mode of+ StopBefore HCc | hscTarget dflags /= HscC+ -> throwGhcException $ UsageError $+ "the option -C is only available with an unregisterised GHC"+ _ -> return ()++ -- Verify that output files point somewhere sensible.+ verifyOutputFiles dflags++-- Compiler output options++-- Called to verify that the output files point somewhere valid.+--+-- The assumption is that the directory portion of these output+-- options will have to exist by the time 'verifyOutputFiles'+-- is invoked.+--+-- We create the directories for -odir, -hidir, -outputdir etc. ourselves if+-- they don't exist, so don't check for those here (#2278).+verifyOutputFiles :: DynFlags -> IO ()+verifyOutputFiles dflags = do+ let ofile = outputFile dflags+ when (isJust ofile) $ do+ let fn = fromJust ofile+ flg <- doesDirNameExist fn+ when (not flg) (nonExistentDir "-o" fn)+ let ohi = outputHi dflags+ when (isJust ohi) $ do+ let hi = fromJust ohi+ flg <- doesDirNameExist hi+ when (not flg) (nonExistentDir "-ohi" hi)+ where+ nonExistentDir flg dir =+ throwGhcException (CmdLineError ("error: directory portion of " +++ show dir ++ " does not exist (used with " +++ show flg ++ " option.)"))++-----------------------------------------------------------------------------+-- GHC modes of operation++type Mode = Either PreStartupMode PostStartupMode+type PostStartupMode = Either PreLoadMode PostLoadMode++data PreStartupMode+ = ShowVersion -- ghc -V/--version+ | ShowNumVersion -- ghc --numeric-version+ | ShowSupportedExtensions -- ghc --supported-extensions+ | ShowOptions Bool {- isInteractive -} -- ghc --show-options++showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode+showVersionMode = mkPreStartupMode ShowVersion+showNumVersionMode = mkPreStartupMode ShowNumVersion+showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions+showOptionsMode = mkPreStartupMode (ShowOptions False)++mkPreStartupMode :: PreStartupMode -> Mode+mkPreStartupMode = Left++isShowVersionMode :: Mode -> Bool+isShowVersionMode (Left ShowVersion) = True+isShowVersionMode _ = False++isShowNumVersionMode :: Mode -> Bool+isShowNumVersionMode (Left ShowNumVersion) = True+isShowNumVersionMode _ = False++data PreLoadMode+ = ShowGhcUsage -- ghc -?+ | ShowGhciUsage -- ghci -?+ | ShowInfo -- ghc --info+ | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo++showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode+showGhcUsageMode = mkPreLoadMode ShowGhcUsage+showGhciUsageMode = mkPreLoadMode ShowGhciUsage+showInfoMode = mkPreLoadMode ShowInfo++printSetting :: String -> Mode+printSetting k = mkPreLoadMode (PrintWithDynFlags f)+ where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))+ $ lookup k (compilerInfo dflags)++mkPreLoadMode :: PreLoadMode -> Mode+mkPreLoadMode = Right . Left++isShowGhcUsageMode :: Mode -> Bool+isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True+isShowGhcUsageMode _ = False++isShowGhciUsageMode :: Mode -> Bool+isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True+isShowGhciUsageMode _ = False++data PostLoadMode+ = ShowInterface FilePath -- ghc --show-iface+ | DoMkDependHS -- ghc -M+ | StopBefore Phase -- ghc -E | -C | -S+ -- StopBefore StopLn is the default+ | DoMake -- ghc --make+ | DoBackpack -- ghc --backpack foo.bkp+ | DoInteractive -- ghc --interactive+ | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]+ | DoAbiHash -- ghc --abi-hash+ | ShowPackages -- ghc --show-packages+ | DoFrontend ModuleName -- ghc --frontend Plugin.Module+ | DoVHDL -- ghc --vhdl+ | DoVerilog -- ghc --verilog+ | DoSystemVerilog -- ghc --systemverilog++doMkDependHSMode, doMakeMode, doInteractiveMode,+ doAbiHashMode, showPackagesMode, doVHDLMode, doVerilogMode,+ doSystemVerilogMode :: Mode+doMkDependHSMode = mkPostLoadMode DoMkDependHS+doMakeMode = mkPostLoadMode DoMake+doInteractiveMode = mkPostLoadMode DoInteractive+doAbiHashMode = mkPostLoadMode DoAbiHash+showPackagesMode = mkPostLoadMode ShowPackages+doVHDLMode = mkPostLoadMode DoVHDL+doVerilogMode = mkPostLoadMode DoVerilog+doSystemVerilogMode = mkPostLoadMode DoSystemVerilog++showInterfaceMode :: FilePath -> Mode+showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)++stopBeforeMode :: Phase -> Mode+stopBeforeMode phase = mkPostLoadMode (StopBefore phase)++doEvalMode :: String -> Mode+doEvalMode str = mkPostLoadMode (DoEval [str])++doFrontendMode :: String -> Mode+doFrontendMode str = mkPostLoadMode (DoFrontend (mkModuleName str))++doBackpackMode :: Mode+doBackpackMode = mkPostLoadMode DoBackpack++mkPostLoadMode :: PostLoadMode -> Mode+mkPostLoadMode = Right . Right++isDoInteractiveMode :: Mode -> Bool+isDoInteractiveMode (Right (Right DoInteractive)) = True+isDoInteractiveMode _ = False++isStopLnMode :: Mode -> Bool+isStopLnMode (Right (Right (StopBefore StopLn))) = True+isStopLnMode _ = False++isDoMakeMode :: Mode -> Bool+isDoMakeMode (Right (Right DoMake)) = True+isDoMakeMode _ = False++isDoEvalMode :: Mode -> Bool+isDoEvalMode (Right (Right (DoEval _))) = True+isDoEvalMode _ = False++#if defined(GHCI)+isInteractiveMode :: PostLoadMode -> Bool+isInteractiveMode DoInteractive = True+isInteractiveMode _ = False+#endif++-- isInterpretiveMode: byte-code compiler involved+isInterpretiveMode :: PostLoadMode -> Bool+isInterpretiveMode DoInteractive = True+isInterpretiveMode (DoEval _) = True+isInterpretiveMode _ = False++needsInputsMode :: PostLoadMode -> Bool+needsInputsMode DoMkDependHS = True+needsInputsMode (StopBefore _) = True+needsInputsMode DoMake = True+needsInputsMode DoVHDL = True+needsInputsMode DoVerilog = True+needsInputsMode DoSystemVerilog = True+needsInputsMode _ = False++-- True if we are going to attempt to link in this mode.+-- (we might not actually link, depending on the GhcLink flag)+isLinkMode :: PostLoadMode -> Bool+isLinkMode (StopBefore StopLn) = True+isLinkMode DoMake = True+isLinkMode DoInteractive = True+isLinkMode (DoEval _) = True+isLinkMode _ = False++isCompManagerMode :: PostLoadMode -> Bool+isCompManagerMode DoMake = True+isCompManagerMode DoInteractive = True+isCompManagerMode (DoEval _) = True+isCompManagerMode DoVHDL = True+isCompManagerMode DoVerilog = True+isCompManagerMode DoSystemVerilog = True+isCompManagerMode _ = False++-- -----------------------------------------------------------------------------+-- Parsing the mode flag++parseModeFlags :: [Located String]+ -> IO (Mode,+ [Located String],+ [Located String])+parseModeFlags args = do+ let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =+ runCmdLine (processArgs mode_flags args)+ (Nothing, [], [])+ mode = case mModeFlag of+ Nothing -> doMakeMode+ Just (m, _) -> m++ -- See Note [Handling errors when parsing commandline flags]+ unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $+ map (("on the commandline", )) $ map unLoc errs1 ++ errs2++ return (mode, flags' ++ leftover, warns)++type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])+ -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)+ -- so we collect the new ones and return them.++mode_flags :: [Flag ModeM]+mode_flags =+ [ ------- help / version ----------------------------------------------+ defFlag "?" (PassFlag (setMode showGhcUsageMode))+ , defFlag "-help" (PassFlag (setMode showGhcUsageMode))+ , defFlag "V" (PassFlag (setMode showVersionMode))+ , defFlag "-version" (PassFlag (setMode showVersionMode))+ , defFlag "-numeric-version" (PassFlag (setMode showNumVersionMode))+ , defFlag "-info" (PassFlag (setMode showInfoMode))+ , defFlag "-show-options" (PassFlag (setMode showOptionsMode))+ , defFlag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))+ , defFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))+ , defFlag "-show-packages" (PassFlag (setMode showPackagesMode))+ ] +++ [ defFlag k' (PassFlag (setMode (printSetting k)))+ | k <- ["Project version",+ "Project Git commit id",+ "Booter version",+ "Stage",+ "Build platform",+ "Host platform",+ "Target platform",+ "Have interpreter",+ "Object splitting supported",+ "Have native code generator",+ "Support SMP",+ "Unregisterised",+ "Tables next to code",+ "RTS ways",+ "Leading underscore",+ "Debug on",+ "LibDir",+ "Global Package DB",+ "C compiler flags",+ "C compiler link flags",+ "ld flags"],+ let k' = "-print-" ++ map (replaceSpace . toLower) k+ replaceSpace ' ' = '-'+ replaceSpace c = c+ ] +++ ------- interfaces ----------------------------------------------------+ [ defFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)+ "--show-iface"))++ ------- primary modes ------------------------------------------------+ , defFlag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f+ addFlag "-no-link" f))+ , defFlag "M" (PassFlag (setMode doMkDependHSMode))+ , defFlag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))+ , defFlag "C" (PassFlag (setMode (stopBeforeMode HCc)))+ , defFlag "S" (PassFlag (setMode (stopBeforeMode (As False))))+ , defFlag "-make" (PassFlag (setMode doMakeMode))+ , defFlag "-backpack" (PassFlag (setMode doBackpackMode))+ , defFlag "-interactive" (PassFlag (setMode doInteractiveMode))+ , defFlag "-abi-hash" (PassFlag (setMode doAbiHashMode))+ , defFlag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))+ , defFlag "-frontend" (SepArg (\s -> setMode (doFrontendMode s) "-frontend"))+ , defFlag "-vhdl" (PassFlag (setMode doVHDLMode))+ , defFlag "-verilog" (PassFlag (setMode doVerilogMode))+ , defFlag "-systemverilog" (PassFlag (setMode doSystemVerilogMode))+ ]++setMode :: Mode -> String -> EwM ModeM ()+setMode newMode newFlag = liftEwM $ do+ (mModeFlag, errs, flags') <- getCmdLineState+ let (modeFlag', errs') =+ case mModeFlag of+ Nothing -> ((newMode, newFlag), errs)+ Just (oldMode, oldFlag) ->+ case (oldMode, newMode) of+ -- -c/--make are allowed together, and mean --make -no-link+ _ | isStopLnMode oldMode && isDoMakeMode newMode+ || isStopLnMode newMode && isDoMakeMode oldMode ->+ ((doMakeMode, "--make"), [])++ -- If we have both --help and --interactive then we+ -- want showGhciUsage+ _ | isShowGhcUsageMode oldMode &&+ isDoInteractiveMode newMode ->+ ((showGhciUsageMode, oldFlag), [])+ | isShowGhcUsageMode newMode &&+ isDoInteractiveMode oldMode ->+ ((showGhciUsageMode, newFlag), [])++ -- If we have both -e and --interactive then -e always wins+ _ | isDoEvalMode oldMode &&+ isDoInteractiveMode newMode ->+ ((oldMode, oldFlag), [])+ | isDoEvalMode newMode &&+ isDoInteractiveMode oldMode ->+ ((newMode, newFlag), [])++ -- Otherwise, --help/--version/--numeric-version always win+ | isDominantFlag oldMode -> ((oldMode, oldFlag), [])+ | isDominantFlag newMode -> ((newMode, newFlag), [])+ -- We need to accumulate eval flags like "-e foo -e bar"+ (Right (Right (DoEval esOld)),+ Right (Right (DoEval [eNew]))) ->+ ((Right (Right (DoEval (eNew : esOld))), oldFlag),+ errs)+ -- Saying e.g. --interactive --interactive is OK+ _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)++ -- --interactive and --show-options are used together+ (Right (Right DoInteractive), Left (ShowOptions _)) ->+ ((Left (ShowOptions True),+ "--interactive --show-options"), errs)+ (Left (ShowOptions _), (Right (Right DoInteractive))) ->+ ((Left (ShowOptions True),+ "--show-options --interactive"), errs)+ -- Otherwise, complain+ _ -> let err = flagMismatchErr oldFlag newFlag+ in ((oldMode, oldFlag), err : errs)+ putCmdLineState (Just modeFlag', errs', flags')+ where isDominantFlag f = isShowGhcUsageMode f ||+ isShowGhciUsageMode f ||+ isShowVersionMode f ||+ isShowNumVersionMode f++flagMismatchErr :: String -> String -> String+flagMismatchErr oldFlag newFlag+ = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'"++addFlag :: String -> String -> EwM ModeM ()+addFlag s flag = liftEwM $ do+ (m, e, flags') <- getCmdLineState+ putCmdLineState (m, e, mkGeneralLocated loc s : flags')+ where loc = "addFlag by " ++ flag ++ " on the commandline"++-- ----------------------------------------------------------------------------+-- Run --make mode++doMake :: [(String,Maybe Phase)] -> Ghc ()+doMake srcs = do+ let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs++ hsc_env <- GHC.getSession++ -- if we have no haskell sources from which to do a dependency+ -- analysis, then just do one-shot compilation and/or linking.+ -- This means that "ghc Foo.o Bar.o -o baz" links the program as+ -- we expect.+ if (null hs_srcs)+ then liftIO (oneShot hsc_env StopLn srcs)+ else do++ o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)+ non_hs_srcs+ dflags <- GHC.getSessionDynFlags+ let dflags' = dflags { ldInputs = map (FileOption "") o_files+ ++ ldInputs dflags }+ _ <- GHC.setSessionDynFlags dflags'++ targets <- mapM (uncurry GHC.guessTarget) hs_srcs+ GHC.setTargets targets+ ok_flag <- GHC.load LoadAllTargets++ when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))+ return ()+++-- ---------------------------------------------------------------------------+-- --show-iface mode++doShowIface :: DynFlags -> FilePath -> IO ()+doShowIface dflags file = do+ hsc_env <- newHscEnv dflags+ showIface hsc_env file++-- ---------------------------------------------------------------------------+-- Various banners and verbosity output.++showBanner :: PostLoadMode -> DynFlags -> IO ()+showBanner _postLoadMode dflags = do+ let verb = verbosity dflags++#if defined(GHCI)+ -- Show the GHCi banner+ when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg+#endif++ -- Display details of the configuration in verbose mode+ when (verb >= 2) $+ do hPutStr stderr "Glasgow Haskell Compiler, Version "+ hPutStr stderr cProjectVersion+ hPutStr stderr ", stage "+ hPutStr stderr cStage+ hPutStr stderr " booted by GHC version "+ hPutStrLn stderr cBooterVersion++-- We print out a Read-friendly string, but a prettier one than the+-- Show instance gives us+showInfo :: DynFlags -> IO ()+showInfo dflags = do+ let sq x = " [" ++ x ++ "\n ]"+ putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags++showSupportedExtensions :: IO ()+showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions++showVersion :: IO ()+showVersion = putStrLn $ concat [ "CLaSH, version "+ , Data.Version.showVersion Paths_clash_ghc.version+ , " (using clash-lib, version: "+ , Data.Version.showVersion clashLibVersion+ , ")"+ ]++showOptions :: Bool -> IO ()+showOptions isInteractive = putStr (unlines availableOptions)+ where+ availableOptions = concat [+ flagsForCompletion isInteractive,+ map ('-':) (getFlagNames mode_flags)+ ]+ getFlagNames opts = map flagName opts++showGhcUsage :: DynFlags -> IO ()+showGhcUsage = showUsage False++showGhciUsage :: DynFlags -> IO ()+showGhciUsage = showUsage True++showUsage :: Bool -> DynFlags -> IO ()+showUsage ghci dflags = do+ let usage_path = if ghci then ghciUsagePath dflags+ else ghcUsagePath dflags+ usage <- readFile usage_path+ dump usage+ where+ dump "" = return ()+ dump ('$':'$':s) = putStr progName >> dump s+ dump (c:s) = putChar c >> dump s++dumpFinalStats :: DynFlags -> IO ()+dumpFinalStats dflags =+ when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags++dumpFastStringStats :: DynFlags -> IO ()+dumpFastStringStats dflags = do+ buckets <- getFastStringTable+ let (entries, longest, has_z) = countFS 0 0 0 buckets+ msg = text "FastString stats:" $$+ nest 4 (vcat [text "size: " <+> int (length buckets),+ text "entries: " <+> int entries,+ text "longest chain: " <+> int longest,+ text "has z-encoding: " <+> (has_z `pcntOf` entries)+ ])+ -- we usually get more "has z-encoding" than "z-encoded", because+ -- when we z-encode a string it might hash to the exact same string,+ -- which will is not counted as "z-encoded". Only strings whose+ -- Z-encoding is different from the original string are counted in+ -- the "z-encoded" total.+ putMsg dflags msg+ where+ x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'++countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int)+countFS entries longest has_z [] = (entries, longest, has_z)+countFS entries longest has_z (b:bs) =+ let+ len = length b+ longest' = max len longest+ entries' = entries + len+ has_zs = length (filter hasZEncoding b)+ in+ countFS entries' longest' (has_z + has_zs) bs++showPackages, dumpPackages, dumpPackagesSimple :: DynFlags -> IO ()+showPackages dflags = putStrLn (showSDoc dflags (pprPackages dflags))+dumpPackages dflags = putMsg dflags (pprPackages dflags)+dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple dflags)++-- -----------------------------------------------------------------------------+-- Frontend plugin support++doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()+#if !defined(GHCI)+doFrontend modname _ = pluginError [modname]+#else+doFrontend modname srcs = do+ hsc_env <- getSession+ frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname+ frontend frontend_plugin+ (reverse $ frontendPluginOpts (hsc_dflags hsc_env)) srcs+#endif++-- -----------------------------------------------------------------------------+-- ABI hash support++{-+ ghc --abi-hash Data.Foo System.Bar++Generates a combined hash of the ABI for modules Data.Foo and+System.Bar. The modules must already be compiled, and appropriate -i+options may be necessary in order to find the .hi files.++This is used by Cabal for generating the ComponentId for a+package. The ComponentId must change when the visible ABI of+the package chagnes, so during registration Cabal calls ghc --abi-hash+to get a hash of the package's ABI.+-}++-- | Print ABI hash of input modules.+--+-- The resulting hash is the MD5 of the GHC version used (Trac #5328,+-- see 'hiVersion') and of the existing ABI hash from each module (see+-- 'mi_mod_hash').+abiHash :: [String] -- ^ List of module names+ -> Ghc ()+abiHash strs = do+ hsc_env <- getSession+ let dflags = hsc_dflags hsc_env++ liftIO $ do++ let find_it str = do+ let modname = mkModuleName str+ r <- findImportedModule hsc_env modname Nothing+ case r of+ Found _ m -> return m+ _error -> throwGhcException $ CmdLineError $ showSDoc dflags $+ cannotFindModule dflags modname r++ mods <- mapM find_it strs++ let get_iface modl = loadUserInterface False (text "abiHash") modl+ ifaces <- initIfaceCheck (text "abiHash") hsc_env $ mapM get_iface mods++ bh <- openBinMem (3*1024) -- just less than a block+ put_ bh hiVersion+ -- package hashes change when the compiler version changes (for now)+ -- see #5328+ mapM_ (put_ bh . mi_mod_hash) ifaces+ f <- fingerprintBinMem bh++ putStrLn (showPpr dflags f)++-----------------------------------------------------------------------------+-- VHDL Generation++makeHDL' :: Clash.Backend.Backend backend => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)+ -> IORef ClashOpts -> [(String,Maybe Phase)] -> Ghc ()+makeHDL' _ _ [] = throwGhcException (CmdLineError "No input files")+makeHDL' backend r srcs = makeHDL backend r $ fmap fst srcs++makeVHDL :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VHDLState)++makeVerilog :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VerilogState)++makeSystemVerilog :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> SystemVerilogState)++-- -----------------------------------------------------------------------------+-- Util++unknownFlagsErr :: [String] -> a+unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs+ where+ oneError f =+ "unrecognised flag: " ++ f ++ "\n" +++ (case match f (nubSort allNonDeprecatedFlags) of+ [] -> ""+ suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs))+ -- fixes #11789+ -- If the flag contains '=',+ -- this uses both the whole and the left side of '=' for comparing.+ match f allFlags+ | elem '=' f =+ let (flagsWithEq, flagsWithoutEq) = partition (elem '=') allFlags+ fName = takeWhile (/= '=') f+ in (fuzzyMatch f flagsWithEq) ++ (fuzzyMatch fName flagsWithoutEq)+ | otherwise = fuzzyMatch f allFlags++{- Note [-Bsymbolic and hooks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-Bsymbolic is a flag that prevents the binding of references to global+symbols to symbols outside the shared library being compiled (see `man+ld`). When dynamically linking, we don't use -Bsymbolic on the RTS+package: that is because we want hooks to be overridden by the user,+we don't want to constrain them to the RTS package.++Unfortunately this seems to have broken somehow on OS X: as a result,+defaultHooks (in hschooks.c) is not called, which does not initialize+the GC stats. As a result, this breaks things like `:set +s` in GHCi+(#8754). As a hacky workaround, we instead call 'defaultHooks'+directly to initalize the flags in the RTS.++A byproduct of this, I believe, is that hooks are likely broken on OS+X when dynamically linking. But this probably doesn't affect most+people since we're linking GHC dynamically, but most things themselves+link statically.+-}++foreign import ccall safe "initGCStatistics"+ initGCStatistics :: IO ()
src-bin-841/Clash/GHCi/UI.hs view
@@ -144,11 +144,14 @@ import Clash.GHC.Evaluator import Clash.GHC.GenerateBindings import Clash.GHC.NetlistTypes+import Clash.GHCi.Common import Clash.Netlist.BlackBox.Types (HdlSyn)-import Clash.Util (clashLibVersion)+import Clash.Util (clashLibVersion, reportTimeDiff) import qualified Data.Time.Clock as Clock import qualified Paths_clash_ghc +import Clash.Annotations.BitRepresentation.Internal (buildCustomReprs)+ ----------------------------------------------------------------------------- data GhciSettings = GhciSettings {@@ -1443,7 +1446,7 @@ liftIO $ setCurrentDirectory dir' dflags <- getDynFlags -- With -fexternal-interpreter, we have to change the directory of the subprocess too.- -- (this gives consistent behaviour with and without -fexternal-interpreter)+ -- (this gives consistent behavior with and without -fexternal-interpreter) when (gopt Opt_ExternalInterpreter dflags) $ lift $ enqueueCommands ["System.Directory.setCurrentDirectory " ++ show dir'] @@ -1908,11 +1911,12 @@ exceptT :: Applicative m => Either e a -> ExceptT e m a exceptT = ExceptT . pure -makeHDL' :: Clash.Backend.Backend backend- => (Int -> HdlSyn -> backend)- -> IORef ClashOpts- -> [FilePath]- -> InputT GHCi ()+makeHDL'+ :: Clash.Backend.Backend backend+ => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)+ -> IORef ClashOpts+ -> [FilePath]+ -> InputT GHCi () makeHDL' backend opts lst = makeHDL backend opts =<< case lst of srcs@(_:_) -> return srcs [] -> do@@ -1922,19 +1926,25 @@ ((AcyclicSCC top) : _) -> maybeToList $ (GHC.ml_hs_file . GHC.ms_location) top _ -> [] -makeHDL :: GHC.GhcMonad m- => Clash.Backend.Backend backend- => (Int -> HdlSyn -> backend)- -> IORef ClashOpts- -> [FilePath]- -> m ()+makeHDL+ :: GHC.GhcMonad m+ => Clash.Backend.Backend backend+ => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)+ -> IORef ClashOpts+ -> [FilePath]+ -> m () makeHDL backend optsRef srcs = do dflags <- GHC.getSessionDynFlags liftIO $ do startTime <- Clock.getCurrentTime- opts <- readIORef optsRef- let iw = opt_intWidth opts- fp = opt_floatSupport opts- syn = opt_hdlSyn opts+ opts0 <- readIORef optsRef+ let opts1 = opts0 { opt_color = useColor dflags }+ iw = opt_intWidth opts1+ fp = opt_floatSupport opts1+ syn = opt_hdlSyn opts1+ color = opt_color opts1+ esc = opt_escapedIds opts1+ frcUdf = opt_forceUndefined opts1+ hdl = Clash.Backend.hdlKind backend' -- determine whether `-outputdir` was used outputDir = do odir <- objectDir dflags hidir <- hiDir dflags@@ -1944,27 +1954,46 @@ then Just odir else Nothing idirs = importPaths dflags- opts' = opts {opt_hdlDir = maybe outputDir Just (opt_hdlDir opts)- ,opt_importPaths = idirs}- backend' = backend iw syn+ opts2 = opts1 { opt_hdlDir = maybe outputDir Just (opt_hdlDir opts1)+ , opt_importPaths = idirs}+ backend' = backend iw syn esc frcUdf++ checkMonoLocalBinds dflags+ checkImportDirs opts0 idirs+ primDirs <- Clash.Backend.primDirs backend'+ forM_ srcs $ \src -> do- (bindingsMap,tcm,tupTcm,topEntities,primMap) <-- generateBindings primDirs idirs (Clash.Backend.hdlKind backend') src (Just dflags)+ -- Generate bindings:+ let dbs = reverse [p | PackageDB (PkgConfFile p) <- packageDBFlags dflags]+ (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs) <-+ generateBindings color primDirs idirs dbs hdl src (Just dflags) prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime- let prepStartDiff = Clock.diffUTCTime prepTime startTime- putStrLn $ "Loading dependencies took " ++ show prepStartDiff- Clash.Driver.generateHDL bindingsMap (Just backend') primMap tcm- tupTcm (ghcTypeToHWType iw fp) reduceConstant topEntities opts' (startTime,prepTime)+ let prepStartDiff = reportTimeDiff prepTime startTime+ putStrLn $ "GHC+Clash: Loading modules cumulatively took " ++ prepStartDiff + -- Generate HDL:+ Clash.Driver.generateHDL+ (buildCustomReprs reprs)+ bindingsMap+ (Just backend')+ primMap+ tcm+ tupTcm+ (ghcTypeToHWType iw fp)+ reduceConstant+ topEntities+ opts2+ (startTime,prepTime)+ makeVHDL :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> VHDLState)+makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VHDLState) makeVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> VerilogState)+makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VerilogState) makeSystemVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> SystemVerilogState)+makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> SystemVerilogState) ----------------------------------------------------------------------------- -- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.
src-bin-841/Clash/Main.hs view
@@ -83,21 +83,17 @@ import Exception (gcatch) import Data.IORef (IORef, newIORef, readIORef) import qualified Data.Version (showVersion)-import Control.Exception (Exception(..),ErrorCall (..)) -import qualified GHC.LanguageExtensions as LangExt-import GHC.Exception ( SomeException )- import qualified Clash.Backend import Clash.Backend.SystemVerilog (SystemVerilogState) import Clash.Backend.VHDL (VHDLState) import Clash.Backend.Verilog (VerilogState)-import Clash.Driver.Types- (ClashOpts (..), ClashException (..), DebugLevel (..))+import Clash.Driver.Types (ClashOpts (..), defClashOpts) import Clash.GHC.ClashFlags import Clash.Netlist.BlackBox.Types (HdlSyn (..)) import Clash.Util (clashLibVersion)-import Clash.GHC.LoadModules (ghcLibDir)+import Clash.GHC.LoadModules (ghcLibDir, wantedLanguageExtensions)+import Clash.GHC.Util (handleClashException) ----------------------------------------------------------------------------- -- ToDo:@@ -141,21 +137,8 @@ libDir <- ghcLibDir let argv1 = map (mkGeneralLocated "on the commandline") argv0- r <- newIORef (ClashOpts { opt_dbgLevel = DebugNone- , opt_inlineLimit = 20- , opt_specLimit = 20- , opt_inlineFunctionLimit = 15- , opt_inlineConstantLimit = 0- , opt_cachehdl = True- , opt_cleanhdl = True- , opt_intWidth = WORD_SIZE_IN_BITS- , opt_hdlDir = Nothing- , opt_hdlSyn = Other- , opt_errorExtra = False- , opt_floatSupport = False- , opt_allowZero = False- , opt_importPaths = []- })+ r <- newIORef defClashOpts+ (argv2, clashFlagWarnings) <- parseClashFlags r argv1 -- 2. Parse the "mode" flags (--make, --interactive etc.)@@ -183,50 +166,28 @@ GHC.runGhc (Just libDir) $ do dflags <- GHC.getSessionDynFlags- let dflagsExtra = foldl DynFlags.xopt_set- dflags- [ LangExt.TemplateHaskell- , LangExt.TemplateHaskellQuotes- , LangExt.DataKinds- , LangExt.MonoLocalBinds- , LangExt.TypeOperators- , LangExt.FlexibleContexts- , LangExt.ConstraintKinds- , LangExt.TypeFamilies- , LangExt.BinaryLiterals- , LangExt.ExplicitNamespaces- , LangExt.KindSignatures- , LangExt.DeriveLift- , LangExt.TypeApplications- , LangExt.ScopedTypeVariables- , LangExt.MagicHash- , LangExt.ExplicitForAll- ]- dflagsExtra1 = foldl DynFlags.xopt_unset dflagsExtra- [ LangExt.ImplicitPrelude- , LangExt.MonomorphismRestriction- ]+ let dflagsExtra = wantedLanguageExtensions dflags ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise" ghcTyLitExtrPlugin = GHC.mkModuleName "GHC.TypeLits.Extra.Solver" ghcTyLitKNPlugin = GHC.mkModuleName "GHC.TypeLits.KnownNat.Solver"- dflagsExtra2 = dflagsExtra1+ dflagsExtra1 = dflagsExtra { DynFlags.pluginModNames = nub $ ghcTyLitNormPlugin : ghcTyLitExtrPlugin : ghcTyLitKNPlugin :- DynFlags.pluginModNames dflagsExtra1+ DynFlags.pluginModNames dflagsExtra } case postStartupMode of Left preLoadMode -> liftIO $ do case preLoadMode of- ShowInfo -> showInfo dflagsExtra2- ShowGhcUsage -> showGhcUsage dflagsExtra2- ShowGhciUsage -> showGhciUsage dflagsExtra2- PrintWithDynFlags f -> putStrLn (f dflagsExtra2)+ ShowInfo -> showInfo dflagsExtra1+ ShowGhcUsage -> showGhcUsage dflagsExtra1+ ShowGhciUsage -> showGhciUsage dflagsExtra1+ PrintWithDynFlags f -> putStrLn (f dflagsExtra1) Right postLoadMode ->- main' postLoadMode dflagsExtra2 argv3 flagWarnings r+ main' postLoadMode dflagsExtra1 argv3 flagWarnings r main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn] -> IORef ClashOpts@@ -245,9 +206,9 @@ DoBackpack -> (CompManager, dflt_target, LinkBinary) DoMkDependHS -> (MkDepend, dflt_target, LinkBinary) DoAbiHash -> (OneShot, dflt_target, LinkBinary)- DoVHDL -> (CompManager, dflt_target, LinkInMemory)- DoVerilog -> (CompManager, dflt_target, LinkInMemory)- DoSystemVerilog -> (CompManager, dflt_target, LinkInMemory)+ DoVHDL -> (CompManager, HscNothing, NoLink)+ DoVerilog -> (CompManager, HscNothing, NoLink)+ DoSystemVerilog -> (CompManager, HscNothing, NoLink) _ -> (OneShot, dflt_target, LinkBinary) let dflags1 = dflags0{ ghcMode = mode,@@ -351,37 +312,6 @@ liftIO $ dumpFinalStats dflags6 -handleClashException- :: GhcMonad m- => DynFlags- -> ClashOpts- -> SomeException- -> m a-handleClashException df opts e = case fromException e of- Just (ClashException sp s eM) ->- throwOneError (mkPlainErrMsg df sp (text s $$ blankLine $$ srcInfo $$ showExtra (opt_errorExtra opts) eM))- _ -> case fromException e of- Just (ErrorCall msg) ->- throwOneError (mkPlainErrMsg df noSrcSpan (text "Clash error call:" $$ text msg))- _ -> case fromException e of- Just (e' :: SourceError) -> do- GHC.printException e'- liftIO $ exitWith (ExitFailure 1)- _ -> throwOneError (mkPlainErrMsg df noSrcSpan (text "Other error:" $$ text (displayException e)))- where- srcInfo = text "NB: The source location of the error is not exact, only indicative, as it is acquired after optimisations." $$- text "The actual location of the error can be in a function that is inlined." $$- text "To prevent inlining of those functions, annotate them with a NOINLINE pragma."-- showExtra False (Just _) =- blankLine $$- text "This error contains additional information, rerun with '-fclash-error-extra' to show this information."- showExtra True (Just msg) =- blankLine $$- text "Additional information:" $$ blankLine $$- text msg- showExtra _ _ = empty- ghciUI :: IORef ClashOpts -> [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc () #if !defined(GHCI) ghciUI _ _ _ = throwGhcException (CmdLineError "not built for interactive use")@@ -664,9 +594,6 @@ isLinkMode DoMake = True isLinkMode DoInteractive = True isLinkMode (DoEval _) = True-isLinkMode DoVHDL = True-isLinkMode DoVerilog = True-isLinkMode DoSystemVerilog = True isLinkMode _ = False isCompManagerMode :: PostLoadMode -> Bool@@ -1044,18 +971,19 @@ ----------------------------------------------------------------------------- -- VHDL Generation -makeHDL' :: Clash.Backend.Backend backend => (Int -> HdlSyn -> backend) -> IORef ClashOpts -> [(String,Maybe Phase)] -> Ghc ()+makeHDL' :: Clash.Backend.Backend backend => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)+ -> IORef ClashOpts -> [(String,Maybe Phase)] -> Ghc () makeHDL' _ _ [] = throwGhcException (CmdLineError "No input files") makeHDL' backend r srcs = makeHDL backend r $ fmap fst srcs makeVHDL :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> VHDLState)+makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VHDLState) makeVerilog :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> VerilogState)+makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VerilogState) makeSystemVerilog :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> SystemVerilogState)+makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> SystemVerilogState) -- ----------------------------------------------------------------------------- -- Util
+ src-bin-861/Clash/GHCi/Leak.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE RecordWildCards, LambdaCase #-}+module Clash.GHCi.Leak+ ( LeakIndicators+ , getLeakIndicators+ , checkLeakIndicators+ ) where++import Control.Monad+import GHC+import Outputable+import HscTypes+import UniqDFM+import System.Mem+import System.Mem.Weak++-- Checking for space leaks in GHCi. See #15111, and the+-- -fghci-leak-check flag.++data LeakIndicators = LeakIndicators [LeakModIndicators]++data LeakModIndicators = LeakModIndicators+ { leakMod :: Weak HomeModInfo+ , leakIface :: Weak ModIface+ , leakDetails :: Weak ModDetails+ , leakLinkable :: Maybe (Weak Linkable)+ }++-- | Grab weak references to some of the data structures representing+-- the currently loaded modules.+getLeakIndicators :: HscEnv -> IO LeakIndicators+getLeakIndicators HscEnv{..} =+ fmap LeakIndicators $+ forM (eltsUDFM hsc_HPT) $ \hmi@HomeModInfo{..} -> do+ leakMod <- mkWeakPtr hmi Nothing+ leakIface <- mkWeakPtr hm_iface Nothing+ leakDetails <- mkWeakPtr hm_details Nothing+ leakLinkable <- mapM (`mkWeakPtr` Nothing) hm_linkable+ return $ LeakModIndicators{..}++-- | Look at the LeakIndicators collected by an earlier call to+-- `getLeakIndicators`, and print messasges if any of them are still+-- alive.+checkLeakIndicators :: DynFlags -> LeakIndicators -> IO ()+checkLeakIndicators dflags (LeakIndicators leakmods) = do+ performGC+ forM_ leakmods $ \LeakModIndicators{..} -> do+ deRefWeak leakMod >>= \case+ Nothing -> return ()+ Just hmi ->+ report ("HomeModInfo for " +++ showSDoc dflags (ppr (mi_module (hm_iface hmi)))) (Just hmi)+ deRefWeak leakIface >>= report "ModIface"+ deRefWeak leakDetails >>= report "ModDetails"+ forM_ leakLinkable $ \l -> deRefWeak l >>= report "Linkable"+ where+ report :: String -> Maybe a -> IO ()+ report _ Nothing = return ()+ report msg (Just _) =+ putStrLn ("-fghci-leak-check: " ++ msg ++ " is still alive!")
+ src-bin-861/Clash/GHCi/UI.hs view
@@ -0,0 +1,3986 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS -fno-cse #-}+-- -fno-cse is needed for GLOBAL_VAR's to behave properly++-----------------------------------------------------------------------------+--+-- GHC Interactive User Interface+--+-- (c) The GHC Team 2005-2006+--+-----------------------------------------------------------------------------++module Clash.GHCi.UI (+ interactiveUI,+ GhciSettings(..),+ defaultGhciSettings,+ ghciCommands,+ ghciWelcomeMsg,+ makeHDL+ ) where++#include "HsVersions.h"++-- GHCi+import qualified Clash.GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls )+import Clash.GHCi.UI.Monad hiding ( args, runStmt, runDecls )+import Clash.GHCi.UI.Tags+import Clash.GHCi.UI.Info+import Debugger++-- The GHC interface+import GHCi+import GHCi.RemoteTypes+import GHCi.BreakArray+import DynFlags+import ErrUtils hiding (traceCmd)+import Finder+import GhcMonad ( modifySession )+import qualified GHC+import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..),+ TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,+ GetDocsFailure(..),+ getModuleGraph, handleSourceError )+import HsImpExp+import HsSyn+import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,+ setInteractivePrintName, hsc_dflags, msObjFilePath )+import Module+import Name+import Packages ( trusted, getPackageDetails, getInstalledPackageDetails,+ listVisibleModuleNames, pprFlag )+import IfaceSyn ( showToHeader )+import PprTyThing+import PrelNames+import RdrName ( getGRE_NameQualifier_maybes, getRdrName )+import SrcLoc+import qualified Lexer++import StringBuffer+import Outputable hiding ( printForUser, printForUserPartWay )++import DynamicLoading ( initializePlugins )++-- Other random utilities+import BasicTypes hiding ( isTopLevel )+import Digraph+import Encoding+import FastString+import Linker+import Maybes ( orElse, expectJust )+import NameSet+import Panic hiding ( showException )+import Util+import qualified GHC.LanguageExtensions as LangExt++-- Haskell Libraries+import System.Console.Haskeline as Haskeline++import Control.Applicative hiding (empty)+import Control.DeepSeq (deepseq)+import Control.Monad as Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except++import Data.Array+import qualified Data.ByteString.Char8 as BS+import Data.Char+import Data.Function+import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )+import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,+ partition, sort, sortBy )+import qualified Data.Set as S+import Data.Maybe+import Data.Map (Map)+import qualified Data.Map as M+import Data.Time.LocalTime ( getZonedTime )+import Data.Time.Format ( formatTime, defaultTimeLocale )+import Data.Version ( showVersion )+import Prelude hiding ((<>))++import Exception hiding (catch)+import Foreign hiding (void)+import GHC.Stack hiding (SrcLoc(..))++import System.Directory+import System.Environment+import System.Exit ( exitWith, ExitCode(..) )+import System.FilePath+import System.Info+import System.IO+import System.IO.Error+import System.IO.Unsafe ( unsafePerformIO )+import System.Process+import Text.Printf+import Text.Read ( readMaybe )+import Text.Read.Lex (isSymbolChar)++import Unsafe.Coerce++#if !defined(mingw32_HOST_OS)+import System.Posix hiding ( getEnv )+#else+import qualified System.Win32+#endif++import GHC.IO.Exception ( IOErrorType(InvalidArgument) )+import GHC.IO.Handle ( hFlushAll )+import GHC.TopHandler ( topHandler )++import Clash.GHCi.Leak++-- clash additions+import qualified Clash.Backend+import Clash.Backend.SystemVerilog (SystemVerilogState)+import Clash.Backend.VHDL (VHDLState)+import Clash.Backend.Verilog (VerilogState)+import qualified Clash.Driver+import Clash.Driver.Types (ClashOpts(..))+import Clash.GHC.Evaluator+import Clash.GHC.GenerateBindings+import Clash.GHC.NetlistTypes+import Clash.GHCi.Common+import Clash.Netlist.BlackBox.Types (HdlSyn)+import Clash.Util (clashLibVersion, reportTimeDiff)+import qualified Data.Time.Clock as Clock+import qualified Paths_clash_ghc++import Clash.Annotations.BitRepresentation.Internal (buildCustomReprs)++-----------------------------------------------------------------------------++data GhciSettings = GhciSettings {+ availableCommands :: [Command],+ shortHelpText :: String,+ fullHelpText :: String,+ defPrompt :: PromptFunction,+ defPromptCont :: PromptFunction+ }++defaultGhciSettings :: IORef ClashOpts -> GhciSettings+defaultGhciSettings opts =+ GhciSettings {+ availableCommands = ghciCommands opts,+ shortHelpText = defShortHelpText,+ defPrompt = default_prompt,+ defPromptCont = default_prompt_cont,+ fullHelpText = defFullHelpText+ }++ghciWelcomeMsg :: String+ghciWelcomeMsg = "Clashi, version " ++ Data.Version.showVersion Paths_clash_ghc.version +++ " (using clash-lib, version " ++ Data.Version.showVersion clashLibVersion +++ "):\nhttp://www.clash-lang.org/ :? for help"++ghciCommands :: IORef ClashOpts -> [Command]+ghciCommands opts = map mkCmd [+ -- Hugs users are accustomed to :e, so make sure it doesn't overlap+ ("?", keepGoing help, noCompletion),+ ("add", keepGoingPaths addModule, completeFilename),+ ("abandon", keepGoing abandonCmd, noCompletion),+ ("break", keepGoing breakCmd, completeIdentifier),+ ("back", keepGoing backCmd, noCompletion),+ ("browse", keepGoing' (browseCmd False), completeModule),+ ("browse!", keepGoing' (browseCmd True), completeModule),+ ("cd", keepGoing' changeDirectory, completeFilename),+ ("check", keepGoing' checkModule, completeHomeModule),+ ("continue", keepGoing continueCmd, noCompletion),+ ("cmd", keepGoing cmdCmd, completeExpression),+ ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename),+ ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename),+ ("def", keepGoing (defineMacro False), completeExpression),+ ("def!", keepGoing (defineMacro True), completeExpression),+ ("delete", keepGoing deleteCmd, noCompletion),+ ("doc", keepGoing' docCmd, completeIdentifier),+ ("edit", keepGoing' editFile, completeFilename),+ ("etags", keepGoing createETagsFileCmd, completeFilename),+ ("force", keepGoing forceCmd, completeExpression),+ ("forward", keepGoing forwardCmd, noCompletion),+ ("help", keepGoing help, noCompletion),+ ("history", keepGoing historyCmd, noCompletion),+ ("info", keepGoing' (info False), completeIdentifier),+ ("info!", keepGoing' (info True), completeIdentifier),+ ("issafe", keepGoing' isSafeCmd, completeModule),+ ("kind", keepGoing' (kindOfType False), completeIdentifier),+ ("kind!", keepGoing' (kindOfType True), completeIdentifier),+ ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),+ ("load!", keepGoingPaths loadModuleDefer, completeHomeModuleOrFile),+ ("list", keepGoing' listCmd, noCompletion),+ ("module", keepGoing moduleCmd, completeSetModule),+ ("main", keepGoing runMain, completeFilename),+ ("print", keepGoing printCmd, completeExpression),+ ("quit", quit, noCompletion),+ ("reload", keepGoing' reloadModule, noCompletion),+ ("reload!", keepGoing' reloadModuleDefer, noCompletion),+ ("run", keepGoing runRun, completeFilename),+ ("script", keepGoing' scriptCmd, completeFilename),+ ("set", keepGoing setCmd, completeSetOptions),+ ("seti", keepGoing setiCmd, completeSeti),+ ("show", keepGoing showCmd, completeShowOptions),+ ("showi", keepGoing showiCmd, completeShowiOptions),+ ("sprint", keepGoing sprintCmd, completeExpression),+ ("step", keepGoing stepCmd, completeIdentifier),+ ("steplocal", keepGoing stepLocalCmd, completeIdentifier),+ ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),+ ("type", keepGoing' typeOfExpr, completeExpression),+ ("trace", keepGoing traceCmd, completeExpression),+ ("unadd", keepGoingPaths unAddModule, completeFilename),+ ("undef", keepGoing undefineMacro, completeMacro),+ ("unset", keepGoing unsetOptions, completeSetOptions),+ ("where", keepGoing whereCmd, noCompletion),+ ("vhdl", keepGoingPaths (makeVHDL opts), completeHomeModuleOrFile),+ ("verilog", keepGoingPaths (makeVerilog opts), completeHomeModuleOrFile),+ ("systemverilog", keepGoingPaths (makeSystemVerilog opts), completeHomeModuleOrFile)+ ] ++ map mkCmdHidden [ -- hidden commands+ ("all-types", keepGoing' allTypesCmd),+ ("complete", keepGoing completeCmd),+ ("loc-at", keepGoing' locAtCmd),+ ("type-at", keepGoing' typeAtCmd),+ ("uses", keepGoing' usesCmd)+ ]+ where+ mkCmd (n,a,c) = Command { cmdName = n+ , cmdAction = a+ , cmdHidden = False+ , cmdCompletionFunc = c+ }++ mkCmdHidden (n,a) = Command { cmdName = n+ , cmdAction = a+ , cmdHidden = True+ , cmdCompletionFunc = noCompletion+ }++-- We initialize readline (in the interactiveUI function) to use+-- word_break_chars as the default set of completion word break characters.+-- This can be overridden for a particular command (for example, filename+-- expansion shouldn't consider '/' to be a word break) by setting the third+-- entry in the Command tuple above.+--+-- NOTE: in order for us to override the default correctly, any custom entry+-- must be a SUBSET of word_break_chars.+word_break_chars :: String+word_break_chars = spaces ++ specials ++ symbols++symbols, specials, spaces :: String+symbols = "!#$%&*+/<=>?@\\^|-~"+specials = "(),;[]`{}"+spaces = " \t\n"++flagWordBreakChars :: String+flagWordBreakChars = " \t\n"+++keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)+keepGoing a str = keepGoing' (lift . a) str++keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool+keepGoing' a str = a str >> return False++keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)+keepGoingPaths a str+ = do case toArgs str of+ Left err -> liftIO $ hPutStrLn stderr err+ Right args -> a args+ return False++defShortHelpText :: String+defShortHelpText = "use :? for help.\n"++defFullHelpText :: String+defFullHelpText =+ " Commands available from the prompt:\n" +++ "\n" +++ " <statement> evaluate/run <statement>\n" +++ " : repeat last command\n" +++ " :{\\n ..lines.. \\n:}\\n multiline command\n" +++ " :add [*]<module> ... add module(s) to the current target set\n" +++ " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" +++ " (!: more details; *: all top-level names)\n" +++ " :cd <dir> change directory to <dir>\n" +++ " :cmd <expr> run the commands returned by <expr>::IO String\n" +++ " :complete <dom> [<rng>] <s> list completions for partial input string\n" +++ " :ctags[!] [<file>] create tags file <file> for Vi (default: \"tags\")\n" +++ " (!: use regex instead of line number)\n" +++ " :def <cmd> <expr> define command :<cmd> (later defined command has\n" +++ " precedence, ::<cmd> is always a builtin command)\n" +++ " :doc <name> display docs for the given name (experimental)\n" +++ " :edit <file> edit file\n" +++ " :edit edit last module\n" +++ " :etags [<file>] create tags file <file> for Emacs (default: \"TAGS\")\n" +++ " :help, :? display this list of commands\n" +++ " :info[!] [<name> ...] display information about the given names\n" +++ " (!: do not filter instances)\n" +++ " :issafe [<mod>] display safe haskell information of module <mod>\n" +++ " :kind[!] <type> show the kind of <type>\n" +++ " (!: also print the normalised type)\n" +++ " :load[!] [*]<module> ... load module(s) and their dependents\n" +++ " (!: defer type errors)\n" +++ " :main [<arguments> ...] run the main function with the given arguments\n" +++ " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" +++ " :quit exit GHCi\n" +++ " :reload[!] reload the current module set\n" +++ " (!: defer type errors)\n" +++ " :run function [<arguments> ...] run the function with the given arguments\n" +++ " :script <file> run the script <file>\n" +++ " :type <expr> show the type of <expr>\n" +++ " :type +d <expr> show the type of <expr>, defaulting type variables\n" +++ " :type +v <expr> show the type of <expr>, with its specified tyvars\n" +++ " :unadd <module> ... remove module(s) from the current target set\n" +++ " :undef <cmd> undefine user-defined command :<cmd>\n" +++ " :!<command> run the shell command <command>\n" +++ " :vhdl synthesize currently loaded module to vhdl\n" +++ " :vhdl [<module>] synthesize specified modules/files to vhdl\n" +++ " :verilog synthesize currently loaded module to verilog\n" +++ " :verilog [<module>] synthesize specified modules/files to verilog\n" +++ " :systemverilog synthesize currently loaded module to systemverilog\n" +++ " :systemverilog [<module>] synthesize specified modules/files to systemverilog\n" +++ "\n" +++ " -- Commands for debugging:\n" +++ "\n" +++ " :abandon at a breakpoint, abandon current computation\n" +++ " :back [<n>] go back in the history N steps (after :trace)\n" +++ " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" +++ " :break <name> set a breakpoint on the specified function\n" +++ " :continue resume after a breakpoint\n" +++ " :delete <number> delete the specified breakpoint\n" +++ " :delete * delete all breakpoints\n" +++ " :force <expr> print <expr>, forcing unevaluated parts\n" +++ " :forward [<n>] go forward in the history N step s(after :back)\n" +++ " :history [<n>] after :trace, show the execution history\n" +++ " :list show the source code around current breakpoint\n" +++ " :list <identifier> show the source code for <identifier>\n" +++ " :list [<module>] <line> show the source code around line number <line>\n" +++ " :print [<name> ...] show a value without forcing its computation\n" +++ " :sprint [<name> ...] simplified version of :print\n" +++ " :step single-step after stopping at a breakpoint\n"+++ " :step <expr> single-step into <expr>\n"+++ " :steplocal single-step within the current top-level binding\n"+++ " :stepmodule single-step restricted to the current module\n"+++ " :trace trace after stopping at a breakpoint\n"+++ " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++++ "\n" +++ " -- Commands for changing settings:\n" +++ "\n" +++ " :set <option> ... set options\n" +++ " :seti <option> ... set options for interactive evaluation only\n" +++ " :set args <arg> ... set the arguments returned by System.getArgs\n" +++ " :set prog <progname> set the value returned by System.getProgName\n" +++ " :set prompt <prompt> set the prompt used in GHCi\n" +++ " :set prompt-cont <prompt> set the continuation prompt used in GHCi\n" +++ " :set prompt-function <expr> set the function to handle the prompt\n" +++ " :set prompt-cont-function <expr>" +++ "set the function to handle the continuation prompt\n" +++ " :set editor <cmd> set the command used for :edit\n" +++ " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" +++ " :unset <option> ... unset options\n" +++ "\n" +++ " Options for ':set' and ':unset':\n" +++ "\n" +++ " +m allow multiline commands\n" +++ " +r revert top-level expressions after each evaluation\n" +++ " +s print timing/memory stats after each evaluation\n" +++ " +t print type after evaluation\n" +++ " +c collect type/location info after loading modules\n" +++ " -<flags> most GHC command line flags can also be set here\n" +++ " (eg. -v2, -XFlexibleInstances, etc.)\n" +++ " for GHCi-specific flags, see User's Guide,\n"+++ " Flag reference, Interactive-mode options\n" +++ "\n" +++ " -- Commands for displaying information:\n" +++ "\n" +++ " :show bindings show the current bindings made at the prompt\n" +++ " :show breaks show the active breakpoints\n" +++ " :show context show the breakpoint context\n" +++ " :show imports show the current imports\n" +++ " :show linker show current linker state\n" +++ " :show modules show the currently loaded modules\n" +++ " :show packages show the currently active package flags\n" +++ " :show paths show the currently active search paths\n" +++ " :show language show the currently active language flags\n" +++ " :show targets show the current set of targets\n" +++ " :show <setting> show value of <setting>, which is one of\n" +++ " [args, prog, editor, stop]\n" +++ " :showi language show language flags for interactive evaluation\n" +++ "\n"++findEditor :: IO String+findEditor = do+ getEnv "EDITOR"+ `catchIO` \_ -> do+#if defined(mingw32_HOST_OS)+ win <- System.Win32.getWindowsDirectory+ return (win </> "notepad.exe")+#else+ return ""+#endif++default_progname, default_stop :: String+default_progname = "<interactive>"+default_stop = ""++default_prompt, default_prompt_cont :: PromptFunction+default_prompt = generatePromptFunctionFromString "%s> "+default_prompt_cont = generatePromptFunctionFromString "%s| "++default_args :: [String]+default_args = []++interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]+ -> Ghc ()+interactiveUI config srcs maybe_exprs = do+ -- HACK! If we happen to get into an infinite loop (eg the user+ -- types 'let x=x in x' at the prompt), then the thread will block+ -- on a blackhole, and become unreachable during GC. The GC will+ -- detect that it is unreachable and send it the NonTermination+ -- exception. However, since the thread is unreachable, everything+ -- it refers to might be finalized, including the standard Handles.+ -- This sounds like a bug, but we don't have a good solution right+ -- now.+ _ <- liftIO $ newStablePtr stdin+ _ <- liftIO $ newStablePtr stdout+ _ <- liftIO $ newStablePtr stderr++ -- Initialise buffering for the *interpreted* I/O system+ (nobuffering, flush) <- initInterpBuffering++ -- The initial set of DynFlags used for interactive evaluation is the same+ -- as the global DynFlags, plus -XExtendedDefaultRules and+ -- -XNoMonomorphismRestriction.+ dflags <- getDynFlags+ let dflags' = (`xopt_set` LangExt.ExtendedDefaultRules)+ . (`xopt_unset` LangExt.MonomorphismRestriction)+ $ dflags+ GHC.setInteractiveDynFlags dflags'++ lastErrLocationsRef <- liftIO $ newIORef []+ progDynFlags <- GHC.getProgramDynFlags+ _ <- GHC.setProgramDynFlags $+ progDynFlags { log_action = ghciLogAction lastErrLocationsRef }++ when (isNothing maybe_exprs) $ do+ -- Only for GHCi (not runghc and ghc -e):++ -- Turn buffering off for the compiled program's stdout/stderr+ turnOffBuffering_ nobuffering+ -- Turn buffering off for GHCi's stdout+ liftIO $ hFlush stdout+ liftIO $ hSetBuffering stdout NoBuffering+ -- We don't want the cmd line to buffer any input that might be+ -- intended for the program, so unbuffer stdin.+ liftIO $ hSetBuffering stdin NoBuffering+ liftIO $ hSetBuffering stderr NoBuffering+#if defined(mingw32_HOST_OS)+ -- On Unix, stdin will use the locale encoding. The IO library+ -- doesn't do this on Windows (yet), so for now we use UTF-8,+ -- for consistency with GHC 6.10 and to make the tests work.+ liftIO $ hSetEncoding stdin utf8+#endif++ default_editor <- liftIO $ findEditor+ eval_wrapper <- mkEvalWrapper default_progname default_args+ let prelude_import = simpleImportDecl preludeModuleName+ startGHCi (runGHCi srcs maybe_exprs)+ GHCiState{ progname = default_progname,+ args = default_args,+ evalWrapper = eval_wrapper,+ prompt = default_prompt,+ prompt_cont = default_prompt_cont,+ stop = default_stop,+ editor = default_editor,+ options = [],+ -- We initialize line number as 0, not 1, because we use+ -- current line number while reporting errors which is+ -- incremented after reading a line.+ line_number = 0,+ break_ctr = 0,+ breaks = [],+ tickarrays = emptyModuleEnv,+ ghci_commands = availableCommands config,+ ghci_macros = [],+ last_command = Nothing,+ cmdqueue = [],+ remembered_ctx = [],+ transient_ctx = [],+ extra_imports = [],+ prelude_imports = [prelude_import],+ ghc_e = isJust maybe_exprs,+ short_help = shortHelpText config,+ long_help = fullHelpText config,+ lastErrorLocations = lastErrLocationsRef,+ mod_infos = M.empty,+ flushStdHandles = flush,+ noBuffering = nobuffering+ }++ return ()++resetLastErrorLocations :: GHCi ()+resetLastErrorLocations = do+ st <- getGHCiState+ liftIO $ writeIORef (lastErrorLocations st) []++ghciLogAction :: IORef [(FastString, Int)] -> LogAction+ghciLogAction lastErrLocations dflags flag severity srcSpan style msg = do+ defaultLogAction dflags flag severity srcSpan style msg+ case severity of+ SevError -> case srcSpan of+ RealSrcSpan rsp -> modifyIORef lastErrLocations+ (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])+ _ -> return ()+ _ -> return ()++withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a+withGhcAppData right left = do+ either_dir <- tryIO (getAppUserDataDirectory "clash")+ case either_dir of+ Right dir ->+ do createDirectoryIfMissing False dir `catchIO` \_ -> return ()+ right dir+ _ -> left++runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()+runGHCi paths maybe_exprs = do+ dflags <- getDynFlags+ let+ ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags++ current_dir = return (Just ".clashi")++ app_user_dir = liftIO $ withGhcAppData+ (\dir -> return (Just (dir </> "clashi.conf")))+ (return Nothing)++ home_dir = do+ either_dir <- liftIO $ tryIO (getEnv "HOME")+ case either_dir of+ Right home -> return (Just (home </> ".clashi"))+ _ -> return Nothing++ canonicalizePath' :: FilePath -> IO (Maybe FilePath)+ canonicalizePath' fp = liftM Just (canonicalizePath fp)+ `catchIO` \_ -> return Nothing++ sourceConfigFile :: FilePath -> GHCi ()+ sourceConfigFile file = do+ exists <- liftIO $ doesFileExist file+ when exists $ do+ either_hdl <- liftIO $ tryIO (openFile file ReadMode)+ case either_hdl of+ Left _e -> return ()+ -- NOTE: this assumes that runInputT won't affect the terminal;+ -- can we assume this will always be the case?+ -- This would be a good place for runFileInputT.+ Right hdl ->+ do runInputTWithPrefs defaultPrefs defaultSettings $+ runCommands $ fileLoop hdl+ liftIO (hClose hdl `catchIO` \_ -> return ())+ -- Don't print a message if this is really ghc -e (#11478).+ -- Also, let the user silence the message with -v0+ -- (the default verbosity in GHCi is 1).+ when (isNothing maybe_exprs && verbosity dflags > 0) $+ liftIO $ putStrLn ("Loaded Clashi configuration from " ++ file)++ --++ setGHCContextFromGHCiState++ dot_cfgs <- if ignore_dot_ghci then return [] else do+ dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]+ liftIO $ filterM checkFileAndDirPerms dot_files+ mdot_cfgs <- liftIO $ mapM canonicalizePath' dot_cfgs++ let arg_cfgs = reverse $ ghciScripts dflags+ -- -ghci-script are collected in reverse order+ -- We don't require that a script explicitly added by -ghci-script+ -- is owned by the current user. (#6017)+ mapM_ sourceConfigFile $ nub $ (catMaybes mdot_cfgs) ++ arg_cfgs+ -- nub, because we don't want to read .ghci twice if the CWD is $HOME.++ -- Perform a :load for files given on the GHCi command line+ -- When in -e mode, if the load fails then we want to stop+ -- immediately rather than going on to evaluate the expression.+ when (not (null paths)) $ do+ ok <- ghciHandle (\e -> do showException e; return Failed) $+ -- TODO: this is a hack.+ runInputTWithPrefs defaultPrefs defaultSettings $+ loadModule paths+ when (isJust maybe_exprs && failed ok) $+ liftIO (exitWith (ExitFailure 1))++ installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)++ -- if verbosity is greater than 0, or we are connected to a+ -- terminal, display the prompt in the interactive loop.+ is_tty <- liftIO (hIsTerminalDevice stdin)+ let show_prompt = verbosity dflags > 0 || is_tty++ -- reset line number+ modifyGHCiState $ \st -> st{line_number=0}++ case maybe_exprs of+ Nothing ->+ do+ -- enter the interactive loop+ runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty+ Just exprs -> do+ -- just evaluate the expression we were given+ enqueueCommands exprs+ let hdle e = do st <- getGHCiState+ -- flush the interpreter's stdout/stderr on exit (#3890)+ flushInterpBuffers+ -- Jump through some hoops to get the+ -- current progname in the exception text:+ -- <progname>: <exception>+ liftIO $ withProgName (progname st)+ $ topHandler e+ -- this used to be topHandlerFastExit, see #2228+ runInputTWithPrefs defaultPrefs defaultSettings $ do+ -- make `ghc -e` exit nonzero on invalid input, see Trac #7962+ _ <- runCommands' hdle+ (Just $ hdle (toException $ ExitFailure 1) >> return ())+ (return Nothing)+ return ()++ -- and finally, exit+ liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving Clashi."++runGHCiInput :: InputT GHCi a -> GHCi a+runGHCiInput f = do+ dflags <- getDynFlags+ let ghciHistory = gopt Opt_GhciHistory dflags+ let localGhciHistory = gopt Opt_LocalGhciHistory dflags+ currentDirectory <- liftIO $ getCurrentDirectory++ histFile <- case (ghciHistory, localGhciHistory) of+ (True, True) -> return (Just (currentDirectory </> ".clashi_history"))+ (True, _) -> liftIO $ withGhcAppData+ (\dir -> return (Just (dir </> "clashi_history"))) (return Nothing)+ _ -> return Nothing++ runInputT+ (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})+ f++-- | How to get the next input line from the user+nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)+nextInputLine show_prompt is_tty+ | is_tty = do+ prmpt <- if show_prompt then lift mkPrompt else return ""+ r <- getInputLine prmpt+ incrementLineNo+ return r+ | otherwise = do+ when show_prompt $ lift mkPrompt >>= liftIO . putStr+ fileLoop stdin++-- NOTE: We only read .ghci files if they are owned by the current user,+-- and aren't world writable (files owned by root are ok, see #9324).+-- Otherwise, we could be accidentally running code planted by+-- a malicious third party.++-- Furthermore, We only read ./.ghci if . is owned by the current user+-- and isn't writable by anyone else. I think this is sufficient: we+-- don't need to check .. and ../.. etc. because "." always refers to+-- the same directory while a process is running.++checkFileAndDirPerms :: FilePath -> IO Bool+checkFileAndDirPerms file = do+ file_ok <- checkPerms file+ -- Do not check dir perms when .ghci doesn't exist, otherwise GHCi will+ -- print some confusing and useless warnings in some cases (e.g. in+ -- travis). Note that we can't add a test for this, as all ghci tests should+ -- run with -ignore-dot-ghci, which means we never get here.+ if file_ok then checkPerms (getDirectory file) else return False+ where+ getDirectory f = case takeDirectory f of+ "" -> "."+ d -> d++checkPerms :: FilePath -> IO Bool+#if defined(mingw32_HOST_OS)+checkPerms _ = return True+#else+checkPerms file =+ handleIO (\_ -> return False) $ do+ st <- getFileStatus file+ me <- getRealUserID+ let mode = System.Posix.fileMode st+ ok = (fileOwner st == me || fileOwner st == 0) &&+ groupWriteMode /= mode `intersectFileModes` groupWriteMode &&+ otherWriteMode /= mode `intersectFileModes` otherWriteMode+ unless ok $+ -- #8248: Improving warning to include a possible fix.+ putStrLn $ "*** WARNING: " ++ file +++ " is writable by someone else, IGNORING!" +++ "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"+ return ok+#endif++incrementLineNo :: InputT GHCi ()+incrementLineNo = modifyGHCiState incLineNo+ where+ incLineNo st = st { line_number = line_number st + 1 }++fileLoop :: Handle -> InputT GHCi (Maybe String)+fileLoop hdl = do+ l <- liftIO $ tryIO $ hGetLine hdl+ case l of+ Left e | isEOFError e -> return Nothing+ | -- as we share stdin with the program, the program+ -- might have already closed it, so we might get a+ -- handle-closed exception. We therefore catch that+ -- too.+ isIllegalOperation e -> return Nothing+ | InvalidArgument <- etype -> return Nothing+ | otherwise -> liftIO $ ioError e+ where etype = ioeGetErrorType e+ -- treat InvalidArgument in the same way as EOF:+ -- this can happen if the user closed stdin, or+ -- perhaps did getContents which closes stdin at+ -- EOF.+ Right l' -> do+ incrementLineNo+ return (Just l')++formatCurrentTime :: String -> IO String+formatCurrentTime format =+ getZonedTime >>= return . (formatTime defaultTimeLocale format)++getUserName :: IO String+getUserName = do+#if defined(mingw32_HOST_OS)+ getEnv "USERNAME"+ `catchIO` \e -> do+ putStrLn $ show e+ return ""+#else+ getLoginName+#endif++getInfoForPrompt :: GHCi (SDoc, [String], Int)+getInfoForPrompt = do+ st <- getGHCiState+ imports <- GHC.getContext+ resumes <- GHC.getResumeContext++ context_bit <-+ case resumes of+ [] -> return empty+ r:_ -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (brackets (ppr (GHC.resumeSpan r)) <> space)+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ pan <- GHC.getHistorySpan hist+ return (brackets (ppr (negate ix) <> char ':'+ <+> ppr pan) <> space)++ let+ dots | _:rs <- resumes, not (null rs) = text "... "+ | otherwise = empty++ rev_imports = reverse imports -- rightmost are the most recent++ myIdeclName d | Just m <- ideclAs d = unLoc m+ | otherwise = unLoc (ideclName d)++ modules_names =+ ['*':(moduleNameString m) | IIModule m <- rev_imports] +++ [moduleNameString (myIdeclName d) | IIDecl d <- rev_imports]+ line = 1 + line_number st++ return (dots <> context_bit, modules_names, line)++parseCallEscape :: String -> (String, String)+parseCallEscape s+ | not (all isSpace beforeOpen) = ("", "")+ | null sinceOpen = ("", "")+ | null sinceClosed = ("", "")+ | null cmd = ("", "")+ | otherwise = (cmd, tail sinceClosed)+ where+ (beforeOpen, sinceOpen) = span (/='(') s+ (cmd, sinceClosed) = span (/=')') (tail sinceOpen)++checkPromptStringForErrors :: String -> Maybe String+checkPromptStringForErrors ('%':'c':'a':'l':'l':xs) =+ case parseCallEscape xs of+ ("", "") -> Just ("Incorrect %call syntax. " +++ "Should be %call(a command and arguments).")+ (_, afterClosed) -> checkPromptStringForErrors afterClosed+checkPromptStringForErrors ('%':'%':xs) = checkPromptStringForErrors xs+checkPromptStringForErrors (_:xs) = checkPromptStringForErrors xs+checkPromptStringForErrors "" = Nothing++generatePromptFunctionFromString :: String -> PromptFunction+generatePromptFunctionFromString promptS modules_names line =+ processString promptS+ where+ processString :: String -> GHCi SDoc+ processString ('%':'s':xs) =+ liftM2 (<>) (return modules_list) (processString xs)+ where+ modules_list = hsep $ map text modules_names+ processString ('%':'l':xs) =+ liftM2 (<>) (return $ ppr line) (processString xs)+ processString ('%':'d':xs) =+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%a %b %d"+ processString ('%':'t':xs) =+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%H:%M:%S"+ processString ('%':'T':xs) = do+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%I:%M:%S"+ processString ('%':'@':xs) = do+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%I:%M %P"+ processString ('%':'A':xs) = do+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%H:%M"+ processString ('%':'u':xs) =+ liftM2 (<>) (liftM text user_name) (processString xs)+ where+ user_name = liftIO $ getUserName+ processString ('%':'w':xs) =+ liftM2 (<>) (liftM text current_directory) (processString xs)+ where+ current_directory = liftIO $ getCurrentDirectory+ processString ('%':'o':xs) =+ liftM ((text os) <>) (processString xs)+ processString ('%':'a':xs) =+ liftM ((text arch) <>) (processString xs)+ processString ('%':'N':xs) =+ liftM ((text compilerName) <>) (processString xs)+ processString ('%':'V':xs) =+ liftM ((text $ showVersion compilerVersion) <>) (processString xs)+ processString ('%':'c':'a':'l':'l':xs) = do+ respond <- liftIO $ do+ (code, out, err) <-+ readProcessWithExitCode+ (head list_words) (tail list_words) ""+ `catchIO` \e -> return (ExitFailure 1, "", show e)+ case code of+ ExitSuccess -> return out+ _ -> do+ hPutStrLn stderr err+ return ""+ liftM ((text respond) <>) (processString afterClosed)+ where+ (cmd, afterClosed) = parseCallEscape xs+ list_words = words cmd+ processString ('%':'%':xs) =+ liftM ((char '%') <>) (processString xs)+ processString (x:xs) =+ liftM (char x <>) (processString xs)+ processString "" =+ return empty++mkPrompt :: GHCi String+mkPrompt = do+ st <- getGHCiState+ dflags <- getDynFlags+ (context, modules_names, line) <- getInfoForPrompt++ prompt_string <- (prompt st) modules_names line+ let prompt_doc = context <> prompt_string++ return (showSDoc dflags prompt_doc)++queryQueue :: GHCi (Maybe String)+queryQueue = do+ st <- getGHCiState+ case cmdqueue st of+ [] -> return Nothing+ c:cs -> do setGHCiState st{ cmdqueue = cs }+ return (Just c)++-- Reconfigurable pretty-printing Ticket #5461+installInteractivePrint :: Maybe String -> Bool -> GHCi ()+installInteractivePrint Nothing _ = return ()+installInteractivePrint (Just ipFun) exprmode = do+ ok <- trySuccess $ do+ name <- head <$> GHC.parseName ipFun+ modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name+ in he{hsc_IC = new_ic})+ return Succeeded++ when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))++-- | The main read-eval-print loop+runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()+runCommands gCmd = runCommands' handler Nothing gCmd >> return ()++runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler+ -> Maybe (GHCi ()) -- ^ Source error handler+ -> InputT GHCi (Maybe String)+ -> InputT GHCi (Maybe Bool)+ -- We want to return () here, but have to return (Maybe Bool)+ -- because gmask is not polymorphic enough: we want to use+ -- unmask at two different types.+runCommands' eh sourceErrorHandler gCmd = gmask $ \unmask -> do+ b <- ghandle (\e -> case fromException e of+ Just UserInterrupt -> return $ Just False+ _ -> case fromException e of+ Just ghce ->+ do liftIO (print (ghce :: GhcException))+ return Nothing+ _other ->+ liftIO (Exception.throwIO e))+ (unmask $ runOneCommand eh gCmd)+ case b of+ Nothing -> return Nothing+ Just success -> do+ unless success $ maybe (return ()) lift sourceErrorHandler+ unmask $ runCommands' eh sourceErrorHandler gCmd++-- | Evaluate a single line of user input (either :<command> or Haskell code).+-- A result of Nothing means there was no more input to process.+-- Otherwise the result is Just b where b is True if the command succeeded;+-- this is relevant only to ghc -e, which will exit with status 1+-- if the command was unsuccessful. GHCi will continue in either case.+runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)+ -> InputT GHCi (Maybe Bool)+runOneCommand eh gCmd = do+ -- run a previously queued command if there is one, otherwise get new+ -- input from user+ mb_cmd0 <- noSpace (lift queryQueue)+ mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0+ case mb_cmd1 of+ Nothing -> return Nothing+ Just c -> ghciHandle (\e -> lift $ eh e >>= return . Just) $+ handleSourceError printErrorAndFail+ (doCommand c)+ -- source error's are handled by runStmt+ -- is the handler necessary here?+ where+ printErrorAndFail err = do+ GHC.printException err+ return $ Just False -- Exit ghc -e, but not GHCi++ noSpace q = q >>= maybe (return Nothing)+ (\c -> case removeSpaces c of+ "" -> noSpace q+ ":{" -> multiLineCmd q+ _ -> return (Just c) )+ multiLineCmd q = do+ st <- getGHCiState+ let p = prompt st+ setGHCiState st{ prompt = prompt_cont st }+ mb_cmd <- collectCommand q "" `GHC.gfinally`+ modifyGHCiState (\st' -> st' { prompt = p })+ return mb_cmd+ -- we can't use removeSpaces for the sublines here, so+ -- multiline commands are somewhat more brittle against+ -- fileformat errors (such as \r in dos input on unix),+ -- we get rid of any extra spaces for the ":}" test;+ -- we also avoid silent failure if ":}" is not found;+ -- and since there is no (?) valid occurrence of \r (as+ -- opposed to its String representation, "\r") inside a+ -- ghci command, we replace any such with ' ' (argh:-(+ collectCommand q c = q >>=+ maybe (liftIO (ioError collectError))+ (\l->if removeSpaces l == ":}"+ then return (Just c)+ else collectCommand q (c ++ "\n" ++ map normSpace l))+ where normSpace '\r' = ' '+ normSpace x = x+ -- SDM (2007-11-07): is userError the one to use here?+ collectError = userError "unterminated multiline command :{ .. :}"++ -- | Handle a line of input+ doCommand :: String -> InputT GHCi (Maybe Bool)++ -- command+ doCommand stmt | (':' : cmd) <- removeSpaces stmt = do+ result <- specialCommand cmd+ case result of+ True -> return Nothing+ _ -> return $ Just True++ -- haskell+ doCommand stmt = do+ -- if 'stmt' was entered via ':{' it will contain '\n's+ let stmt_nl_cnt = length [ () | '\n' <- stmt ]+ ml <- lift $ isOptionSet Multiline+ if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input+ then do+ fst_line_num <- line_number <$> getGHCiState+ mb_stmt <- checkInputForLayout stmt gCmd+ case mb_stmt of+ Nothing -> return $ Just True+ Just ml_stmt -> do+ -- temporarily compensate line-number for multi-line input+ result <- timeIt runAllocs $ lift $+ runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion+ return $ Just (runSuccess result)+ else do -- single line input and :{ - multiline input+ last_line_num <- line_number <$> getGHCiState+ -- reconstruct first line num from last line num and stmt+ let fst_line_num | stmt_nl_cnt > 0 = last_line_num - (stmt_nl_cnt2 + 1)+ | otherwise = last_line_num -- single line input+ stmt_nl_cnt2 = length [ () | '\n' <- stmt' ]+ stmt' = dropLeadingWhiteLines stmt -- runStmt doesn't like leading empty lines+ -- temporarily compensate line-number for multi-line input+ result <- timeIt runAllocs $ lift $+ runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion+ return $ Just (runSuccess result)++ -- runStmt wrapper for temporarily overridden line-number+ runStmtWithLineNum :: Int -> String -> SingleStep+ -> GHCi (Maybe GHC.ExecResult)+ runStmtWithLineNum lnum stmt step = do+ st0 <- getGHCiState+ setGHCiState st0 { line_number = lnum }+ result <- runStmt stmt step+ -- restore original line_number+ getGHCiState >>= \st -> setGHCiState st { line_number = line_number st0 }+ return result++ -- note: this is subtly different from 'unlines . dropWhile (all isSpace) . lines'+ dropLeadingWhiteLines s | (l0,'\n':r) <- break (=='\n') s+ , all isSpace l0 = dropLeadingWhiteLines r+ | otherwise = s+++-- #4316+-- lex the input. If there is an unclosed layout context, request input+checkInputForLayout :: String -> InputT GHCi (Maybe String)+ -> InputT GHCi (Maybe String)+checkInputForLayout stmt getStmt = do+ dflags' <- getDynFlags+ let dflags = xopt_set dflags' LangExt.AlternativeLayoutRule+ st0 <- getGHCiState+ let buf' = stringToStringBuffer stmt+ loc = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1+ pstate = Lexer.mkPState dflags buf' loc+ case Lexer.unP goToEnd pstate of+ (Lexer.POk _ False) -> return $ Just stmt+ _other -> do+ st1 <- getGHCiState+ let p = prompt st1+ setGHCiState st1{ prompt = prompt_cont st1 }+ mb_stmt <- ghciHandle (\ex -> case fromException ex of+ Just UserInterrupt -> return Nothing+ _ -> case fromException ex of+ Just ghce ->+ do liftIO (print (ghce :: GhcException))+ return Nothing+ _other -> liftIO (Exception.throwIO ex))+ getStmt+ modifyGHCiState (\st' -> st' { prompt = p })+ -- the recursive call does not recycle parser state+ -- as we use a new string buffer+ case mb_stmt of+ Nothing -> return Nothing+ Just str -> if str == ""+ then return $ Just stmt+ else do+ checkInputForLayout (stmt++"\n"++str) getStmt+ where goToEnd = do+ eof <- Lexer.nextIsEOF+ if eof+ then Lexer.activeContext+ else Lexer.lexer False return >> goToEnd++enqueueCommands :: [String] -> GHCi ()+enqueueCommands cmds = do+ -- make sure we force any exceptions in the commands while we're+ -- still inside the exception handler, otherwise bad things will+ -- happen (see #10501)+ cmds `deepseq` return ()+ modifyGHCiState $ \st -> st{ cmdqueue = cmds ++ cmdqueue st }++-- | Entry point to execute some haskell code from user.+-- The return value True indicates success, as in `runOneCommand`.+runStmt :: String -> SingleStep -> GHCi (Maybe GHC.ExecResult)+runStmt stmt step = do+ dflags <- GHC.getInteractiveDynFlags+ -- In GHCi, we disable `-fdefer-type-errors`, as well as `-fdefer-type-holes`+ -- and `-fdefer-out-of-scope-variables` for **naked expressions**. The+ -- declarations and statements are not affected.+ -- See Note [Deferred type errors in GHCi] in typecheck/TcRnDriver.hs+ if | GHC.isStmt dflags stmt -> run_stmt+ | GHC.isImport dflags stmt -> run_import+ -- Every import declaration should be handled by `run_import`. As GHCi+ -- in general only accepts one command at a time, we simply throw an+ -- exception when the input contains multiple commands of which at least+ -- one is an import command (see #10663).+ | GHC.hasImport dflags stmt -> throwGhcException+ (CmdLineError "error: expecting a single import declaration")+ -- Note: `GHC.isDecl` returns False on input like+ -- `data Infix a b = a :@: b; infixl 4 :@:`+ -- and should therefore not be used here.+ | otherwise -> run_decl++ where+ run_import = do+ addImportToContext stmt+ return (Just (GHC.ExecComplete (Right []) 0))++ run_decl =+ do _ <- liftIO $ tryIO $ hFlushAll stdin+ m_result <- GhciMonad.runDecls stmt+ case m_result of+ Nothing -> return Nothing+ Just result ->+ Just <$> afterRunStmt (const True)+ (GHC.ExecComplete (Right result) 0)++ run_stmt =+ do -- In the new IO library, read handles buffer data even if the Handle+ -- is set to NoBuffering. This causes problems for GHCi where there+ -- are really two stdin Handles. So we flush any bufferred data in+ -- GHCi's stdin Handle here (only relevant if stdin is attached to+ -- a file, otherwise the read buffer can't be flushed).+ _ <- liftIO $ tryIO $ hFlushAll stdin+ m_result <- GhciMonad.runStmt stmt step+ case m_result of+ Nothing -> return Nothing+ Just result -> Just <$> afterRunStmt (const True) result++-- | Clean up the GHCi environment after a statement has run+afterRunStmt :: (SrcSpan -> Bool) -> GHC.ExecResult -> GHCi GHC.ExecResult+afterRunStmt step_here run_result = do+ resumes <- GHC.getResumeContext+ case run_result of+ GHC.ExecComplete{..} ->+ case execResult of+ Left ex -> liftIO $ Exception.throwIO ex+ Right names -> do+ show_types <- isOptionSet ShowType+ when show_types $ printTypeOfNames names+ GHC.ExecBreak names mb_info+ | isNothing mb_info ||+ step_here (GHC.resumeSpan $ head resumes) -> do+ mb_id_loc <- toBreakIdAndLocation mb_info+ let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc+ if (null bCmd)+ then printStoppedAtBreakInfo (head resumes) names+ else enqueueCommands [bCmd]+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]+ return ()+ | otherwise -> resume step_here GHC.SingleStep >>=+ afterRunStmt step_here >> return ()++ flushInterpBuffers+ withSignalHandlers $ do+ b <- isOptionSet RevertCAFs+ when b revertCAFs++ return run_result++runSuccess :: Maybe GHC.ExecResult -> Bool+runSuccess run_result+ | Just (GHC.ExecComplete { execResult = Right _ }) <- run_result = True+ | otherwise = False++runAllocs :: Maybe GHC.ExecResult -> Maybe Integer+runAllocs m = do+ res <- m+ case res of+ GHC.ExecComplete{..} -> Just (fromIntegral execAllocation)+ _ -> Nothing++toBreakIdAndLocation ::+ Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))+toBreakIdAndLocation Nothing = return Nothing+toBreakIdAndLocation (Just inf) = do+ let md = GHC.breakInfo_module inf+ nm = GHC.breakInfo_number inf+ st <- getGHCiState+ return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,+ breakModule loc == md,+ breakTick loc == nm ]++printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()+printStoppedAtBreakInfo res names = do+ printForUser $ pprStopped res+ -- printTypeOfNames session names+ let namesSorted = sortBy compareNames names+ tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted+ docs <- mapM pprTypeAndContents [i | AnId i <- tythings]+ printForUserPartWay $ vcat docs++printTypeOfNames :: [Name] -> GHCi ()+printTypeOfNames names+ = mapM_ (printTypeOfName ) $ sortBy compareNames names++compareNames :: Name -> Name -> Ordering+n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2+ where compareWith n = (getOccString n, getSrcSpan n)++printTypeOfName :: Name -> GHCi ()+printTypeOfName n+ = do maybe_tything <- GHC.lookupName n+ case maybe_tything of+ Nothing -> return ()+ Just thing -> printTyThing thing+++data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand++-- | Entry point for execution a ':<command>' input from user+specialCommand :: String -> InputT GHCi Bool+specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)+specialCommand str = do+ let (cmd,rest) = break isSpace str+ maybe_cmd <- lift $ lookupCommand cmd+ htxt <- short_help <$> getGHCiState+ case maybe_cmd of+ GotCommand cmd -> (cmdAction cmd) (dropWhile isSpace rest)+ BadCommand ->+ do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"+ ++ htxt)+ return False+ NoLastCommand ->+ do liftIO $ hPutStr stdout ("there is no last command to perform\n"+ ++ htxt)+ return False++shellEscape :: String -> GHCi Bool+shellEscape str = liftIO (system str >> return False)++lookupCommand :: String -> GHCi (MaybeCommand)+lookupCommand "" = do+ st <- getGHCiState+ case last_command st of+ Just c -> return $ GotCommand c+ Nothing -> return NoLastCommand+lookupCommand str = do+ mc <- lookupCommand' str+ modifyGHCiState (\st -> st { last_command = mc })+ return $ case mc of+ Just c -> GotCommand c+ Nothing -> BadCommand++lookupCommand' :: String -> GHCi (Maybe Command)+lookupCommand' ":" = return Nothing+lookupCommand' str' = do+ macros <- ghci_macros <$> getGHCiState+ ghci_cmds <- ghci_commands <$> getGHCiState++ let ghci_cmds_nohide = filter (not . cmdHidden) ghci_cmds++ let (str, xcmds) = case str' of+ ':' : rest -> (rest, []) -- "::" selects a builtin command+ _ -> (str', macros) -- otherwise include macros in lookup++ lookupExact s = find $ (s ==) . cmdName+ lookupPrefix s = find $ (s `isPrefixOf`) . cmdName++ -- hidden commands can only be matched exact+ builtinPfxMatch = lookupPrefix str ghci_cmds_nohide++ -- first, look for exact match (while preferring macros); then, look+ -- for first prefix match (preferring builtins), *unless* a macro+ -- overrides the builtin; see #8305 for motivation+ return $ lookupExact str xcmds <|>+ lookupExact str ghci_cmds <|>+ (builtinPfxMatch >>= \c -> lookupExact (cmdName c) xcmds) <|>+ builtinPfxMatch <|>+ lookupPrefix str xcmds++getCurrentBreakSpan :: GHCi (Maybe SrcSpan)+getCurrentBreakSpan = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (Just (GHC.resumeSpan r))+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ pan <- GHC.getHistorySpan hist+ return (Just pan)++getCallStackAtCurrentBreakpoint :: GHCi (Maybe [String])+getCallStackAtCurrentBreakpoint = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ hsc_env <- GHC.getSession+ Just <$> liftIO (costCentreStackInfo hsc_env (GHC.resumeCCS r))++getCurrentBreakModule :: GHCi (Maybe Module)+getCurrentBreakModule = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ return $ Just $ GHC.getHistoryModule hist++-----------------------------------------------------------------------------+--+-- Commands+--+-----------------------------------------------------------------------------++noArgs :: GHCi () -> String -> GHCi ()+noArgs m "" = m+noArgs _ _ = liftIO $ putStrLn "This command takes no arguments"++withSandboxOnly :: String -> GHCi () -> GHCi ()+withSandboxOnly cmd this = do+ dflags <- getDynFlags+ if not (gopt Opt_GhciSandbox dflags)+ then printForUser (text cmd <+>+ ptext (sLit "is not supported with -fno-ghci-sandbox"))+ else this++-----------------------------------------------------------------------------+-- :help++help :: String -> GHCi ()+help _ = do+ txt <- long_help `fmap` getGHCiState+ liftIO $ putStr txt++-----------------------------------------------------------------------------+-- :info++info :: Bool -> String -> InputT GHCi ()+info _ "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'")+info allInfo s = handleSourceError GHC.printException $ do+ unqual <- GHC.getPrintUnqual+ dflags <- getDynFlags+ sdocs <- mapM (infoThing allInfo) (words s)+ mapM_ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs++infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc+infoThing allInfo str = do+ names <- GHC.parseName str+ mb_stuffs <- mapM (GHC.getInfo allInfo) names+ let filtered = filterOutChildren (\(t,_f,_ci,_fi,_sd) -> t)+ (catMaybes mb_stuffs)+ return $ vcat (intersperse (text "") $ map pprInfo filtered)++ -- Filter out names whose parent is also there Good+ -- example is '[]', which is both a type and data+ -- constructor in the same type+filterOutChildren :: (a -> TyThing) -> [a] -> [a]+filterOutChildren get_thing xs+ = filterOut has_parent xs+ where+ all_names = mkNameSet (map (getName . get_thing) xs)+ has_parent x = case tyThingParent_maybe (get_thing x) of+ Just p -> getName p `elemNameSet` all_names+ Nothing -> False++pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc+pprInfo (thing, fixity, cls_insts, fam_insts, docs)+ = docs+ $$ pprTyThingInContextLoc thing+ $$ show_fixity+ $$ vcat (map GHC.pprInstance cls_insts)+ $$ vcat (map GHC.pprFamInst fam_insts)+ where+ show_fixity+ | fixity == GHC.defaultFixity = empty+ | otherwise = ppr fixity <+> pprInfixName (GHC.getName thing)++-----------------------------------------------------------------------------+-- :main++runMain :: String -> GHCi ()+runMain s = case toArgs s of+ Left err -> liftIO (hPutStrLn stderr err)+ Right args ->+ do dflags <- getDynFlags+ let main = fromMaybe "main" (mainFunIs dflags)+ -- Wrap the main function in 'void' to discard its value instead+ -- of printing it (#9086). See Haskell 2010 report Chapter 5.+ doWithArgs args $ "Control.Monad.void (" ++ main ++ ")"++-----------------------------------------------------------------------------+-- :run++runRun :: String -> GHCi ()+runRun s = case toCmdArgs s of+ Left err -> liftIO (hPutStrLn stderr err)+ Right (cmd, args) -> doWithArgs args cmd++doWithArgs :: [String] -> String -> GHCi ()+doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " +++ show args ++ " (" ++ cmd ++ ")"]++-----------------------------------------------------------------------------+-- :cd++changeDirectory :: String -> InputT GHCi ()+changeDirectory "" = do+ -- :cd on its own changes to the user's home directory+ either_dir <- liftIO $ tryIO getHomeDirectory+ case either_dir of+ Left _e -> return ()+ Right dir -> changeDirectory dir+changeDirectory dir = do+ graph <- GHC.getModuleGraph+ when (not (null $ GHC.mgModSummaries graph)) $+ liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."+ GHC.setTargets []+ _ <- GHC.load LoadAllTargets+ lift $ setContextAfterLoad False []+ GHC.workingDirectoryChanged+ dir' <- expandPath dir+ liftIO $ setCurrentDirectory dir'+ dflags <- getDynFlags+ -- With -fexternal-interpreter, we have to change the directory of the subprocess too.+ -- (this gives consistent behavior with and without -fexternal-interpreter)+ when (gopt Opt_ExternalInterpreter dflags) $+ lift $ enqueueCommands ["System.Directory.setCurrentDirectory " ++ show dir']++trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag+trySuccess act =+ handleSourceError (\e -> do GHC.printException e+ return Failed) $ do+ act++-----------------------------------------------------------------------------+-- :edit++editFile :: String -> InputT GHCi ()+editFile str =+ do file <- if null str then lift chooseEditFile else expandPath str+ st <- getGHCiState+ errs <- liftIO $ readIORef $ lastErrorLocations st+ let cmd = editor st+ when (null cmd)+ $ throwGhcException (CmdLineError "editor not set, use :set editor")+ lineOpt <- liftIO $ do+ let sameFile p1 p2 = liftA2 (==) (canonicalizePath p1) (canonicalizePath p2)+ `catchIO` (\_ -> return False)++ curFileErrs <- filterM (\(f, _) -> unpackFS f `sameFile` file) errs+ return $ case curFileErrs of+ (_, line):_ -> " +" ++ show line+ _ -> ""+ let cmdArgs = ' ':(file ++ lineOpt)+ code <- liftIO $ system (cmd ++ cmdArgs)++ when (code == ExitSuccess)+ $ reloadModule ""++-- The user didn't specify a file so we pick one for them.+-- Our strategy is to pick the first module that failed to load,+-- or otherwise the first target.+--+-- XXX: Can we figure out what happened if the depndecy analysis fails+-- (e.g., because the porgrammeer mistyped the name of a module)?+-- XXX: Can we figure out the location of an error to pass to the editor?+-- XXX: if we could figure out the list of errors that occured during the+-- last load/reaload, then we could start the editor focused on the first+-- of those.+chooseEditFile :: GHCi String+chooseEditFile =+ do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x++ graph <- GHC.getModuleGraph+ failed_graph <-+ GHC.mkModuleGraph <$> filterM hasFailed (GHC.mgModSummaries graph)+ let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing+ pick xs = case xs of+ x : _ -> GHC.ml_hs_file (GHC.ms_location x)+ _ -> Nothing++ case pick (order failed_graph) of+ Just file -> return file+ Nothing ->+ do targets <- GHC.getTargets+ case msum (map fromTarget targets) of+ Just file -> return file+ Nothing -> throwGhcException (CmdLineError "No files to edit.")++ where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f+ fromTarget _ = Nothing -- when would we get a module target?+++-----------------------------------------------------------------------------+-- :def++defineMacro :: Bool{-overwrite-} -> String -> GHCi ()+defineMacro _ (':':_) =+ liftIO $ putStrLn "macro name cannot start with a colon"+defineMacro overwrite s = do+ let (macro_name, definition) = break isSpace s+ macros <- ghci_macros <$> getGHCiState+ let defined = map cmdName macros+ if null macro_name+ then if null defined+ then liftIO $ putStrLn "no macros defined"+ else liftIO $ putStr ("the following macros are defined:\n" +++ unlines defined)+ else do+ if (not overwrite && macro_name `elem` defined)+ then throwGhcException (CmdLineError+ ("macro '" ++ macro_name ++ "' is already defined"))+ else do++ -- compile the expression+ handleSourceError GHC.printException $ do+ step <- getGhciStepIO+ expr <- GHC.parseExpr definition+ -- > ghciStepIO . definition :: String -> IO String+ let stringTy = nlHsTyVar stringTy_RDR+ ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy+ body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)+ `mkHsApp` (nlHsPar expr)+ tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM)+ new_expr = L (getLoc expr) $ ExprWithTySig tySig body+ hv <- GHC.compileParsedExprRemote new_expr++ let newCmd = Command { cmdName = macro_name+ , cmdAction = lift . runMacro hv+ , cmdHidden = False+ , cmdCompletionFunc = noCompletion+ }++ -- later defined macros have precedence+ modifyGHCiState $ \s ->+ let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]+ in s { ghci_macros = newCmd : filtered }++runMacro :: GHC.ForeignHValue{-String -> IO String-} -> String -> GHCi Bool+runMacro fun s = do+ hsc_env <- GHC.getSession+ str <- liftIO $ evalStringToIOString hsc_env fun s+ enqueueCommands (lines str)+ return False+++-----------------------------------------------------------------------------+-- :undef++undefineMacro :: String -> GHCi ()+undefineMacro str = mapM_ undef (words str)+ where undef macro_name = do+ cmds <- ghci_macros <$> getGHCiState+ if (macro_name `notElem` map cmdName cmds)+ then throwGhcException (CmdLineError+ ("macro '" ++ macro_name ++ "' is not defined"))+ else do+ -- This is a tad racy but really, it's a shell+ modifyGHCiState $ \s ->+ s { ghci_macros = filter ((/= macro_name) . cmdName)+ (ghci_macros s) }+++-----------------------------------------------------------------------------+-- :cmd++cmdCmd :: String -> GHCi ()+cmdCmd str = handleSourceError GHC.printException $ do+ step <- getGhciStepIO+ expr <- GHC.parseExpr str+ -- > ghciStepIO str :: IO String+ let new_expr = step `mkHsApp` expr+ hv <- GHC.compileParsedExprRemote new_expr++ hsc_env <- GHC.getSession+ cmds <- liftIO $ evalString hsc_env hv+ enqueueCommands (lines cmds)++-- | Generate a typed ghciStepIO expression+-- @ghciStepIO :: Ty String -> IO String@.+getGhciStepIO :: GHCi (LHsExpr GhcPs)+getGhciStepIO = do+ ghciTyConName <- GHC.getGHCiMonad+ let stringTy = nlHsTyVar stringTy_RDR+ ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy+ ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy+ body = nlHsVar (getRdrName ghciStepIoMName)+ tySig = mkLHsSigWcType (ghciM `nlHsFunTy` ioM)+ return $ noLoc $ ExprWithTySig tySig body++-----------------------------------------------------------------------------+-- :check++checkModule :: String -> InputT GHCi ()+checkModule m = do+ let modl = GHC.mkModuleName m+ ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do+ r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl+ dflags <- getDynFlags+ liftIO $ putStrLn $ showSDoc dflags $+ case GHC.moduleInfo r of+ cm | Just scope <- GHC.modInfoTopLevelScope cm ->+ let+ (loc, glob) = ASSERT( all isExternalName scope )+ partition ((== modl) . GHC.moduleName . GHC.nameModule) scope+ in+ (text "global names: " <+> ppr glob) $$+ (text "local names: " <+> ppr loc)+ _ -> empty+ return True+ afterLoad (successIf ok) False++-----------------------------------------------------------------------------+-- :doc++docCmd :: String -> InputT GHCi ()+docCmd "" =+ throwGhcException (CmdLineError "syntax: ':doc <thing-you-want-docs-for>'")+docCmd s = do+ -- TODO: Maybe also get module headers for module names+ names <- GHC.parseName s+ e_docss <- mapM GHC.getDocs names+ sdocs <- mapM (either handleGetDocsFailure (pure . pprDocs)) e_docss+ let sdocs' = vcat (intersperse (text "") sdocs)+ unqual <- GHC.getPrintUnqual+ dflags <- getDynFlags+ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs'++-- TODO: also print arg docs.+pprDocs :: (Maybe HsDocString, Map Int HsDocString) -> SDoc+pprDocs (mb_decl_docs, _arg_docs) =+ maybe+ (text "<has no documentation>")+ (text . unpackHDS)+ mb_decl_docs++handleGetDocsFailure :: GHC.GhcMonad m => GetDocsFailure -> m SDoc+handleGetDocsFailure no_docs = do+ dflags <- getDynFlags+ let msg = showPpr dflags no_docs+ throwGhcException $ case no_docs of+ NameHasNoModule {} -> Sorry msg+ NoDocsInIface {} -> InstallationError msg+ InteractiveName -> ProgramError msg++-----------------------------------------------------------------------------+-- :load, :add, :reload++-- | Sets '-fdefer-type-errors' if 'defer' is true, executes 'load' and unsets+-- '-fdefer-type-errors' again if it has not been set before.+wrapDeferTypeErrors :: InputT GHCi a -> InputT GHCi a+wrapDeferTypeErrors load =+ gbracket+ (do+ -- Force originalFlags to avoid leaking the associated HscEnv+ !originalFlags <- getDynFlags+ void $ GHC.setProgramDynFlags $+ setGeneralFlag' Opt_DeferTypeErrors originalFlags+ return originalFlags)+ (\originalFlags -> void $ GHC.setProgramDynFlags originalFlags)+ (\_ -> load)++loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag+loadModule fs = timeIt (const Nothing) (loadModule' fs)++-- | @:load@ command+loadModule_ :: [FilePath] -> InputT GHCi ()+loadModule_ fs = void $ loadModule (zip fs (repeat Nothing))++loadModuleDefer :: [FilePath] -> InputT GHCi ()+loadModuleDefer = wrapDeferTypeErrors . loadModule_++loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag+loadModule' files = do+ let (filenames, phases) = unzip files+ exp_filenames <- mapM expandPath filenames+ let files' = zip exp_filenames phases+ targets <- mapM (uncurry GHC.guessTarget) files'++ -- NOTE: we used to do the dependency anal first, so that if it+ -- fails we didn't throw away the current set of modules. This would+ -- require some re-working of the GHC interface, so we'll leave it+ -- as a ToDo for now.++ hsc_env <- GHC.getSession++ -- Grab references to the currently loaded modules so that we can+ -- see if they leak.+ leak_indicators <- if gopt Opt_GhciLeakCheck (hsc_dflags hsc_env)+ then liftIO $ getLeakIndicators hsc_env+ else return (panic "no leak indicators")++ -- unload first+ _ <- GHC.abandonAll+ lift discardActiveBreakPoints+ GHC.setTargets []+ _ <- GHC.load LoadAllTargets++ GHC.setTargets targets+ success <- doLoadAndCollectInfo False LoadAllTargets+ when (gopt Opt_GhciLeakCheck (hsc_dflags hsc_env)) $+ liftIO $ checkLeakIndicators (hsc_dflags hsc_env) leak_indicators+ return success++-- | @:add@ command+addModule :: [FilePath] -> InputT GHCi ()+addModule files = do+ lift revertCAFs -- always revert CAFs on load/add.+ files' <- mapM expandPath files+ targets <- mapM (\m -> GHC.guessTarget m Nothing) files'+ targets' <- filterM checkTarget targets+ -- remove old targets with the same id; e.g. for :add *M+ mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets' ]+ mapM_ GHC.addTarget targets'+ _ <- doLoadAndCollectInfo False LoadAllTargets+ return ()+ where+ checkTarget :: Target -> InputT GHCi Bool+ checkTarget (Target (TargetModule m) _ _) = checkTargetModule m+ checkTarget (Target (TargetFile f _) _ _) = liftIO $ checkTargetFile f++ checkTargetModule :: ModuleName -> InputT GHCi Bool+ checkTargetModule m = do+ hsc_env <- GHC.getSession+ result <- liftIO $+ Finder.findImportedModule hsc_env m (Just (fsLit "this"))+ case result of+ Found _ _ -> return True+ _ -> (liftIO $ putStrLn $+ "Module " ++ moduleNameString m ++ " not found") >> return False++ checkTargetFile :: String -> IO Bool+ checkTargetFile f = do+ exists <- (doesFileExist f) :: IO Bool+ unless exists $ putStrLn $ "File " ++ f ++ " not found"+ return exists++-- | @:unadd@ command+unAddModule :: [FilePath] -> InputT GHCi ()+unAddModule files = do+ files' <- mapM expandPath files+ targets <- mapM (\m -> GHC.guessTarget m Nothing) files'+ mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]+ _ <- doLoadAndCollectInfo False LoadAllTargets+ return ()++-- | @:reload@ command+reloadModule :: String -> InputT GHCi ()+reloadModule m = void $ doLoadAndCollectInfo True loadTargets+ where+ loadTargets | null m = LoadAllTargets+ | otherwise = LoadUpTo (GHC.mkModuleName m)++reloadModuleDefer :: String -> InputT GHCi ()+reloadModuleDefer = wrapDeferTypeErrors . reloadModule++-- | Load/compile targets and (optionally) collect module-info+--+-- This collects the necessary SrcSpan annotated type information (via+-- 'collectInfo') required by the @:all-types@, @:loc-at@, @:type-at@,+-- and @:uses@ commands.+--+-- Meta-info collection is not enabled by default and needs to be+-- enabled explicitly via @:set +c@. The reason is that collecting+-- the type-information for all sub-spans can be quite expensive, and+-- since those commands are designed to be used by editors and+-- tooling, it's useless to collect this data for normal GHCi+-- sessions.+doLoadAndCollectInfo :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag+doLoadAndCollectInfo retain_context howmuch = do+ doCollectInfo <- lift (isOptionSet CollectInfo)++ doLoad retain_context howmuch >>= \case+ Succeeded | doCollectInfo -> do+ mod_summaries <- GHC.mgModSummaries <$> getModuleGraph+ loaded <- filterM GHC.isLoaded $ map GHC.ms_mod_name mod_summaries+ v <- mod_infos <$> getGHCiState+ !newInfos <- collectInfo v loaded+ modifyGHCiState (\st -> st { mod_infos = newInfos })+ return Succeeded+ flag -> return flag++doLoad :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag+doLoad retain_context howmuch = do+ -- turn off breakpoints before we load: we can't turn them off later, because+ -- the ModBreaks will have gone away.+ lift discardActiveBreakPoints++ lift resetLastErrorLocations+ -- Enable buffering stdout and stderr as we're compiling. Keeping these+ -- handles unbuffered will just slow the compilation down, especially when+ -- compiling in parallel.+ gbracket (liftIO $ do hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering)+ (\_ ->+ liftIO $ do hSetBuffering stdout NoBuffering+ hSetBuffering stderr NoBuffering) $ \_ -> do+ ok <- trySuccess $ GHC.load howmuch+ afterLoad ok retain_context+ return ok+++afterLoad :: SuccessFlag+ -> Bool -- keep the remembered_ctx, as far as possible (:reload)+ -> InputT GHCi ()+afterLoad ok retain_context = do+ lift revertCAFs -- always revert CAFs on load.+ lift discardTickArrays+ loaded_mods <- getLoadedModules+ modulesLoadedMsg ok loaded_mods+ lift $ setContextAfterLoad retain_context loaded_mods++setContextAfterLoad :: Bool -> [GHC.ModSummary] -> GHCi ()+setContextAfterLoad keep_ctxt [] = do+ setContextKeepingPackageModules keep_ctxt []+setContextAfterLoad keep_ctxt ms = do+ -- load a target if one is available, otherwise load the topmost module.+ targets <- GHC.getTargets+ case [ m | Just m <- map (findTarget ms) targets ] of+ [] ->+ let graph = GHC.mkModuleGraph ms+ graph' = flattenSCCs (GHC.topSortModuleGraph True graph Nothing)+ in load_this (last graph')+ (m:_) ->+ load_this m+ where+ findTarget mds t+ = case filter (`matches` t) mds of+ [] -> Nothing+ (m:_) -> Just m++ summary `matches` Target (TargetModule m) _ _+ = GHC.ms_mod_name summary == m+ summary `matches` Target (TargetFile f _) _ _+ | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'+ _ `matches` _+ = False++ load_this summary | m <- GHC.ms_mod summary = do+ is_interp <- GHC.moduleIsInterpreted m+ dflags <- getDynFlags+ let star_ok = is_interp && not (safeLanguageOn dflags)+ -- We import the module with a * iff+ -- - it is interpreted, and+ -- - -XSafe is off (it doesn't allow *-imports)+ let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)]+ | otherwise = [mkIIDecl (GHC.moduleName m)]+ setContextKeepingPackageModules keep_ctxt new_ctx+++-- | Keep any package modules (except Prelude) when changing the context.+setContextKeepingPackageModules+ :: Bool -- True <=> keep all of remembered_ctx+ -- False <=> just keep package imports+ -> [InteractiveImport] -- new context+ -> GHCi ()++setContextKeepingPackageModules keep_ctx trans_ctx = do++ st <- getGHCiState+ let rem_ctx = remembered_ctx st+ new_rem_ctx <- if keep_ctx then return rem_ctx+ else keepPackageImports rem_ctx+ setGHCiState st{ remembered_ctx = new_rem_ctx,+ transient_ctx = filterSubsumed new_rem_ctx trans_ctx }+ setGHCContextFromGHCiState++-- | Filters a list of 'InteractiveImport', clearing out any home package+-- imports so only imports from external packages are preserved. ('IIModule'+-- counts as a home package import, because we are only able to bring a+-- full top-level into scope when the source is available.)+keepPackageImports :: [InteractiveImport] -> GHCi [InteractiveImport]+keepPackageImports = filterM is_pkg_import+ where+ is_pkg_import :: InteractiveImport -> GHCi Bool+ is_pkg_import (IIModule _) = return False+ is_pkg_import (IIDecl d)+ = do e <- gtry $ GHC.findModule mod_name (fmap sl_fs $ ideclPkgQual d)+ case e :: Either SomeException Module of+ Left _ -> return False+ Right m -> return (not (isHomeModule m))+ where+ mod_name = unLoc (ideclName d)+++modulesLoadedMsg :: SuccessFlag -> [GHC.ModSummary] -> InputT GHCi ()+modulesLoadedMsg ok mods = do+ dflags <- getDynFlags+ unqual <- GHC.getPrintUnqual++ msg <- if gopt Opt_ShowLoadedModules dflags+ then do+ mod_names <- mapM mod_name mods+ let mod_commas+ | null mods = text "none."+ | otherwise = hsep (punctuate comma mod_names) <> text "."+ return $ status <> text ", modules loaded:" <+> mod_commas+ else do+ return $ status <> text ","+ <+> speakNOf (length mods) (text "module") <+> "loaded."++ when (verbosity dflags > 0) $+ liftIO $ putStrLn $ showSDocForUser dflags unqual msg+ where+ status = case ok of+ Failed -> text "Failed"+ Succeeded -> text "Ok"++ mod_name mod = do+ is_interpreted <- GHC.moduleIsBootOrNotObjectLinkable mod+ return $ if is_interpreted+ then ppr (GHC.ms_mod mod)+ else ppr (GHC.ms_mod mod)+ <+> parens (text $ normalise $ msObjFilePath mod)+ -- Fix #9887++-- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors+-- and printing 'throwE' strings to 'stderr'+runExceptGhcMonad :: GHC.GhcMonad m => ExceptT SDoc m () -> m ()+runExceptGhcMonad act = handleSourceError GHC.printException $+ either handleErr pure =<<+ runExceptT act+ where+ handleErr sdoc = do+ dflags <- getDynFlags+ liftIO . hPutStrLn stderr . showSDocForUser dflags alwaysQualify $ sdoc++-- | Inverse of 'runExceptT' for \"pure\" computations+-- (c.f. 'except' for 'Except')+exceptT :: Applicative m => Either e a -> ExceptT e m a+exceptT = ExceptT . pure++makeHDL' :: Clash.Backend.Backend backend+ => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)+ -> IORef ClashOpts+ -> [FilePath]+ -> InputT GHCi ()+makeHDL' backend opts lst = makeHDL backend opts =<< case lst of+ srcs@(_:_) -> return srcs+ [] -> do+ modGraph <- GHC.getModuleGraph+ let sortedGraph = GHC.topSortModuleGraph False modGraph Nothing+ return $ case (reverse sortedGraph) of+ ((AcyclicSCC top) : _) -> maybeToList $ (GHC.ml_hs_file . GHC.ms_location) top+ _ -> []++makeHDL :: GHC.GhcMonad m+ => Clash.Backend.Backend backend+ => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)+ -> IORef ClashOpts+ -> [FilePath]+ -> m ()+makeHDL backend optsRef srcs = do+ dflags <- GHC.getSessionDynFlags+ liftIO $ do startTime <- Clock.getCurrentTime+ opts0 <- readIORef optsRef+ let opts1 = opts0 { opt_color = useColor dflags }+ iw = opt_intWidth opts1+ fp = opt_floatSupport opts1+ syn = opt_hdlSyn opts1+ color = opt_color opts1+ esc = opt_escapedIds opts1+ frcUdf = opt_forceUndefined opts1+ hdl = Clash.Backend.hdlKind backend'+ -- determine whether `-outputdir` was used+ outputDir = do odir <- objectDir dflags+ hidir <- hiDir dflags+ sdir <- stubDir dflags+ ddir <- dumpDir dflags+ if all (== odir) [hidir,sdir,ddir]+ then Just odir+ else Nothing+ idirs = importPaths dflags+ opts2 = opts1 { opt_hdlDir = maybe outputDir Just (opt_hdlDir opts1)+ , opt_importPaths = idirs}+ backend' = backend iw syn esc frcUdf++ checkMonoLocalBinds dflags+ checkImportDirs opts0 idirs++ primDirs <- Clash.Backend.primDirs backend'++ forM_ srcs $ \src -> do+ -- Generate bindings:+ let dbs = reverse [p | PackageDB (PkgConfFile p) <- packageDBFlags dflags]+ (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs) <-+ generateBindings color primDirs idirs dbs hdl src (Just dflags)+ prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime+ let prepStartDiff = reportTimeDiff prepTime startTime+ putStrLn $ "GHC+Clash: Loading modules cumulatively took " ++ prepStartDiff++ -- Generate HDL:+ Clash.Driver.generateHDL+ (buildCustomReprs reprs)+ bindingsMap+ (Just backend')+ primMap+ tcm+ tupTcm+ (ghcTypeToHWType iw fp)+ reduceConstant+ topEntities+ opts2+ (startTime,prepTime)++makeVHDL :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VHDLState)++makeVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VerilogState)++makeSystemVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> SystemVerilogState)++-----------------------------------------------------------------------------+-- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.++typeOfExpr :: String -> InputT GHCi ()+typeOfExpr str = handleSourceError GHC.printException $ do+ let (mode, expr_str) = case break isSpace str of+ ("+d", rest) -> (GHC.TM_Default, dropWhile isSpace rest)+ ("+v", rest) -> (GHC.TM_NoInst, dropWhile isSpace rest)+ _ -> (GHC.TM_Inst, str)+ ty <- GHC.exprType mode expr_str+ printForUser $ sep [text expr_str, nest 2 (dcolon <+> pprTypeForUser ty)]++-----------------------------------------------------------------------------+-- | @:type-at@ command++typeAtCmd :: String -> InputT GHCi ()+typeAtCmd str = runExceptGhcMonad $ do+ (span',sample) <- exceptT $ parseSpanArg str+ infos <- mod_infos <$> getGHCiState+ (info, ty) <- findType infos span' sample+ lift $ printForUserModInfo (modinfoInfo info)+ (sep [text sample,nest 2 (dcolon <+> ppr ty)])++-----------------------------------------------------------------------------+-- | @:uses@ command++usesCmd :: String -> InputT GHCi ()+usesCmd str = runExceptGhcMonad $ do+ (span',sample) <- exceptT $ parseSpanArg str+ infos <- mod_infos <$> getGHCiState+ uses <- findNameUses infos span' sample+ forM_ uses (liftIO . putStrLn . showSrcSpan)++-----------------------------------------------------------------------------+-- | @:loc-at@ command++locAtCmd :: String -> InputT GHCi ()+locAtCmd str = runExceptGhcMonad $ do+ (span',sample) <- exceptT $ parseSpanArg str+ infos <- mod_infos <$> getGHCiState+ (_,_,sp) <- findLoc infos span' sample+ liftIO . putStrLn . showSrcSpan $ sp++-----------------------------------------------------------------------------+-- | @:all-types@ command++allTypesCmd :: String -> InputT GHCi ()+allTypesCmd _ = runExceptGhcMonad $ do+ infos <- mod_infos <$> getGHCiState+ forM_ (M.elems infos) $ \mi ->+ forM_ (modinfoSpans mi) (lift . printSpan)+ where+ printSpan span'+ | Just ty <- spaninfoType span' = do+ df <- getDynFlags+ let tyInfo = unwords . words $+ showSDocForUser df alwaysQualify (pprTypeForUser ty)+ liftIO . putStrLn $+ showRealSrcSpan (spaninfoSrcSpan span') ++ ": " ++ tyInfo+ | otherwise = return ()++-----------------------------------------------------------------------------+-- Helpers for locAtCmd/typeAtCmd/usesCmd++-- | Parse a span: <module-name/filepath> <sl> <sc> <el> <ec> <string>+parseSpanArg :: String -> Either SDoc (RealSrcSpan,String)+parseSpanArg s = do+ (fp,s0) <- readAsString (skipWs s)+ s0' <- skipWs1 s0+ (sl,s1) <- readAsInt s0'+ s1' <- skipWs1 s1+ (sc,s2) <- readAsInt s1'+ s2' <- skipWs1 s2+ (el,s3) <- readAsInt s2'+ s3' <- skipWs1 s3+ (ec,s4) <- readAsInt s3'++ trailer <- case s4 of+ [] -> Right ""+ _ -> skipWs1 s4++ let fs = mkFastString fp+ span' = mkRealSrcSpan (mkRealSrcLoc fs sl sc)+ (mkRealSrcLoc fs el ec)++ return (span',trailer)+ where+ readAsInt :: String -> Either SDoc (Int,String)+ readAsInt "" = Left "Premature end of string while expecting Int"+ readAsInt s0 = case reads s0 of+ [s_rest] -> Right s_rest+ _ -> Left ("Couldn't read" <+> text (show s0) <+> "as Int")++ readAsString :: String -> Either SDoc (String,String)+ readAsString s0+ | '"':_ <- s0 = case reads s0 of+ [s_rest] -> Right s_rest+ _ -> leftRes+ | s_rest@(_:_,_) <- breakWs s0 = Right s_rest+ | otherwise = leftRes+ where+ leftRes = Left ("Couldn't read" <+> text (show s0) <+> "as String")++ skipWs1 :: String -> Either SDoc String+ skipWs1 (c:cs) | isWs c = Right (skipWs cs)+ skipWs1 s0 = Left ("Expected whitespace in" <+> text (show s0))++ isWs = (`elem` [' ','\t'])+ skipWs = dropWhile isWs+ breakWs = break isWs+++-- | Pretty-print \"real\" 'SrcSpan's as+-- @<filename>:(<line>,<col>)-(<line-end>,<col-end>)@+-- while simply unpacking 'UnhelpfulSpan's+showSrcSpan :: SrcSpan -> String+showSrcSpan (UnhelpfulSpan s) = unpackFS s+showSrcSpan (RealSrcSpan spn) = showRealSrcSpan spn++-- | Variant of 'showSrcSpan' for 'RealSrcSpan's+showRealSrcSpan :: RealSrcSpan -> String+showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc+ , ")-(", show el, ",", show ec, ")"+ ]+ where+ fp = unpackFS (srcSpanFile spn)+ sl = srcSpanStartLine spn+ sc = srcSpanStartCol spn+ el = srcSpanEndLine spn+ ec = srcSpanEndCol spn++-----------------------------------------------------------------------------+-- | @:kind@ command++kindOfType :: Bool -> String -> InputT GHCi ()+kindOfType norm str = handleSourceError GHC.printException $ do+ (ty, kind) <- GHC.typeKind norm str+ printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind+ , ppWhen norm $ equals <+> pprTypeForUser ty ]++-----------------------------------------------------------------------------+-- :quit++quit :: String -> InputT GHCi Bool+quit _ = return True+++-----------------------------------------------------------------------------+-- :script++-- running a script file #1363++scriptCmd :: String -> InputT GHCi ()+scriptCmd ws = do+ case words ws of+ [s] -> runScript s+ _ -> throwGhcException (CmdLineError "syntax: :script <filename>")++runScript :: String -- ^ filename+ -> InputT GHCi ()+runScript filename = do+ filename' <- expandPath filename+ either_script <- liftIO $ tryIO (openFile filename' ReadMode)+ case either_script of+ Left _err -> throwGhcException (CmdLineError $ "IO error: \""++filename++"\" "+ ++(ioeGetErrorString _err))+ Right script -> do+ st <- getGHCiState+ let prog = progname st+ line = line_number st+ setGHCiState st{progname=filename',line_number=0}+ scriptLoop script+ liftIO $ hClose script+ new_st <- getGHCiState+ setGHCiState new_st{progname=prog,line_number=line}+ where scriptLoop script = do+ res <- runOneCommand handler $ fileLoop script+ case res of+ Nothing -> return ()+ Just s -> if s+ then scriptLoop script+ else return ()++-----------------------------------------------------------------------------+-- :issafe++-- Displaying Safe Haskell properties of a module++isSafeCmd :: String -> InputT GHCi ()+isSafeCmd m =+ case words m of+ [s] | looksLikeModuleName s -> do+ md <- lift $ lookupModule s+ isSafeModule md+ [] -> do md <- guessCurrentModule "issafe"+ isSafeModule md+ _ -> throwGhcException (CmdLineError "syntax: :issafe <module>")++isSafeModule :: Module -> InputT GHCi ()+isSafeModule m = do+ mb_mod_info <- GHC.getModuleInfo m+ when (isNothing mb_mod_info)+ (throwGhcException $ CmdLineError $ "unknown module: " ++ mname)++ dflags <- getDynFlags+ let iface = GHC.modInfoIface $ fromJust mb_mod_info+ when (isNothing iface)+ (throwGhcException $ CmdLineError $ "can't load interface file for module: " +++ (GHC.moduleNameString $ GHC.moduleName m))++ (msafe, pkgs) <- GHC.moduleTrustReqs m+ let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface+ pkg = if packageTrusted dflags m then "trusted" else "untrusted"+ (good, bad) = tallyPkgs dflags pkgs++ -- print info to user...+ liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"+ liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")+ when (not $ S.null good)+ (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " +++ (intercalate ", " $ map (showPpr dflags) (S.toList good)))+ case msafe && S.null bad of+ True -> liftIO $ putStrLn $ mname ++ " is trusted!"+ False -> do+ when (not $ null bad)+ (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "+ ++ (intercalate ", " $ map (showPpr dflags) (S.toList bad)))+ liftIO $ putStrLn $ mname ++ " is NOT trusted!"++ where+ mname = GHC.moduleNameString $ GHC.moduleName m++ packageTrusted dflags md+ | thisPackage dflags == moduleUnitId md = True+ | otherwise = trusted $ getPackageDetails dflags (moduleUnitId md)++ tallyPkgs dflags deps | not (packageTrustOn dflags) = (S.empty, S.empty)+ | otherwise = S.partition part deps+ where part pkg = trusted $ getInstalledPackageDetails dflags pkg++-----------------------------------------------------------------------------+-- :browse++-- Browsing a module's contents++browseCmd :: Bool -> String -> InputT GHCi ()+browseCmd bang m =+ case words m of+ ['*':s] | looksLikeModuleName s -> do+ md <- lift $ wantInterpretedModule s+ browseModule bang md False+ [s] | looksLikeModuleName s -> do+ md <- lift $ lookupModule s+ browseModule bang md True+ [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")+ browseModule bang md True+ _ -> throwGhcException (CmdLineError "syntax: :browse <module>")++guessCurrentModule :: String -> InputT GHCi Module+-- Guess which module the user wants to browse. Pick+-- modules that are interpreted first. The most+-- recently-added module occurs last, it seems.+guessCurrentModule cmd+ = do imports <- GHC.getContext+ when (null imports) $ throwGhcException $+ CmdLineError (':' : cmd ++ ": no current module")+ case (head imports) of+ IIModule m -> GHC.findModule m Nothing+ IIDecl d -> GHC.findModule (unLoc (ideclName d))+ (fmap sl_fs $ ideclPkgQual d)++-- without bang, show items in context of their parents and omit children+-- with bang, show class methods and data constructors separately, and+-- indicate import modules, to aid qualifying unqualified names+-- with sorted, sort items alphabetically+browseModule :: Bool -> Module -> Bool -> InputT GHCi ()+browseModule bang modl exports_only = do+ -- :browse reports qualifiers wrt current context+ unqual <- GHC.getPrintUnqual++ mb_mod_info <- GHC.getModuleInfo modl+ case mb_mod_info of+ Nothing -> throwGhcException (CmdLineError ("unknown module: " +++ GHC.moduleNameString (GHC.moduleName modl)))+ Just mod_info -> do+ dflags <- getDynFlags+ let names+ | exports_only = GHC.modInfoExports mod_info+ | otherwise = GHC.modInfoTopLevelScope mod_info+ `orElse` []++ -- sort alphabetically name, but putting locally-defined+ -- identifiers first. We would like to improve this; see #1799.+ sorted_names = loc_sort local ++ occ_sort external+ where+ (local,external) = ASSERT( all isExternalName names )+ partition ((==modl) . nameModule) names+ occ_sort = sortBy (compare `on` nameOccName)+ -- try to sort by src location. If the first name in our list+ -- has a good source location, then they all should.+ loc_sort ns+ | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n)+ = sortBy (compare `on` nameSrcSpan) ns+ | otherwise+ = occ_sort ns++ mb_things <- mapM GHC.lookupName sorted_names+ let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)++ rdr_env <- GHC.getGRE++ let things | bang = catMaybes mb_things+ | otherwise = filtered_things+ pretty | bang = pprTyThing showToHeader+ | otherwise = pprTyThingInContext showToHeader++ labels [] = text "-- not currently imported"+ labels l = text $ intercalate "\n" $ map qualifier l++ qualifier :: Maybe [ModuleName] -> String+ qualifier = maybe "-- defined locally"+ (("-- imported via "++) . intercalate ", "+ . map GHC.moduleNameString)+ importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env++ modNames :: [[Maybe [ModuleName]]]+ modNames = map (importInfo . GHC.getName) things++ -- annotate groups of imports with their import modules+ -- the default ordering is somewhat arbitrary, so we group+ -- by header and sort groups; the names themselves should+ -- really come in order of source appearance.. (trac #1799)+ annotate mts = concatMap (\(m,ts)->labels m:ts)+ $ sortBy cmpQualifiers $ grp mts+ where cmpQualifiers =+ compare `on` (map (fmap (map moduleNameFS)) . fst)+ grp [] = []+ grp mts@((m,_):_) = (m,map snd g) : grp ng+ where (g,ng) = partition ((==m).fst) mts++ let prettyThings, prettyThings' :: [SDoc]+ prettyThings = map pretty things+ prettyThings' | bang = annotate $ zip modNames prettyThings+ | otherwise = prettyThings+ liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings')+ -- ToDo: modInfoInstances currently throws an exception for+ -- package modules. When it works, we can do this:+ -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))+++-----------------------------------------------------------------------------+-- :module++-- Setting the module context. For details on context handling see+-- "remembered_ctx" and "transient_ctx" in GhciMonad.++moduleCmd :: String -> GHCi ()+moduleCmd str+ | all sensible strs = cmd+ | otherwise = throwGhcException (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")+ where+ (cmd, strs) =+ case str of+ '+':stuff -> rest addModulesToContext stuff+ '-':stuff -> rest remModulesFromContext stuff+ stuff -> rest setContext stuff++ rest op stuff = (op as bs, stuffs)+ where (as,bs) = partitionWith starred stuffs+ stuffs = words stuff++ sensible ('*':m) = looksLikeModuleName m+ sensible m = looksLikeModuleName m++ starred ('*':m) = Left (GHC.mkModuleName m)+ starred m = Right (GHC.mkModuleName m)+++-- -----------------------------------------------------------------------------+-- Four ways to manipulate the context:+-- (a) :module +<stuff>: addModulesToContext+-- (b) :module -<stuff>: remModulesFromContext+-- (c) :module <stuff>: setContext+-- (d) import <module>...: addImportToContext++addModulesToContext :: [ModuleName] -> [ModuleName] -> GHCi ()+addModulesToContext starred unstarred = restoreContextOnFailure $ do+ addModulesToContext_ starred unstarred++addModulesToContext_ :: [ModuleName] -> [ModuleName] -> GHCi ()+addModulesToContext_ starred unstarred = do+ mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)+ setGHCContextFromGHCiState++remModulesFromContext :: [ModuleName] -> [ModuleName] -> GHCi ()+remModulesFromContext starred unstarred = do+ -- we do *not* call restoreContextOnFailure here. If the user+ -- is trying to fix up a context that contains errors by removing+ -- modules, we don't want GHC to silently put them back in again.+ mapM_ rm (starred ++ unstarred)+ setGHCContextFromGHCiState+ where+ rm :: ModuleName -> GHCi ()+ rm str = do+ m <- moduleName <$> lookupModuleName str+ let filt = filter ((/=) m . iiModuleName)+ modifyGHCiState $ \st ->+ st { remembered_ctx = filt (remembered_ctx st)+ , transient_ctx = filt (transient_ctx st) }++setContext :: [ModuleName] -> [ModuleName] -> GHCi ()+setContext starred unstarred = restoreContextOnFailure $ do+ modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }+ -- delete the transient context+ addModulesToContext_ starred unstarred++addImportToContext :: String -> GHCi ()+addImportToContext str = restoreContextOnFailure $ do+ idecl <- GHC.parseImportDecl str+ addII (IIDecl idecl) -- #5836+ setGHCContextFromGHCiState++-- Util used by addImportToContext and addModulesToContext+addII :: InteractiveImport -> GHCi ()+addII iidecl = do+ checkAdd iidecl+ modifyGHCiState $ \st ->+ st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st)+ , transient_ctx = filter (not . (iidecl `iiSubsumes`))+ (transient_ctx st)+ }++-- Sometimes we can't tell whether an import is valid or not until+-- we finally call 'GHC.setContext'. e.g.+--+-- import System.IO (foo)+--+-- will fail because System.IO does not export foo. In this case we+-- don't want to store the import in the context permanently, so we+-- catch the failure from 'setGHCContextFromGHCiState' and set the+-- context back to what it was.+--+-- See #6007+--+restoreContextOnFailure :: GHCi a -> GHCi a+restoreContextOnFailure do_this = do+ st <- getGHCiState+ let rc = remembered_ctx st; tc = transient_ctx st+ do_this `gonException` (modifyGHCiState $ \st' ->+ st' { remembered_ctx = rc, transient_ctx = tc })++-- -----------------------------------------------------------------------------+-- Validate a module that we want to add to the context++checkAdd :: InteractiveImport -> GHCi ()+checkAdd ii = do+ dflags <- getDynFlags+ let safe = safeLanguageOn dflags+ case ii of+ IIModule modname+ | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"+ | otherwise -> wantInterpretedModuleName modname >> return ()++ IIDecl d -> do+ let modname = unLoc (ideclName d)+ pkgqual = ideclPkgQual d+ m <- GHC.lookupModule modname (fmap sl_fs pkgqual)+ when safe $ do+ t <- GHC.isModuleTrusted m+ when (not t) $ throwGhcException $ ProgramError $ ""++-- -----------------------------------------------------------------------------+-- Update the GHC API's view of the context++-- | Sets the GHC context from the GHCi state. The GHC context is+-- always set this way, we never modify it incrementally.+--+-- We ignore any imports for which the ModuleName does not currently+-- exist. This is so that the remembered_ctx can contain imports for+-- modules that are not currently loaded, perhaps because we just did+-- a :reload and encountered errors.+--+-- Prelude is added if not already present in the list. Therefore to+-- override the implicit Prelude import you can say 'import Prelude ()'+-- at the prompt, just as in Haskell source.+--+setGHCContextFromGHCiState :: GHCi ()+setGHCContextFromGHCiState = do+ st <- getGHCiState+ -- re-use checkAdd to check whether the module is valid. If the+ -- module does not exist, we do *not* want to print an error+ -- here, we just want to silently keep the module in the context+ -- until such time as the module reappears again. So we ignore+ -- the actual exception thrown by checkAdd, using tryBool to+ -- turn it into a Bool.+ iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st)++ prel_iidecls <- getImplicitPreludeImports iidecls+ valid_prel_iidecls <- filterM (tryBool . checkAdd) prel_iidecls++ extra_imports <- filterM (tryBool . checkAdd) (map IIDecl (extra_imports st))++ GHC.setContext $ iidecls ++ extra_imports ++ valid_prel_iidecls+++getImplicitPreludeImports :: [InteractiveImport] -> GHCi [InteractiveImport]+getImplicitPreludeImports iidecls = do+ -- allow :seti to override -XNoImplicitPrelude+ st <- getGHCiState++ -- We add the prelude imports if there are no *-imports, and we also+ -- allow each prelude import to be subsumed by another explicit import+ -- of the same module. This means that you can override the prelude import+ -- with "import Prelude hiding (map)", for example.+ let prel_iidecls =+ if not (any isIIModule iidecls)+ then [ IIDecl imp+ | imp <- prelude_imports st+ , not (any (sameImpModule imp) iidecls) ]+ else []++ return prel_iidecls++-- -----------------------------------------------------------------------------+-- Utils on InteractiveImport++mkIIModule :: ModuleName -> InteractiveImport+mkIIModule = IIModule++mkIIDecl :: ModuleName -> InteractiveImport+mkIIDecl = IIDecl . simpleImportDecl++iiModules :: [InteractiveImport] -> [ModuleName]+iiModules is = [m | IIModule m <- is]++isIIModule :: InteractiveImport -> Bool+isIIModule (IIModule _) = True+isIIModule _ = False++iiModuleName :: InteractiveImport -> ModuleName+iiModuleName (IIModule m) = m+iiModuleName (IIDecl d) = unLoc (ideclName d)++preludeModuleName :: ModuleName+preludeModuleName = GHC.mkModuleName "Clash.Prelude"++sameImpModule :: ImportDecl GhcPs -> InteractiveImport -> Bool+sameImpModule _ (IIModule _) = False -- we only care about imports here+sameImpModule imp (IIDecl d) = unLoc (ideclName d) == unLoc (ideclName imp)++addNotSubsumed :: InteractiveImport+ -> [InteractiveImport] -> [InteractiveImport]+addNotSubsumed i is+ | any (`iiSubsumes` i) is = is+ | otherwise = i : filter (not . (i `iiSubsumes`)) is++-- | @filterSubsumed is js@ returns the elements of @js@ not subsumed+-- by any of @is@.+filterSubsumed :: [InteractiveImport] -> [InteractiveImport]+ -> [InteractiveImport]+filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js++-- | Returns True if the left import subsumes the right one. Doesn't+-- need to be 100% accurate, conservatively returning False is fine.+-- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in+-- plusProv will ensue (#5904))+--+-- Note that an IIModule does not necessarily subsume an IIDecl,+-- because e.g. a module might export a name that is only available+-- qualified within the module itself.+--+-- Note that 'import M' does not necessarily subsume 'import M(foo)',+-- because M might not export foo and we want an error to be produced+-- in that case.+--+iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool+iiSubsumes (IIModule m1) (IIModule m2) = m1==m2+iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude+ = unLoc (ideclName d1) == unLoc (ideclName d2)+ && ideclAs d1 == ideclAs d2+ && (not (ideclQualified d1) || ideclQualified d2)+ && (ideclHiding d1 `hidingSubsumes` ideclHiding d2)+ where+ _ `hidingSubsumes` Just (False,L _ []) = True+ Just (False, L _ xs) `hidingSubsumes` Just (False,L _ ys)+ = all (`elem` xs) ys+ h1 `hidingSubsumes` h2 = h1 == h2+iiSubsumes _ _ = False+++----------------------------------------------------------------------------+-- :set++-- set options in the interpreter. Syntax is exactly the same as the+-- ghc command line, except that certain options aren't available (-C,+-- -E etc.)+--+-- This is pretty fragile: most options won't work as expected. ToDo:+-- figure out which ones & disallow them.++setCmd :: String -> GHCi ()+setCmd "" = showOptions False+setCmd "-a" = showOptions True+setCmd str+ = case getCmd str of+ Right ("args", rest) ->+ case toArgs rest of+ Left err -> liftIO (hPutStrLn stderr err)+ Right args -> setArgs args+ Right ("prog", rest) ->+ case toArgs rest of+ Right [prog] -> setProg prog+ _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")++ Right ("prompt", rest) ->+ setPromptString setPrompt (dropWhile isSpace rest)+ "syntax: set prompt <string>"+ Right ("prompt-function", rest) ->+ setPromptFunc setPrompt $ dropWhile isSpace rest+ Right ("prompt-cont", rest) ->+ setPromptString setPromptCont (dropWhile isSpace rest)+ "syntax: :set prompt-cont <string>"+ Right ("prompt-cont-function", rest) ->+ setPromptFunc setPromptCont $ dropWhile isSpace rest++ Right ("editor", rest) -> setEditor $ dropWhile isSpace rest+ Right ("stop", rest) -> setStop $ dropWhile isSpace rest+ _ -> case toArgs str of+ Left err -> liftIO (hPutStrLn stderr err)+ Right wds -> setOptions wds++setiCmd :: String -> GHCi ()+setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False+setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True+setiCmd str =+ case toArgs str of+ Left err -> liftIO (hPutStrLn stderr err)+ Right wds -> newDynFlags True wds++showOptions :: Bool -> GHCi ()+showOptions show_all+ = do st <- getGHCiState+ dflags <- getDynFlags+ let opts = options st+ liftIO $ putStrLn (showSDoc dflags (+ text "options currently set: " <>+ if null opts+ then text "none."+ else hsep (map (\o -> char '+' <> text (optToStr o)) opts)+ ))+ getDynFlags >>= liftIO . showDynFlags show_all+++showDynFlags :: Bool -> DynFlags -> IO ()+showDynFlags show_all dflags = do+ showLanguages' show_all dflags+ putStrLn $ showSDoc dflags $+ text "GHCi-specific dynamic flag settings:" $$+ nest 2 (vcat (map (setting "-f" "-fno-" gopt) ghciFlags))+ putStrLn $ showSDoc dflags $+ text "other dynamic, non-language, flag settings:" $$+ nest 2 (vcat (map (setting "-f" "-fno-" gopt) others))+ putStrLn $ showSDoc dflags $+ text "warning settings:" $$+ nest 2 (vcat (map (setting "-W" "-Wno-" wopt) DynFlags.wWarningFlags))+ where+ setting prefix noPrefix test flag+ | quiet = empty+ | is_on = text prefix <> text name+ | otherwise = text noPrefix <> text name+ where name = flagSpecName flag+ f = flagSpecFlag flag+ is_on = test f dflags+ quiet = not show_all && test f default_dflags == is_on++ llvmConfig = (llvmTargets dflags, llvmPasses dflags)++ default_dflags = defaultDynFlags (settings dflags) llvmConfig++ (ghciFlags,others) = partition (\f -> flagSpecFlag f `elem` flgs)+ DynFlags.fFlags+ flgs = [ Opt_PrintExplicitForalls+ , Opt_PrintExplicitKinds+ , Opt_PrintUnicodeSyntax+ , Opt_PrintBindResult+ , Opt_BreakOnException+ , Opt_BreakOnError+ , Opt_PrintEvldWithShow+ ]++setArgs, setOptions :: [String] -> GHCi ()+setProg, setEditor, setStop :: String -> GHCi ()++setArgs args = do+ st <- getGHCiState+ wrapper <- mkEvalWrapper (progname st) args+ setGHCiState st { GhciMonad.args = args, evalWrapper = wrapper }++setProg prog = do+ st <- getGHCiState+ wrapper <- mkEvalWrapper prog (GhciMonad.args st)+ setGHCiState st { progname = prog, evalWrapper = wrapper }++setEditor cmd = modifyGHCiState (\st -> st { editor = cmd })++setStop str@(c:_) | isDigit c+ = do let (nm_str,rest) = break (not.isDigit) str+ nm = read nm_str+ st <- getGHCiState+ let old_breaks = breaks st+ if all ((/= nm) . fst) old_breaks+ then printForUser (text "Breakpoint" <+> ppr nm <+>+ text "does not exist")+ else do+ let new_breaks = map fn old_breaks+ fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })+ | otherwise = (i,loc)+ setGHCiState st{ breaks = new_breaks }+setStop cmd = modifyGHCiState (\st -> st { stop = cmd })++setPrompt :: PromptFunction -> GHCi ()+setPrompt v = modifyGHCiState (\st -> st {prompt = v})++setPromptCont :: PromptFunction -> GHCi ()+setPromptCont v = modifyGHCiState (\st -> st {prompt_cont = v})++setPromptFunc :: (PromptFunction -> GHCi ()) -> String -> GHCi ()+setPromptFunc fSetPrompt s = do+ -- We explicitly annotate the type of the expression to ensure+ -- that unsafeCoerce# is passed the exact type necessary rather+ -- than a more general one+ let exprStr = "(" ++ s ++ ") :: [String] -> Int -> IO String"+ (HValue funValue) <- GHC.compileExpr exprStr+ fSetPrompt (convertToPromptFunction $ unsafeCoerce funValue)+ where+ convertToPromptFunction :: ([String] -> Int -> IO String)+ -> PromptFunction+ convertToPromptFunction func = (\mods line -> liftIO $+ liftM text (func mods line))++setPromptString :: (PromptFunction -> GHCi ()) -> String -> String -> GHCi ()+setPromptString fSetPrompt value err = do+ if null value+ then liftIO $ hPutStrLn stderr $ err+ else case value of+ ('\"':_) ->+ case reads value of+ [(value', xs)] | all isSpace xs ->+ setParsedPromptString fSetPrompt value'+ _ -> liftIO $ hPutStrLn stderr+ "Can't parse prompt string. Use Haskell syntax."+ _ ->+ setParsedPromptString fSetPrompt value++setParsedPromptString :: (PromptFunction -> GHCi ()) -> String -> GHCi ()+setParsedPromptString fSetPrompt s = do+ case (checkPromptStringForErrors s) of+ Just err ->+ liftIO $ hPutStrLn stderr err+ Nothing ->+ fSetPrompt $ generatePromptFunctionFromString s++setOptions wds =+ do -- first, deal with the GHCi opts (+s, +t, etc.)+ let (plus_opts, minus_opts) = partitionWith isPlus wds+ mapM_ setOpt plus_opts+ -- then, dynamic flags+ when (not (null minus_opts)) $ newDynFlags False minus_opts++newDynFlags :: Bool -> [String] -> GHCi ()+newDynFlags interactive_only minus_opts = do+ let lopts = map noLoc minus_opts++ idflags0 <- GHC.getInteractiveDynFlags+ (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts++ liftIO $ handleFlagWarnings idflags1 warns+ when (not $ null leftovers)+ (throwGhcException . CmdLineError+ $ "Some flags have not been recognized: "+ ++ (concat . intersperse ", " $ map unLoc leftovers))++ when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do+ liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"+ -- Load any new plugins+ hsc_env0 <- GHC.getSession+ idflags2 <- liftIO (initializePlugins hsc_env0 idflags1)+ GHC.setInteractiveDynFlags idflags2+ installInteractivePrint (interactivePrint idflags1) False++ dflags0 <- getDynFlags+ when (not interactive_only) $ do+ (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts+ new_pkgs <- GHC.setProgramDynFlags dflags1++ -- if the package flags changed, reset the context and link+ -- the new packages.+ hsc_env <- GHC.getSession+ let dflags2 = hsc_dflags hsc_env+ when (packageFlagsChanged dflags2 dflags0) $ do+ when (verbosity dflags2 > 0) $+ liftIO . putStrLn $+ "package flags have changed, resetting and loading new packages..."+ GHC.setTargets []+ _ <- GHC.load LoadAllTargets+ liftIO $ linkPackages hsc_env new_pkgs+ -- package flags changed, we can't re-use any of the old context+ setContextAfterLoad False []+ -- and copy the package state to the interactive DynFlags+ idflags <- GHC.getInteractiveDynFlags+ GHC.setInteractiveDynFlags+ idflags{ pkgState = pkgState dflags2+ , pkgDatabase = pkgDatabase dflags2+ , packageFlags = packageFlags dflags2 }++ let ld0length = length $ ldInputs dflags0+ fmrk0length = length $ cmdlineFrameworks dflags0++ newLdInputs = drop ld0length (ldInputs dflags2)+ newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)++ hsc_env' = hsc_env { hsc_dflags =+ dflags2 { ldInputs = newLdInputs+ , cmdlineFrameworks = newCLFrameworks } }++ when (not (null newLdInputs && null newCLFrameworks)) $+ liftIO $ linkCmdLineLibs hsc_env'++ return ()+++unsetOptions :: String -> GHCi ()+unsetOptions str+ = -- first, deal with the GHCi opts (+s, +t, etc.)+ let opts = words str+ (minus_opts, rest1) = partition isMinus opts+ (plus_opts, rest2) = partitionWith isPlus rest1+ (other_opts, rest3) = partition (`elem` map fst defaulters) rest2++ defaulters =+ [ ("args" , setArgs default_args)+ , ("prog" , setProg default_progname)+ , ("prompt" , setPrompt default_prompt)+ , ("prompt-cont", setPromptCont default_prompt_cont)+ , ("editor" , liftIO findEditor >>= setEditor)+ , ("stop" , setStop default_stop)+ ]++ no_flag ('-':'f':rest) = return ("-fno-" ++ rest)+ no_flag ('-':'X':rest) = return ("-XNo" ++ rest)+ no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f))++ in if (not (null rest3))+ then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))+ else do+ mapM_ (fromJust.flip lookup defaulters) other_opts++ mapM_ unsetOpt plus_opts++ no_flags <- mapM no_flag minus_opts+ when (not (null no_flags)) $ newDynFlags False no_flags++isMinus :: String -> Bool+isMinus ('-':_) = True+isMinus _ = False++isPlus :: String -> Either String String+isPlus ('+':opt) = Left opt+isPlus other = Right other++setOpt, unsetOpt :: String -> GHCi ()++setOpt str+ = case strToGHCiOpt str of+ Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))+ Just o -> setOption o++unsetOpt str+ = case strToGHCiOpt str of+ Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))+ Just o -> unsetOption o++strToGHCiOpt :: String -> (Maybe GHCiOption)+strToGHCiOpt "m" = Just Multiline+strToGHCiOpt "s" = Just ShowTiming+strToGHCiOpt "t" = Just ShowType+strToGHCiOpt "r" = Just RevertCAFs+strToGHCiOpt "c" = Just CollectInfo+strToGHCiOpt _ = Nothing++optToStr :: GHCiOption -> String+optToStr Multiline = "m"+optToStr ShowTiming = "s"+optToStr ShowType = "t"+optToStr RevertCAFs = "r"+optToStr CollectInfo = "c"+++-- ---------------------------------------------------------------------------+-- :show++showCmd :: String -> GHCi ()+showCmd "" = showOptions False+showCmd "-a" = showOptions True+showCmd str = do+ st <- getGHCiState+ dflags <- getDynFlags++ let lookupCmd :: String -> Maybe (GHCi ())+ lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds++ -- (show in help?, command name, action)+ action :: String -> GHCi () -> (Bool, String, GHCi ())+ action name m = (True, name, m)++ hidden :: String -> GHCi () -> (Bool, String, GHCi ())+ hidden name m = (False, name, m)++ cmds =+ [ action "args" $ liftIO $ putStrLn (show (GhciMonad.args st))+ , action "prog" $ liftIO $ putStrLn (show (progname st))+ , action "editor" $ liftIO $ putStrLn (show (editor st))+ , action "stop" $ liftIO $ putStrLn (show (stop st))+ , action "imports" $ showImports+ , action "modules" $ showModules+ , action "bindings" $ showBindings+ , action "linker" $ getDynFlags >>= liftIO . showLinkerState+ , action "breaks" $ showBkptTable+ , action "context" $ showContext+ , action "packages" $ showPackages+ , action "paths" $ showPaths+ , action "language" $ showLanguages+ , hidden "languages" $ showLanguages -- backwards compat+ , hidden "lang" $ showLanguages -- useful abbreviation+ , action "targets" $ showTargets+ ]++ case words str of+ [w] | Just action <- lookupCmd w -> action++ _ -> let helpCmds = [ text name | (True, name, _) <- cmds ]+ in throwGhcException $ CmdLineError $ showSDoc dflags+ $ hang (text "syntax:") 4+ $ hang (text ":show") 6+ $ brackets (fsep $ punctuate (text " |") helpCmds)++showiCmd :: String -> GHCi ()+showiCmd str = do+ case words str of+ ["languages"] -> showiLanguages -- backwards compat+ ["language"] -> showiLanguages+ ["lang"] -> showiLanguages -- useful abbreviation+ _ -> throwGhcException (CmdLineError ("syntax: :showi language"))++showImports :: GHCi ()+showImports = do+ st <- getGHCiState+ dflags <- getDynFlags+ let rem_ctx = reverse (remembered_ctx st)+ trans_ctx = transient_ctx st++ show_one (IIModule star_m)+ = ":module +*" ++ moduleNameString star_m+ show_one (IIDecl imp) = showPpr dflags imp++ prel_iidecls <- getImplicitPreludeImports (rem_ctx ++ trans_ctx)++ let show_prel p = show_one p ++ " -- implicit"+ show_extra p = show_one (IIDecl p) ++ " -- fixed"++ trans_comment s = s ++ " -- added automatically" :: String+ --+ liftIO $ mapM_ putStrLn (map show_one rem_ctx +++ map (trans_comment . show_one) trans_ctx +++ map show_prel prel_iidecls +++ map show_extra (extra_imports st))++showModules :: GHCi ()+showModules = do+ loaded_mods <- getLoadedModules+ -- we want *loaded* modules only, see #1734+ let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)+ mapM_ show_one loaded_mods++getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]+getLoadedModules = do+ graph <- GHC.getModuleGraph+ filterM (GHC.isLoaded . GHC.ms_mod_name) (GHC.mgModSummaries graph)++showBindings :: GHCi ()+showBindings = do+ bindings <- GHC.getBindings+ (insts, finsts) <- GHC.getInsts+ docs <- mapM makeDoc (reverse bindings)+ -- reverse so the new ones come last+ let idocs = map GHC.pprInstanceHdr insts+ fidocs = map GHC.pprFamInst finsts+ mapM_ printForUserPartWay (docs ++ idocs ++ fidocs)+ where+ makeDoc (AnId i) = pprTypeAndContents i+ makeDoc tt = do+ mb_stuff <- GHC.getInfo False (getName tt)+ return $ maybe (text "") pprTT mb_stuff++ pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc+ pprTT (thing, fixity, _cls_insts, _fam_insts, _docs)+ = pprTyThing showToHeader thing+ $$ show_fixity+ where+ show_fixity+ | fixity == GHC.defaultFixity = empty+ | otherwise = ppr fixity <+> ppr (GHC.getName thing)+++printTyThing :: TyThing -> GHCi ()+printTyThing tyth = printForUser (pprTyThing showToHeader tyth)++showBkptTable :: GHCi ()+showBkptTable = do+ st <- getGHCiState+ printForUser $ prettyLocations (breaks st)++showContext :: GHCi ()+showContext = do+ resumes <- GHC.getResumeContext+ printForUser $ vcat (map pp_resume (reverse resumes))+ where+ pp_resume res =+ ptext (sLit "--> ") <> text (GHC.resumeStmt res)+ $$ nest 2 (pprStopped res)++pprStopped :: GHC.Resume -> SDoc+pprStopped res =+ ptext (sLit "Stopped in")+ <+> ((case mb_mod_name of+ Nothing -> empty+ Just mod_name -> text (moduleNameString mod_name) <> char '.')+ <> text (GHC.resumeDecl res))+ <> char ',' <+> ppr (GHC.resumeSpan res)+ where+ mb_mod_name = moduleName <$> GHC.breakInfo_module <$> GHC.resumeBreakInfo res++showPackages :: GHCi ()+showPackages = do+ dflags <- getDynFlags+ let pkg_flags = packageFlags dflags+ liftIO $ putStrLn $ showSDoc dflags $+ text ("active package flags:"++if null pkg_flags then " none" else "") $$+ nest 2 (vcat (map pprFlag pkg_flags))++showPaths :: GHCi ()+showPaths = do+ dflags <- getDynFlags+ liftIO $ do+ cwd <- getCurrentDirectory+ putStrLn $ showSDoc dflags $+ text "current working directory: " $$+ nest 2 (text cwd)+ let ipaths = importPaths dflags+ putStrLn $ showSDoc dflags $+ text ("module import search paths:"++if null ipaths then " none" else "") $$+ nest 2 (vcat (map text ipaths))++showLanguages :: GHCi ()+showLanguages = getDynFlags >>= liftIO . showLanguages' False++showiLanguages :: GHCi ()+showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False++showLanguages' :: Bool -> DynFlags -> IO ()+showLanguages' show_all dflags =+ putStrLn $ showSDoc dflags $ vcat+ [ text "base language is: " <>+ case language dflags of+ Nothing -> text "Haskell2010"+ Just Haskell98 -> text "Haskell98"+ Just Haskell2010 -> text "Haskell2010"+ , (if show_all then text "all active language options:"+ else text "with the following modifiers:") $$+ nest 2 (vcat (map (setting xopt) DynFlags.xFlags))+ ]+ where+ setting test flag+ | quiet = empty+ | is_on = text "-X" <> text name+ | otherwise = text "-XNo" <> text name+ where name = flagSpecName flag+ f = flagSpecFlag flag+ is_on = test f dflags+ quiet = not show_all && test f default_dflags == is_on++ llvmConfig = (llvmTargets dflags, llvmPasses dflags)++ default_dflags =+ defaultDynFlags (settings dflags) llvmConfig `lang_set`+ case language dflags of+ Nothing -> Just Haskell2010+ other -> other++showTargets :: GHCi ()+showTargets = mapM_ showTarget =<< GHC.getTargets+ where+ showTarget :: Target -> GHCi ()+ showTarget (Target (TargetFile f _) _ _) = liftIO (putStrLn f)+ showTarget (Target (TargetModule m) _ _) =+ liftIO (putStrLn $ moduleNameString m)++-- -----------------------------------------------------------------------------+-- Completion++completeCmd :: String -> GHCi ()+completeCmd argLine0 = case parseLine argLine0 of+ Just ("repl", resultRange, left) -> do+ (unusedLine,compls) <- ghciCompleteWord (reverse left,"")+ let compls' = takeRange resultRange compls+ liftIO . putStrLn $ unwords [ show (length compls'), show (length compls), show (reverse unusedLine) ]+ forM_ (takeRange resultRange compls) $ \(Completion r _ _) -> do+ liftIO $ print r+ _ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>")+ where+ parseLine argLine+ | null argLine = Nothing+ | null rest1 = Nothing+ | otherwise = (,,) dom <$> resRange <*> s+ where+ (dom, rest1) = breakSpace argLine+ (rng, rest2) = breakSpace rest1+ resRange | head rest1 == '"' = parseRange ""+ | otherwise = parseRange rng+ s | head rest1 == '"' = readMaybe rest1 :: Maybe String+ | otherwise = readMaybe rest2+ breakSpace = fmap (dropWhile isSpace) . break isSpace++ takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub++ -- syntax: [n-][m] with semantics "drop (n-1) . take m"+ parseRange :: String -> Maybe (Maybe Int,Maybe Int)+ parseRange s = case span isDigit s of+ (_, "") ->+ -- upper limit only+ Just (Nothing, bndRead s)+ (s1, '-' : s2)+ | all isDigit s2 ->+ Just (bndRead s1, bndRead s2)+ _ ->+ Nothing+ where+ bndRead x = if null x then Nothing else Just (read x)++++completeGhciCommand, completeMacro, completeIdentifier, completeModule,+ completeSetModule, completeSeti, completeShowiOptions,+ completeHomeModule, completeSetOptions, completeShowOptions,+ completeHomeModuleOrFile, completeExpression+ :: CompletionFunc GHCi++-- | Provide completions for last word in a given string.+--+-- Takes a tuple of two strings. First string is a reversed line to be+-- completed. Second string is likely unused, 'completeCmd' always passes an+-- empty string as second item in tuple.+ghciCompleteWord :: CompletionFunc GHCi+ghciCompleteWord line@(left,_) = case firstWord of+ -- If given string starts with `:` colon, and there is only one following+ -- word then provide REPL command completions. If there is more than one+ -- word complete either filename or builtin ghci commands or macros.+ ':':cmd | null rest -> completeGhciCommand line+ | otherwise -> do+ completion <- lookupCompletion cmd+ completion line+ -- If given string starts with `import` keyword provide module name+ -- completions+ "import" -> completeModule line+ -- otherwise provide identifier completions+ _ -> completeExpression line+ where+ (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left+ lookupCompletion ('!':_) = return completeFilename+ lookupCompletion c = do+ maybe_cmd <- lookupCommand' c+ case maybe_cmd of+ Just cmd -> return (cmdCompletionFunc cmd)+ Nothing -> return completeFilename++completeGhciCommand = wrapCompleter " " $ \w -> do+ macros <- ghci_macros <$> getGHCiState+ cmds <- ghci_commands `fmap` getGHCiState+ let macro_names = map (':':) . map cmdName $ macros+ let command_names = map (':':) . map cmdName $ filter (not . cmdHidden) cmds+ let{ candidates = case w of+ ':' : ':' : _ -> map (':':) command_names+ _ -> nub $ macro_names ++ command_names }+ return $ filter (w `isPrefixOf`) candidates++completeMacro = wrapIdentCompleter $ \w -> do+ cmds <- ghci_macros <$> getGHCiState+ return (filter (w `isPrefixOf`) (map cmdName cmds))++completeIdentifier line@(left, _) =+ -- Note: `left` is a reversed input+ case left of+ (x:_) | isSymbolChar x -> wrapCompleter (specials ++ spaces) complete line+ _ -> wrapIdentCompleter complete line+ where+ complete w = do+ rdrs <- GHC.getRdrNamesInScope+ dflags <- GHC.getSessionDynFlags+ return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))++completeModule = wrapIdentCompleter $ \w -> do+ dflags <- GHC.getSessionDynFlags+ let pkg_mods = allVisibleModules dflags+ loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules+ return $ filter (w `isPrefixOf`)+ $ map (showPpr dflags) $ loaded_mods ++ pkg_mods++completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do+ dflags <- GHC.getSessionDynFlags+ modules <- case m of+ Just '-' -> do+ imports <- GHC.getContext+ return $ map iiModuleName imports+ _ -> do+ let pkg_mods = allVisibleModules dflags+ loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules+ return $ loaded_mods ++ pkg_mods+ return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules++completeHomeModule = wrapIdentCompleter listHomeModules++listHomeModules :: String -> GHCi [String]+listHomeModules w = do+ g <- GHC.getModuleGraph+ let home_mods = map GHC.ms_mod_name (GHC.mgModSummaries g)+ dflags <- getDynFlags+ return $ sort $ filter (w `isPrefixOf`)+ $ map (showPpr dflags) home_mods++completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) opts)+ where opts = "args":"prog":"prompt":"prompt-cont":"prompt-function":+ "prompt-cont-function":"editor":"stop":flagList+ flagList = map head $ group $ sort allNonDeprecatedFlags++completeSeti = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) flagList)+ where flagList = map head $ group $ sort allNonDeprecatedFlags++completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) opts)+ where opts = ["args", "prog", "editor", "stop",+ "modules", "bindings", "linker", "breaks",+ "context", "packages", "paths", "language", "imports"]++completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) ["language"])++completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars+ $ unionComplete (fmap (map simpleCompletion) . listHomeModules)+ listFiles++unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]+unionComplete f1 f2 line = do+ cs1 <- f1 line+ cs2 <- f2 line+ return (cs1 ++ cs2)++wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi+wrapCompleter breakChars fun = completeWord Nothing breakChars+ $ fmap (map simpleCompletion . nubSort) . fun++wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi+wrapIdentCompleter = wrapCompleter word_break_chars++wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi+wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars+ $ \rest -> fmap (map simpleCompletion . nubSort) . fun (getModifier rest)+ where+ getModifier = find (`elem` modifChars)++-- | Return a list of visible module names for autocompletion.+-- (NB: exposed != visible)+allVisibleModules :: DynFlags -> [ModuleName]+allVisibleModules dflags = listVisibleModuleNames dflags++completeExpression = completeQuotedWord (Just '\\') "\"" listFiles+ completeIdentifier+++-- -----------------------------------------------------------------------------+-- commands for debugger++sprintCmd, printCmd, forceCmd :: String -> GHCi ()+sprintCmd = pprintCommand False False+printCmd = pprintCommand True False+forceCmd = pprintCommand False True++pprintCommand :: Bool -> Bool -> String -> GHCi ()+pprintCommand bind force str = do+ pprintClosureCommand bind force str++stepCmd :: String -> GHCi ()+stepCmd arg = withSandboxOnly ":step" $ step arg+ where+ step [] = doContinue (const True) GHC.SingleStep+ step expression = runStmt expression GHC.SingleStep >> return ()++stepLocalCmd :: String -> GHCi ()+stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg+ where+ step expr+ | not (null expr) = stepCmd expr+ | otherwise = do+ mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing -> stepCmd []+ Just loc -> do+ md <- fromJust <$> getCurrentBreakModule+ current_toplevel_decl <- enclosingTickSpan md loc+ doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep++stepModuleCmd :: String -> GHCi ()+stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg+ where+ step expr+ | not (null expr) = stepCmd expr+ | otherwise = do+ mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing -> stepCmd []+ Just pan -> do+ let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span+ doContinue f GHC.SingleStep++-- | Returns the span of the largest tick containing the srcspan given+enclosingTickSpan :: Module -> SrcSpan -> GHCi RealSrcSpan+enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"+enclosingTickSpan md (RealSrcSpan src) = do+ ticks <- getTickArray md+ let line = srcSpanStartLine src+ ASSERT(inRange (bounds ticks) line) do+ let enclosing_spans = [ pan | (_,pan) <- ticks ! line+ , realSrcSpanEnd pan >= realSrcSpanEnd src]+ return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans+ where++leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering+leftmostLargestRealSrcSpan a b =+ (realSrcSpanStart a `compare` realSrcSpanStart b)+ `thenCmp`+ (realSrcSpanEnd b `compare` realSrcSpanEnd a)++traceCmd :: String -> GHCi ()+traceCmd arg+ = withSandboxOnly ":trace" $ tr arg+ where+ tr [] = doContinue (const True) GHC.RunAndLogSteps+ tr expression = runStmt expression GHC.RunAndLogSteps >> return ()++continueCmd :: String -> GHCi ()+continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion++-- doContinue :: SingleStep -> GHCi ()+doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()+doContinue pre step = do+ runResult <- resume pre step+ _ <- afterRunStmt pre runResult+ return ()++abandonCmd :: String -> GHCi ()+abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do+ b <- GHC.abandon -- the prompt will change to indicate the new context+ when (not b) $ liftIO $ putStrLn "There is no computation running."++deleteCmd :: String -> GHCi ()+deleteCmd argLine = withSandboxOnly ":delete" $ do+ deleteSwitch $ words argLine+ where+ deleteSwitch :: [String] -> GHCi ()+ deleteSwitch [] =+ liftIO $ putStrLn "The delete command requires at least one argument."+ -- delete all break points+ deleteSwitch ("*":_rest) = discardActiveBreakPoints+ deleteSwitch idents = do+ mapM_ deleteOneBreak idents+ where+ deleteOneBreak :: String -> GHCi ()+ deleteOneBreak str+ | all isDigit str = deleteBreak (read str)+ | otherwise = return ()++historyCmd :: String -> GHCi ()+historyCmd arg+ | null arg = history 20+ | all isDigit arg = history (read arg)+ | otherwise = liftIO $ putStrLn "Syntax: :history [num]"+ where+ history num = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> liftIO $ putStrLn "Not stopped at a breakpoint"+ (r:_) -> do+ let hist = GHC.resumeHistory r+ (took,rest) = splitAt num hist+ case hist of+ [] -> liftIO $ putStrLn $+ "Empty history. Perhaps you forgot to use :trace?"+ _ -> do+ pans <- mapM GHC.getHistorySpan took+ let nums = map (printf "-%-3d:") [(1::Int)..]+ names = map GHC.historyEnclosingDecls took+ printForUser (vcat(zipWith3+ (\x y z -> x <+> y <+> z)+ (map text nums)+ (map (bold . hcat . punctuate colon . map text) names)+ (map (parens . ppr) pans)))+ liftIO $ putStrLn $ if null rest then "<end of history>" else "..."++bold :: SDoc -> SDoc+bold c | do_bold = text start_bold <> c <> text end_bold+ | otherwise = c++backCmd :: String -> GHCi ()+backCmd arg+ | null arg = back 1+ | all isDigit arg = back (read arg)+ | otherwise = liftIO $ putStrLn "Syntax: :back [num]"+ where+ back num = withSandboxOnly ":back" $ do+ (names, _, pan, _) <- GHC.back num+ printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan+ printTypeOfNames names+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]++forwardCmd :: String -> GHCi ()+forwardCmd arg+ | null arg = forward 1+ | all isDigit arg = forward (read arg)+ | otherwise = liftIO $ putStrLn "Syntax: :back [num]"+ where+ forward num = withSandboxOnly ":forward" $ do+ (names, ix, pan, _) <- GHC.forward num+ printForUser $ (if (ix == 0)+ then ptext (sLit "Stopped at")+ else ptext (sLit "Logged breakpoint at")) <+> ppr pan+ printTypeOfNames names+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]++-- handle the "break" command+breakCmd :: String -> GHCi ()+breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine++breakSwitch :: [String] -> GHCi ()+breakSwitch [] = do+ liftIO $ putStrLn "The break command requires at least one argument."+breakSwitch (arg1:rest)+ | looksLikeModuleName arg1 && not (null rest) = do+ md <- wantInterpretedModule arg1+ breakByModule md rest+ | all isDigit arg1 = do+ imports <- GHC.getContext+ case iiModules imports of+ (mn : _) -> do+ md <- lookupModuleName mn+ breakByModuleLine md (read arg1) rest+ [] -> do+ liftIO $ putStrLn "No modules are loaded with debugging support."+ | otherwise = do -- try parsing it as an identifier+ wantNameFromInterpretedModule noCanDo arg1 $ \name -> do+ maybe_info <- GHC.getModuleInfo (GHC.nameModule name)+ case maybe_info of+ Nothing -> noCanDo name (ptext (sLit "cannot get module info"))+ Just minf ->+ ASSERT( isExternalName name )+ findBreakAndSet (GHC.nameModule name) $+ findBreakForBind name (GHC.modInfoModBreaks minf)+ where+ noCanDo n why = printForUser $+ text "cannot set breakpoint on " <> ppr n <> text ": " <> why++breakByModule :: Module -> [String] -> GHCi ()+breakByModule md (arg1:rest)+ | all isDigit arg1 = do -- looks like a line number+ breakByModuleLine md (read arg1) rest+breakByModule _ _+ = breakSyntax++breakByModuleLine :: Module -> Int -> [String] -> GHCi ()+breakByModuleLine md line args+ | [] <- args = findBreakAndSet md $ maybeToList . findBreakByLine line+ | [col] <- args, all isDigit col =+ findBreakAndSet md $ maybeToList . findBreakByCoord Nothing (line, read col)+ | otherwise = breakSyntax++breakSyntax :: a+breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")++findBreakAndSet :: Module -> (TickArray -> [(Int, RealSrcSpan)]) -> GHCi ()+findBreakAndSet md lookupTickTree = do+ tickArray <- getTickArray md+ (breakArray, _) <- getModBreak md+ case lookupTickTree tickArray of+ [] -> liftIO $ putStrLn $ "No breakpoints found at that location."+ some -> mapM_ (breakAt breakArray) some+ where+ breakAt breakArray (tick, pan) = do+ setBreakFlag True breakArray tick+ (alreadySet, nm) <-+ recordBreak $ BreakLocation+ { breakModule = md+ , breakLoc = RealSrcSpan pan+ , breakTick = tick+ , onBreakCmd = ""+ }+ printForUser $+ text "Breakpoint " <> ppr nm <>+ if alreadySet+ then text " was already set at " <> ppr pan+ else text " activated at " <> ppr pan++-- When a line number is specified, the current policy for choosing+-- the best breakpoint is this:+-- - the leftmost complete subexpression on the specified line, or+-- - the leftmost subexpression starting on the specified line, or+-- - the rightmost subexpression enclosing the specified line+--+findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan)+findBreakByLine line arr+ | not (inRange (bounds arr) line) = Nothing+ | otherwise =+ listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd) comp) `mplus`+ listToMaybe (sortBy (compare `on` snd) incomp) `mplus`+ listToMaybe (sortBy (flip compare `on` snd) ticks)+ where+ ticks = arr ! line++ starts_here = [ (ix,pan) | (ix, pan) <- ticks,+ GHC.srcSpanStartLine pan == line ]++ (comp, incomp) = partition ends_here starts_here+ where ends_here (_,pan) = GHC.srcSpanEndLine pan == line++-- The aim is to find the breakpoints for all the RHSs of the+-- equations corresponding to a binding. So we find all breakpoints+-- for+-- (a) this binder only (not a nested declaration)+-- (b) that do not have an enclosing breakpoint+findBreakForBind :: Name -> GHC.ModBreaks -> TickArray+ -> [(BreakIndex,RealSrcSpan)]+findBreakForBind name modbreaks _ = filter (not . enclosed) ticks+ where+ ticks = [ (index, span)+ | (index, [n]) <- assocs (GHC.modBreaks_decls modbreaks),+ n == occNameString (nameOccName name),+ RealSrcSpan span <- [GHC.modBreaks_locs modbreaks ! index] ]+ enclosed (_,sp0) = any subspan ticks+ where subspan (_,sp) = sp /= sp0 &&+ realSrcSpanStart sp <= realSrcSpanStart sp0 &&+ realSrcSpanEnd sp0 <= realSrcSpanEnd sp++findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray+ -> Maybe (BreakIndex,RealSrcSpan)+findBreakByCoord mb_file (line, col) arr+ | not (inRange (bounds arr) line) = Nothing+ | otherwise =+ listToMaybe (sortBy (flip compare `on` snd) contains +++ sortBy (compare `on` snd) after_here)+ where+ ticks = arr ! line++ -- the ticks that span this coordinate+ contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan `spans` (line,col),+ is_correct_file pan ]++ is_correct_file pan+ | Just f <- mb_file = GHC.srcSpanFile pan == f+ | otherwise = True++ after_here = [ tick | tick@(_,pan) <- ticks,+ GHC.srcSpanStartLine pan == line,+ GHC.srcSpanStartCol pan >= col ]++-- For now, use ANSI bold on terminals that we know support it.+-- Otherwise, we add a line of carets under the active expression instead.+-- In particular, on Windows and when running the testsuite (which sets+-- TERM to vt100 for other reasons) we get carets.+-- We really ought to use a proper termcap/terminfo library.+do_bold :: Bool+do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]+ where mTerm = System.Environment.getEnv "TERM"+ `catchIO` \_ -> return "TERM not set"++start_bold :: String+start_bold = "\ESC[1m"+end_bold :: String+end_bold = "\ESC[0m"++-----------------------------------------------------------------------------+-- :where++whereCmd :: String -> GHCi ()+whereCmd = noArgs $ do+ mstrs <- getCallStackAtCurrentBreakpoint+ case mstrs of+ Nothing -> return ()+ Just strs -> liftIO $ putStrLn (renderStack strs)++-----------------------------------------------------------------------------+-- :list++listCmd :: String -> InputT GHCi ()+listCmd c = listCmd' c++listCmd' :: String -> InputT GHCi ()+listCmd' "" = do+ mb_span <- lift getCurrentBreakSpan+ case mb_span of+ Nothing ->+ printForUser $ text "Not stopped at a breakpoint; nothing to list"+ Just (RealSrcSpan pan) ->+ listAround pan True+ Just pan@(UnhelpfulSpan _) ->+ do resumes <- GHC.getResumeContext+ case resumes of+ [] -> panic "No resumes"+ (r:_) ->+ do let traceIt = case GHC.resumeHistory r of+ [] -> text "rerunning with :trace,"+ _ -> empty+ doWhat = traceIt <+> text ":back then :list"+ printForUser (text "Unable to list source for" <+>+ ppr pan+ $$ text "Try" <+> doWhat)+listCmd' str = list2 (words str)++list2 :: [String] -> InputT GHCi ()+list2 [arg] | all isDigit arg = do+ imports <- GHC.getContext+ case iiModules imports of+ [] -> liftIO $ putStrLn "No module to list"+ (mn : _) -> do+ md <- lift $ lookupModuleName mn+ listModuleLine md (read arg)+list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do+ md <- wantInterpretedModule arg1+ listModuleLine md (read arg2)+list2 [arg] = do+ wantNameFromInterpretedModule noCanDo arg $ \name -> do+ let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)+ case loc of+ RealSrcLoc l ->+ do tickArray <- ASSERT( isExternalName name )+ lift $ getTickArray (GHC.nameModule name)+ let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))+ (GHC.srcLocLine l, GHC.srcLocCol l)+ tickArray+ case mb_span of+ Nothing -> listAround (realSrcLocSpan l) False+ Just (_, pan) -> listAround pan False+ UnhelpfulLoc _ ->+ noCanDo name $ text "can't find its location: " <>+ ppr loc+ where+ noCanDo n why = printForUser $+ text "cannot list source code for " <> ppr n <> text ": " <> why+list2 _other =+ liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"++listModuleLine :: Module -> Int -> InputT GHCi ()+listModuleLine modl line = do+ graph <- GHC.getModuleGraph+ let this = GHC.mgLookupModule graph modl+ case this of+ Nothing -> panic "listModuleLine"+ Just summ -> do+ let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))+ loc = mkRealSrcLoc (mkFastString (filename)) line 0+ listAround (realSrcLocSpan loc) False++-- | list a section of a source file around a particular SrcSpan.+-- If the highlight flag is True, also highlight the span using+-- start_bold\/end_bold.++-- GHC files are UTF-8, so we can implement this by:+-- 1) read the file in as a BS and syntax highlight it as before+-- 2) convert the BS to String using utf-string, and write it out.+-- It would be better if we could convert directly between UTF-8 and the+-- console encoding, of course.+listAround :: MonadIO m => RealSrcSpan -> Bool -> InputT m ()+listAround pan do_highlight = do+ contents <- liftIO $ BS.readFile (unpackFS file)+ -- Drop carriage returns to avoid duplicates, see #9367.+ let ls = BS.split '\n' $ BS.filter (/= '\r') contents+ ls' = take (line2 - line1 + 1 + pad_before + pad_after) $+ drop (line1 - 1 - pad_before) $ ls+ fst_line = max 1 (line1 - pad_before)+ line_nos = [ fst_line .. ]++ highlighted | do_highlight = zipWith highlight line_nos ls'+ | otherwise = [\p -> BS.concat[p,l] | l <- ls']++ bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]+ prefixed = zipWith ($) highlighted bs_line_nos+ output = BS.intercalate (BS.pack "\n") prefixed++ let utf8Decoded = utf8DecodeByteString output+ liftIO $ putStrLn utf8Decoded+ where+ file = GHC.srcSpanFile pan+ line1 = GHC.srcSpanStartLine pan+ col1 = GHC.srcSpanStartCol pan - 1+ line2 = GHC.srcSpanEndLine pan+ col2 = GHC.srcSpanEndCol pan - 1++ pad_before | line1 == 1 = 0+ | otherwise = 1+ pad_after = 1++ highlight | do_bold = highlight_bold+ | otherwise = highlight_carets++ highlight_bold no line prefix+ | no == line1 && no == line2+ = let (a,r) = BS.splitAt col1 line+ (b,c) = BS.splitAt (col2-col1) r+ in+ BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]+ | no == line1+ = let (a,b) = BS.splitAt col1 line in+ BS.concat [prefix, a, BS.pack start_bold, b]+ | no == line2+ = let (a,b) = BS.splitAt col2 line in+ BS.concat [prefix, a, BS.pack end_bold, b]+ | otherwise = BS.concat [prefix, line]++ highlight_carets no line prefix+ | no == line1 && no == line2+ = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',+ BS.replicate (col2-col1) '^']+ | no == line1+ = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,+ prefix, line]+ | no == line2+ = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',+ BS.pack "^^"]+ | otherwise = BS.concat [prefix, line]+ where+ indent = BS.pack (" " ++ replicate (length (show no)) ' ')+ nl = BS.singleton '\n'+++-- --------------------------------------------------------------------------+-- Tick arrays++getTickArray :: Module -> GHCi TickArray+getTickArray modl = do+ st <- getGHCiState+ let arrmap = tickarrays st+ case lookupModuleEnv arrmap modl of+ Just arr -> return arr+ Nothing -> do+ (_breakArray, ticks) <- getModBreak modl+ let arr = mkTickArray (assocs ticks)+ setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}+ return arr++discardTickArrays :: GHCi ()+discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})++mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray+mkTickArray ticks+ = accumArray (flip (:)) [] (1, max_line)+ [ (line, (nm,pan)) | (nm,RealSrcSpan pan) <- ticks, line <- srcSpanLines pan ]+ where+ max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp) <- ticks ]+ srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]++-- don't reset the counter back to zero?+discardActiveBreakPoints :: GHCi ()+discardActiveBreakPoints = do+ st <- getGHCiState+ mapM_ (turnOffBreak.snd) (breaks st)+ setGHCiState $ st { breaks = [] }++deleteBreak :: Int -> GHCi ()+deleteBreak identity = do+ st <- getGHCiState+ let oldLocations = breaks st+ (this,rest) = partition (\loc -> fst loc == identity) oldLocations+ if null this+ then printForUser (text "Breakpoint" <+> ppr identity <+>+ text "does not exist")+ else do+ mapM_ (turnOffBreak.snd) this+ setGHCiState $ st { breaks = rest }++turnOffBreak :: BreakLocation -> GHCi ()+turnOffBreak loc = do+ (arr, _) <- getModBreak (breakModule loc)+ hsc_env <- GHC.getSession+ liftIO $ enableBreakpoint hsc_env arr (breakTick loc) False++getModBreak :: Module -> GHCi (ForeignRef BreakArray, Array Int SrcSpan)+getModBreak m = do+ mod_info <- fromJust <$> GHC.getModuleInfo m+ let modBreaks = GHC.modInfoModBreaks mod_info+ let arr = GHC.modBreaks_flags modBreaks+ let ticks = GHC.modBreaks_locs modBreaks+ return (arr, ticks)++setBreakFlag :: Bool -> ForeignRef BreakArray -> Int -> GHCi ()+setBreakFlag toggle arr i = do+ hsc_env <- GHC.getSession+ liftIO $ enableBreakpoint hsc_env arr i toggle++-- ---------------------------------------------------------------------------+-- User code exception handling++-- This is the exception handler for exceptions generated by the+-- user's code and exceptions coming from children sessions;+-- it normally just prints out the exception. The+-- handler must be recursive, in case showing the exception causes+-- more exceptions to be raised.+--+-- Bugfix: if the user closed stdout or stderr, the flushing will fail,+-- raising another exception. We therefore don't put the recursive+-- handler arond the flushing operation, so if stderr is closed+-- GHCi will just die gracefully rather than going into an infinite loop.+handler :: SomeException -> GHCi Bool++handler exception = do+ flushInterpBuffers+ withSignalHandlers $+ ghciHandle handler (showException exception >> return False)++showException :: SomeException -> GHCi ()+showException se =+ liftIO $ case fromException se of+ -- omit the location for CmdLineError:+ Just (CmdLineError s) -> putException s+ -- ditto:+ Just other_ghc_ex -> putException (show other_ghc_ex)+ Nothing ->+ case fromException se of+ Just UserInterrupt -> putException "Interrupted."+ _ -> putException ("*** Exception: " ++ show se)+ where+ putException = hPutStrLn stderr+++-----------------------------------------------------------------------------+-- recursive exception handlers++-- Don't forget to unblock async exceptions in the handler, or if we're+-- in an exception loop (eg. let a = error a in a) the ^C exception+-- may never be delivered. Thanks to Marcin for pointing out the bug.++ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a+ghciHandle h m = gmask $ \restore -> do+ -- Force dflags to avoid leaking the associated HscEnv+ !dflags <- getDynFlags+ gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)++ghciTry :: GHCi a -> GHCi (Either SomeException a)+ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)++tryBool :: GHCi a -> GHCi Bool+tryBool m = do+ r <- ghciTry m+ case r of+ Left _ -> return False+ Right _ -> return True++-- ----------------------------------------------------------------------------+-- Utils++lookupModule :: GHC.GhcMonad m => String -> m Module+lookupModule mName = lookupModuleName (GHC.mkModuleName mName)++lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module+lookupModuleName mName = GHC.lookupModule mName Nothing++isHomeModule :: Module -> Bool+isHomeModule m = GHC.moduleUnitId m == mainUnitId++-- TODO: won't work if home dir is encoded.+-- (changeDirectory may not work either in that case.)+expandPath :: MonadIO m => String -> InputT m String+expandPath = liftIO . expandPathIO++expandPathIO :: String -> IO String+expandPathIO p =+ case dropWhile isSpace p of+ ('~':d) -> do+ tilde <- getHomeDirectory -- will fail if HOME not defined+ return (tilde ++ '/':d)+ other ->+ return other++wantInterpretedModule :: GHC.GhcMonad m => String -> m Module+wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)++wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module+wantInterpretedModuleName modname = do+ modl <- lookupModuleName modname+ let str = moduleNameString modname+ dflags <- getDynFlags+ when (GHC.moduleUnitId modl /= thisPackage dflags) $+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))+ is_interpreted <- GHC.moduleIsInterpreted modl+ when (not is_interpreted) $+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))+ return modl++wantNameFromInterpretedModule :: GHC.GhcMonad m+ => (Name -> SDoc -> m ())+ -> String+ -> (Name -> m ())+ -> m ()+wantNameFromInterpretedModule noCanDo str and_then =+ handleSourceError GHC.printException $ do+ names <- GHC.parseName str+ case names of+ [] -> return ()+ (n:_) -> do+ let modl = ASSERT( isExternalName n ) GHC.nameModule n+ if not (GHC.isExternalName n)+ then noCanDo n $ ppr n <>+ text " is not defined in an interpreted module"+ else do+ is_interpreted <- GHC.moduleIsInterpreted modl+ if not is_interpreted+ then noCanDo n $ text "module " <> ppr modl <>+ text " is not interpreted"+ else and_then n
+ src-bin-861/Clash/GHCi/UI/Info.hs view
@@ -0,0 +1,368 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Get information on modules, expressions, and identifiers+module Clash.GHCi.UI.Info+ ( ModInfo(..)+ , SpanInfo(..)+ , spanInfoFromRealSrcSpan+ , collectInfo+ , findLoc+ , findNameUses+ , findType+ , getModInfo+ ) where++import Control.Exception+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+import Control.Monad.Trans.Maybe+import Data.Data+import Data.Function+import Data.List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Time+import Prelude hiding (mod,(<>))+import System.Directory++import qualified CoreUtils+import Desugar+import DynFlags (HasDynFlags(..))+import FastString+import GHC+import GhcMonad+import Name+import NameSet+import Outputable+import SrcLoc+import TcHsSyn+import Var++-- | Info about a module. This information is generated every time a+-- module is loaded.+data ModInfo = ModInfo+ { modinfoSummary :: !ModSummary+ -- ^ Summary generated by GHC. Can be used to access more+ -- information about the module.+ , modinfoSpans :: [SpanInfo]+ -- ^ Generated set of information about all spans in the+ -- module that correspond to some kind of identifier for+ -- which there will be type info and/or location info.+ , modinfoInfo :: !ModuleInfo+ -- ^ Again, useful from GHC for accessing information+ -- (exports, instances, scope) from a module.+ , modinfoLastUpdate :: !UTCTime+ }++-- | Type of some span of source code. Most of these fields are+-- unboxed but Haddock doesn't show that.+data SpanInfo = SpanInfo+ { spaninfoSrcSpan :: {-# UNPACK #-} !RealSrcSpan+ -- ^ The span we associate information with+ , spaninfoType :: !(Maybe Type)+ -- ^ The 'Type' associated with the span+ , spaninfoVar :: !(Maybe Id)+ -- ^ The actual 'Var' associated with the span, if+ -- any. This can be useful for accessing a variety of+ -- information about the identifier such as module,+ -- locality, definition location, etc.+ }++-- | Test whether second span is contained in (or equal to) first span.+-- This is basically 'containsSpan' for 'SpanInfo'+containsSpanInfo :: SpanInfo -> SpanInfo -> Bool+containsSpanInfo = containsSpan `on` spaninfoSrcSpan++-- | Filter all 'SpanInfo' which are contained in 'SpanInfo'+spaninfosWithin :: [SpanInfo] -> SpanInfo -> [SpanInfo]+spaninfosWithin spans' si = filter (si `containsSpanInfo`) spans'++-- | Construct a 'SpanInfo' from a 'RealSrcSpan' and optionally a+-- 'Type' and an 'Id' (for 'spaninfoType' and 'spaninfoVar'+-- respectively)+spanInfoFromRealSrcSpan :: RealSrcSpan -> Maybe Type -> Maybe Id -> SpanInfo+spanInfoFromRealSrcSpan spn mty mvar =+ SpanInfo spn mty mvar++-- | Convenience wrapper around 'spanInfoFromRealSrcSpan' which needs+-- only a 'RealSrcSpan'+spanInfoFromRealSrcSpan' :: RealSrcSpan -> SpanInfo+spanInfoFromRealSrcSpan' s = spanInfoFromRealSrcSpan s Nothing Nothing++-- | Convenience wrapper around 'srcSpanFile' which results in a 'FilePath'+srcSpanFilePath :: RealSrcSpan -> FilePath+srcSpanFilePath = unpackFS . srcSpanFile++-- | Try to find the location of the given identifier at the given+-- position in the module.+findLoc :: GhcMonad m+ => Map ModuleName ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT SDoc m (ModInfo,Name,SrcSpan)+findLoc infos span0 string = do+ name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $+ guessModule infos (srcSpanFilePath span0)++ info <- maybeToExceptT "No module info for current file! Try loading it?" $+ MaybeT $ pure $ M.lookup name infos++ name' <- findName infos span0 info string++ case getSrcSpan name' of+ UnhelpfulSpan{} -> do+ throwE ("Found a name, but no location information." <+>+ "The module is:" <+>+ maybe "<unknown>" (ppr . moduleName)+ (nameModule_maybe name'))++ span' -> return (info,name',span')++-- | Find any uses of the given identifier in the codebase.+findNameUses :: (GhcMonad m)+ => Map ModuleName ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT SDoc m [SrcSpan]+findNameUses infos span0 string =+ locToSpans <$> findLoc infos span0 string+ where+ locToSpans (modinfo,name',span') =+ stripSurrounding (span' : map toSrcSpan spans)+ where+ toSrcSpan = RealSrcSpan . spaninfoSrcSpan+ spans = filter ((== Just name') . fmap getName . spaninfoVar)+ (modinfoSpans modinfo)++-- | Filter out redundant spans which surround/contain other spans.+stripSurrounding :: [SrcSpan] -> [SrcSpan]+stripSurrounding xs = filter (not . isRedundant) xs+ where+ isRedundant x = any (x `strictlyContains`) xs++ (RealSrcSpan s1) `strictlyContains` (RealSrcSpan s2)+ = s1 /= s2 && s1 `containsSpan` s2+ _ `strictlyContains` _ = False++-- | Try to resolve the name located at the given position, or+-- otherwise resolve based on the current module's scope.+findName :: GhcMonad m+ => Map ModuleName ModInfo+ -> RealSrcSpan+ -> ModInfo+ -> String+ -> ExceptT SDoc m Name+findName infos span0 mi string =+ case resolveName (modinfoSpans mi) (spanInfoFromRealSrcSpan' span0) of+ Nothing -> tryExternalModuleResolution+ Just name ->+ case getSrcSpan name of+ UnhelpfulSpan {} -> tryExternalModuleResolution+ RealSrcSpan {} -> return (getName name)+ where+ tryExternalModuleResolution =+ case find (matchName $ mkFastString string)+ (fromMaybe [] (modInfoTopLevelScope (modinfoInfo mi))) of+ Nothing -> throwE "Couldn't resolve to any modules."+ Just imported -> resolveNameFromModule infos imported++ matchName :: FastString -> Name -> Bool+ matchName str name =+ str ==+ occNameFS (getOccName name)++-- | Try to resolve the name from another (loaded) module's exports.+resolveNameFromModule :: GhcMonad m+ => Map ModuleName ModInfo+ -> Name+ -> ExceptT SDoc m Name+resolveNameFromModule infos name = do+ modL <- maybe (throwE $ "No module for" <+> ppr name) return $+ nameModule_maybe name++ info <- maybe (throwE (ppr (moduleUnitId modL) <> ":" <>+ ppr modL)) return $+ M.lookup (moduleName modL) infos++ maybe (throwE "No matching export in any local modules.") return $+ find (matchName name) (modInfoExports (modinfoInfo info))+ where+ matchName :: Name -> Name -> Bool+ matchName x y = occNameFS (getOccName x) ==+ occNameFS (getOccName y)++-- | Try to resolve the type display from the given span.+resolveName :: [SpanInfo] -> SpanInfo -> Maybe Var+resolveName spans' si = listToMaybe $ mapMaybe spaninfoVar $+ reverse spans' `spaninfosWithin` si++-- | Try to find the type of the given span.+findType :: GhcMonad m+ => Map ModuleName ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT SDoc m (ModInfo, Type)+findType infos span0 string = do+ name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $+ guessModule infos (srcSpanFilePath span0)++ info <- maybeToExceptT "No module info for current file! Try loading it?" $+ MaybeT $ pure $ M.lookup name infos++ case resolveType (modinfoSpans info) (spanInfoFromRealSrcSpan' span0) of+ Nothing -> (,) info <$> lift (exprType TM_Inst string)+ Just ty -> return (info, ty)+ where+ -- | Try to resolve the type display from the given span.+ resolveType :: [SpanInfo] -> SpanInfo -> Maybe Type+ resolveType spans' si = listToMaybe $ mapMaybe spaninfoType $+ reverse spans' `spaninfosWithin` si++-- | Guess a module name from a file path.+guessModule :: GhcMonad m+ => Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName+guessModule infos fp = do+ target <- lift $ guessTarget fp Nothing+ case targetId target of+ TargetModule mn -> return mn+ TargetFile fp' _ -> guessModule' fp'+ where+ guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName+ guessModule' fp' = case findModByFp fp' of+ Just mn -> return mn+ Nothing -> do+ fp'' <- liftIO (makeRelativeToCurrentDirectory fp')++ target' <- lift $ guessTarget fp'' Nothing+ case targetId target' of+ TargetModule mn -> return mn+ _ -> MaybeT . pure $ findModByFp fp''++ findModByFp :: FilePath -> Maybe ModuleName+ findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos)+ where+ mifp :: (ModuleName, ModInfo) -> Maybe FilePath+ mifp = ml_hs_file . ms_location . modinfoSummary . snd+++-- | Collect type info data for the loaded modules.+collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]+ -> m (Map ModuleName ModInfo)+collectInfo ms loaded = do+ df <- getDynFlags+ liftIO (filterM cacheInvalid loaded) >>= \case+ [] -> return ms+ invalidated -> do+ liftIO (putStrLn ("Collecting type info for " +++ show (length invalidated) +++ " module(s) ... "))++ foldM (go df) ms invalidated+ where+ go df m name = do { info <- getModInfo name; return (M.insert name info m) }+ `gcatch`+ (\(e :: SomeException) -> do+ liftIO $ putStrLn+ $ showSDocForUser df alwaysQualify+ $ "Error while getting type info from" <+>+ ppr name <> ":" <+> text (show e)+ return m)++ cacheInvalid name = case M.lookup name ms of+ Nothing -> return True+ Just mi -> do+ let src_fp = ml_hs_file (ms_location (modinfoSummary mi))+ obj_fp = ml_obj_file (ms_location (modinfoSummary mi))+ fp = fromMaybe obj_fp src_fp+ last' = modinfoLastUpdate mi+ exists <- doesFileExist fp+ if exists+ then (> last') <$> getModificationTime fp+ else return True++-- | Get info about the module: summary, types, etc.+getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo+getModInfo name = do+ m <- getModSummary name+ p <- parseModule m+ typechecked <- typecheckModule p+ allTypes <- processAllTypeCheckedModule typechecked+ let i = tm_checked_module_info typechecked+ now <- liftIO getCurrentTime+ return (ModInfo m allTypes i now)++-- | Get ALL source spans in the module.+processAllTypeCheckedModule :: forall m . GhcMonad m => TypecheckedModule+ -> m [SpanInfo]+processAllTypeCheckedModule tcm = do+ bts <- mapM getTypeLHsBind $ listifyAllSpans tcs+ ets <- mapM getTypeLHsExpr $ listifyAllSpans tcs+ pts <- mapM getTypeLPat $ listifyAllSpans tcs+ return $ mapMaybe toSpanInfo+ $ sortBy cmpSpan+ $ catMaybes (bts ++ ets ++ pts)+ where+ tcs = tm_typechecked_source tcm++ -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's+ getTypeLHsBind :: LHsBind GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))+ getTypeLHsBind (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _})+ = pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid))+ getTypeLHsBind _ = pure Nothing++ -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's+ getTypeLHsExpr :: LHsExpr GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))+ getTypeLHsExpr e = do+ hs_env <- getSession+ (_,mbe) <- liftIO $ deSugarExpr hs_env e+ return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe+ where+ mid :: Maybe Id+ mid | HsVar _ (L _ i) <- unwrapVar (unLoc e) = Just i+ | otherwise = Nothing++ unwrapVar (HsWrap _ _ var) = var+ unwrapVar e' = e'++ -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's+ getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))+ getTypeLPat (L spn pat) =+ pure (Just (getMaybeId pat,spn,hsPatType pat))+ where+ getMaybeId (VarPat _ (L _ vid)) = Just vid+ getMaybeId _ = Nothing++ -- | Get ALL source spans in the source.+ listifyAllSpans :: Typeable a => TypecheckedSource -> [Located a]+ listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x]))+ where+ p (L spn _) = isGoodSrcSpan spn++ -- | Variant of @syb@'s @everything@ (which summarises all nodes+ -- in top-down, left-to-right order) with a stop-condition on 'NameSet's+ everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r+ everythingAllSpans k z f x+ | (False `mkQ` (const True :: NameSet -> Bool)) x = z+ | otherwise = foldl k (f x) (gmapQ (everythingAllSpans k z f) x)++ cmpSpan (_,a,_) (_,b,_)+ | a `isSubspanOf` b = LT+ | b `isSubspanOf` a = GT+ | otherwise = EQ++ -- | Pretty print the types into a 'SpanInfo'.+ toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo+ toSpanInfo (n,RealSrcSpan spn,typ)+ = Just $ spanInfoFromRealSrcSpan spn (Just typ) n+ toSpanInfo _ = Nothing++-- helper stolen from @syb@ package+type GenericQ r = forall a. Data a => a -> r++mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r+(r `mkQ` br) a = maybe r br (cast a)
+ src-bin-861/Clash/GHCi/UI/Monad.hs view
@@ -0,0 +1,470 @@+{-# LANGUAGE CPP, FlexibleInstances, UnboxedTuples, MagicHash #-}+{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}+-- -fno-cse is needed for GLOBAL_VAR's to behave properly++-----------------------------------------------------------------------------+--+-- Monadery code used in InteractiveUI+--+-- (c) The GHC Team 2005-2006+--+-----------------------------------------------------------------------------++module Clash.GHCi.UI.Monad (+ GHCi(..), startGHCi,+ GHCiState(..), setGHCiState, getGHCiState, modifyGHCiState,+ GHCiOption(..), isOptionSet, setOption, unsetOption,+ Command(..),+ PromptFunction,+ BreakLocation(..),+ TickArray,+ getDynFlags,++ runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs,++ printForUserNeverQualify, printForUserModInfo,+ printForUser, printForUserPartWay, prettyLocations,+ initInterpBuffering,+ turnOffBuffering, turnOffBuffering_,+ flushInterpBuffers,+ mkEvalWrapper+ ) where++#include "HsVersions.h"++import Clash.GHCi.UI.Info (ModInfo)+import qualified GHC+import GhcMonad hiding (liftIO)+import Outputable hiding (printForUser, printForUserPartWay)+import qualified Outputable+import DynFlags+import FastString+import HscTypes+import SrcLoc+import Module+import GHCi+import GHCi.RemoteTypes+import HsSyn (ImportDecl, GhcPs)+import Util++import Exception+import Numeric+import Data.Array+import Data.IORef+import Data.Time+import System.Environment+import System.IO+import Control.Monad+import Prelude hiding ((<>))++import System.Console.Haskeline (CompletionFunc, InputT)+import qualified System.Console.Haskeline as Haskeline+import Control.Monad.Trans.Class+import Control.Monad.IO.Class+import Data.Map.Strict (Map)+import qualified GHC.LanguageExtensions as LangExt++-----------------------------------------------------------------------------+-- GHCi monad++data GHCiState = GHCiState+ {+ progname :: String,+ args :: [String],+ evalWrapper :: ForeignHValue, -- ^ of type @IO a -> IO a@+ prompt :: PromptFunction,+ prompt_cont :: PromptFunction,+ editor :: String,+ stop :: String,+ options :: [GHCiOption],+ line_number :: !Int, -- ^ input line+ break_ctr :: !Int,+ breaks :: ![(Int, BreakLocation)],+ tickarrays :: ModuleEnv TickArray,+ -- ^ 'tickarrays' caches the 'TickArray' for loaded modules,+ -- so that we don't rebuild it each time the user sets+ -- a breakpoint.+ ghci_commands :: [Command],+ -- ^ available ghci commands+ ghci_macros :: [Command],+ -- ^ user-defined macros+ last_command :: Maybe Command,+ -- ^ @:@ at the GHCi prompt repeats the last command, so we+ -- remember it here+ cmdqueue :: [String],++ remembered_ctx :: [InteractiveImport],+ -- ^ The imports that the user has asked for, via import+ -- declarations and :module commands. This list is+ -- persistent over :reloads (but any imports for modules+ -- that are not loaded are temporarily ignored). After a+ -- :load, all the home-package imports are stripped from+ -- this list.+ --+ -- See bugs #2049, #1873, #1360++ transient_ctx :: [InteractiveImport],+ -- ^ An import added automatically after a :load, usually of+ -- the most recently compiled module. May be empty if+ -- there are no modules loaded. This list is replaced by+ -- :load, :reload, and :add. In between it may be modified+ -- by :module.++ extra_imports :: [ImportDecl GhcPs],+ -- ^ These are "always-on" imports, added to the+ -- context regardless of what other imports we have.+ -- This is useful for adding imports that are required+ -- by setGHCiMonad. Be careful adding things here:+ -- you can create ambiguities if these imports overlap+ -- with other things in scope.+ --+ -- NB. although this is not currently used by GHCi itself,+ -- it was added to support other front-ends that are based+ -- on the GHCi code. Potentially we could also expose+ -- this functionality via GHCi commands.++ prelude_imports :: [ImportDecl GhcPs],+ -- ^ These imports are added to the context when+ -- -XImplicitPrelude is on and we don't have a *-module+ -- in the context. They can also be overridden by another+ -- import for the same module, e.g.+ -- "import Prelude hiding (map)"++ ghc_e :: Bool, -- ^ True if this is 'ghc -e' (or runghc)++ short_help :: String,+ -- ^ help text to display to a user+ long_help :: String,+ lastErrorLocations :: IORef [(FastString, Int)],++ mod_infos :: !(Map ModuleName ModInfo),++ flushStdHandles :: ForeignHValue,+ -- ^ @hFlush stdout; hFlush stderr@ in the interpreter+ noBuffering :: ForeignHValue+ -- ^ @hSetBuffering NoBuffering@ for stdin/stdout/stderr+ }++type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]++-- | A GHCi command+data Command+ = Command+ { cmdName :: String+ -- ^ Name of GHCi command (e.g. "exit")+ , cmdAction :: String -> InputT GHCi Bool+ -- ^ The 'Bool' value denotes whether to exit GHCi+ , cmdHidden :: Bool+ -- ^ Commands which are excluded from default completion+ -- and @:help@ summary. This is usually set for commands not+ -- useful for interactive use but rather for IDEs.+ , cmdCompletionFunc :: CompletionFunc GHCi+ -- ^ 'CompletionFunc' for arguments+ }++type PromptFunction = [String]+ -> Int+ -> GHCi SDoc++data GHCiOption+ = ShowTiming -- show time/allocs after evaluation+ | ShowType -- show the type of expressions+ | RevertCAFs -- revert CAFs after every evaluation+ | Multiline -- use multiline commands+ | CollectInfo -- collect and cache information about+ -- modules after load+ deriving Eq++data BreakLocation+ = BreakLocation+ { breakModule :: !GHC.Module+ , breakLoc :: !SrcSpan+ , breakTick :: {-# UNPACK #-} !Int+ , onBreakCmd :: String+ }++instance Eq BreakLocation where+ loc1 == loc2 = breakModule loc1 == breakModule loc2 &&+ breakTick loc1 == breakTick loc2++prettyLocations :: [(Int, BreakLocation)] -> SDoc+prettyLocations [] = text "No active breakpoints."+prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs++instance Outputable BreakLocation where+ ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>+ if null (onBreakCmd loc)+ then Outputable.empty+ else doubleQuotes (text (onBreakCmd loc))++recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)+recordBreak brkLoc = do+ st <- getGHCiState+ let oldActiveBreaks = breaks st+ -- don't store the same break point twice+ case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of+ (nm:_) -> return (True, nm)+ [] -> do+ let oldCounter = break_ctr st+ newCounter = oldCounter + 1+ setGHCiState $ st { break_ctr = newCounter,+ breaks = (oldCounter, brkLoc) : oldActiveBreaks+ }+ return (False, oldCounter)++newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }++reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a+reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s++reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a+reifyGHCi f = GHCi f'+ where+ -- f' :: IORef GHCiState -> Ghc a+ f' gs = reifyGhc (f'' gs)+ -- f'' :: IORef GHCiState -> Session -> IO a+ f'' gs s = f (s, gs)++startGHCi :: GHCi a -> GHCiState -> Ghc a+startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref++instance Functor GHCi where+ fmap = liftM++instance Applicative GHCi where+ pure a = GHCi $ \_ -> pure a+ (<*>) = ap++instance Monad GHCi where+ (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s++class HasGhciState m where+ getGHCiState :: m GHCiState+ setGHCiState :: GHCiState -> m ()+ modifyGHCiState :: (GHCiState -> GHCiState) -> m ()++instance HasGhciState GHCi where+ getGHCiState = GHCi $ \r -> liftIO $ readIORef r+ setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s+ modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f++instance (MonadTrans t, Monad m, HasGhciState m) => HasGhciState (t m) where+ getGHCiState = lift getGHCiState+ setGHCiState = lift . setGHCiState+ modifyGHCiState = lift . modifyGHCiState++liftGhc :: Ghc a -> GHCi a+liftGhc m = GHCi $ \_ -> m++instance MonadIO GHCi where+ liftIO = liftGhc . liftIO++instance HasDynFlags GHCi where+ getDynFlags = getSessionDynFlags++instance GhcMonad GHCi where+ setSession s' = liftGhc $ setSession s'+ getSession = liftGhc $ getSession++instance HasDynFlags (InputT GHCi) where+ getDynFlags = lift getDynFlags++instance GhcMonad (InputT GHCi) where+ setSession = lift . setSession+ getSession = lift getSession++instance ExceptionMonad GHCi where+ gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)+ gmask f =+ GHCi $ \s -> gmask $ \io_restore ->+ let+ g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')+ in+ unGHCi (f g_restore) s++instance Haskeline.MonadException Ghc where+ controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let+ run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)+ in fmap (flip unGhc s) $ f run'++instance Haskeline.MonadException GHCi where+ controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let+ run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)+ in fmap (flip unGHCi s) $ f run'++instance ExceptionMonad (InputT GHCi) where+ gcatch = Haskeline.catch+ gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)++isOptionSet :: GHCiOption -> GHCi Bool+isOptionSet opt+ = do st <- getGHCiState+ return (opt `elem` options st)++setOption :: GHCiOption -> GHCi ()+setOption opt+ = do st <- getGHCiState+ setGHCiState (st{ options = opt : filter (/= opt) (options st) })++unsetOption :: GHCiOption -> GHCi ()+unsetOption opt+ = do st <- getGHCiState+ setGHCiState (st{ options = filter (/= opt) (options st) })++printForUserNeverQualify :: GhcMonad m => SDoc -> m ()+printForUserNeverQualify doc = do+ dflags <- getDynFlags+ liftIO $ Outputable.printForUser dflags stdout neverQualify doc++printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()+printForUserModInfo info doc = do+ dflags <- getDynFlags+ mUnqual <- GHC.mkPrintUnqualifiedForModule info+ unqual <- maybe GHC.getPrintUnqual return mUnqual+ liftIO $ Outputable.printForUser dflags stdout unqual doc++printForUser :: GhcMonad m => SDoc -> m ()+printForUser doc = do+ unqual <- GHC.getPrintUnqual+ dflags <- getDynFlags+ liftIO $ Outputable.printForUser dflags stdout unqual doc++printForUserPartWay :: SDoc -> GHCi ()+printForUserPartWay doc = do+ unqual <- GHC.getPrintUnqual+ dflags <- getDynFlags+ liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc++-- | Run a single Haskell expression+runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult)+runStmt expr step = do+ st <- getGHCiState+ GHC.handleSourceError (\e -> do GHC.printException e; return Nothing) $ do+ let opts = GHC.execOptions+ { GHC.execSourceFile = progname st+ , GHC.execLineNumber = line_number st+ , GHC.execSingleStep = step+ , GHC.execWrap = \fhv -> EvalApp (EvalThis (evalWrapper st))+ (EvalThis fhv) }+ Just <$> GHC.execStmt expr opts++runDecls :: String -> GHCi (Maybe [GHC.Name])+runDecls decls = do+ st <- getGHCiState+ reifyGHCi $ \x ->+ withProgName (progname st) $+ withArgs (args st) $+ reflectGHCi x $ do+ GHC.handleSourceError (\e -> do GHC.printException e;+ return Nothing) $ do+ r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls+ return (Just r)++resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.ExecResult+resume canLogSpan step = do+ st <- getGHCiState+ reifyGHCi $ \x ->+ withProgName (progname st) $+ withArgs (args st) $+ reflectGHCi x $ do+ GHC.resumeExec canLogSpan step++-- --------------------------------------------------------------------------+-- timing & statistics++timeIt :: (a -> Maybe Integer) -> InputT GHCi a -> InputT GHCi a+timeIt getAllocs action+ = do b <- lift $ isOptionSet ShowTiming+ if not b+ then action+ else do time1 <- liftIO $ getCurrentTime+ a <- action+ let allocs = getAllocs a+ time2 <- liftIO $ getCurrentTime+ dflags <- getDynFlags+ let period = time2 `diffUTCTime` time1+ liftIO $ printTimes dflags allocs (realToFrac period)+ return a++printTimes :: DynFlags -> Maybe Integer -> Double -> IO ()+printTimes dflags mallocs secs+ = do let secs_str = showFFloat (Just 2) secs+ putStrLn (showSDoc dflags (+ parens (text (secs_str "") <+> text "secs" <> comma <+>+ case mallocs of+ Nothing -> empty+ Just allocs ->+ text (separateThousands allocs) <+> text "bytes")))+ where+ separateThousands n = reverse . sep . reverse . show $ n+ where sep n'+ | n' `lengthAtMost` 3 = n'+ | otherwise = take 3 n' ++ "," ++ sep (drop 3 n')++-----------------------------------------------------------------------------+-- reverting CAFs++revertCAFs :: GHCi ()+revertCAFs = do+ liftIO rts_revertCAFs+ s <- getGHCiState+ when (not (ghc_e s)) turnOffBuffering+ -- Have to turn off buffering again, because we just+ -- reverted stdout, stderr & stdin to their defaults.++foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()+ -- Make it "safe", just in case++-----------------------------------------------------------------------------+-- To flush buffers for the *interpreted* computation we need+-- to refer to *its* stdout/stderr handles++-- | Compile "hFlush stdout; hFlush stderr" once, so we can use it repeatedly+initInterpBuffering :: Ghc (ForeignHValue, ForeignHValue)+initInterpBuffering = do+ nobuf <- compileGHCiExpr $+ "do { System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering; " +++ " System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering; " +++ " System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering }"+ flush <- compileGHCiExpr $+ "do { System.IO.hFlush System.IO.stdout; " +++ " System.IO.hFlush System.IO.stderr }"+ return (nobuf, flush)++-- | Invoke "hFlush stdout; hFlush stderr" in the interpreter+flushInterpBuffers :: GHCi ()+flushInterpBuffers = do+ st <- getGHCiState+ hsc_env <- GHC.getSession+ liftIO $ evalIO hsc_env (flushStdHandles st)++-- | Turn off buffering for stdin, stdout, and stderr in the interpreter+turnOffBuffering :: GHCi ()+turnOffBuffering = do+ st <- getGHCiState+ turnOffBuffering_ (noBuffering st)++turnOffBuffering_ :: GhcMonad m => ForeignHValue -> m ()+turnOffBuffering_ fhv = do+ hsc_env <- getSession+ liftIO $ evalIO hsc_env fhv++mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue+mkEvalWrapper progname args =+ compileGHCiExpr $+ "\\m -> System.Environment.withProgName " ++ show progname +++ "(System.Environment.withArgs " ++ show args ++ " m)"++compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue+compileGHCiExpr expr = do+ hsc_env <- getSession+ let dflags = hsc_dflags hsc_env+ -- RebindableSyntax can wreak havoc with GHCi in several ways+ -- (see #13385 and #14342 for examples), so we take care to disable it+ -- for the duration of running expressions that are internal to GHCi.+ no_rb_hsc_env =+ hsc_env { hsc_dflags = xopt_unset dflags LangExt.RebindableSyntax }+ setSession no_rb_hsc_env+ res <- GHC.compileExprRemote expr+ setSession hsc_env+ pure res
+ src-bin-861/Clash/GHCi/UI/Tags.hs view
@@ -0,0 +1,215 @@+-----------------------------------------------------------------------------+--+-- GHCi's :ctags and :etags commands+--+-- (c) The GHC Team 2005-2007+--+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+module Clash.GHCi.UI.Tags (+ createCTagsWithLineNumbersCmd,+ createCTagsWithRegExesCmd,+ createETagsFileCmd+) where++import Exception+import GHC+import Clash.GHCi.UI.Monad+import Outputable++-- ToDo: figure out whether we need these, and put something appropriate+-- into the GHC API instead+import Name (nameOccName)+import OccName (pprOccName)+import ConLike+import MonadUtils++import Data.Function+import Data.Maybe+import Data.Ord+import DriverPhases+import Panic+import Data.List+import Control.Monad+import System.Directory+import System.IO+import System.IO.Error++-----------------------------------------------------------------------------+-- create tags file for currently loaded modules.++createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd,+ createETagsFileCmd :: String -> GHCi ()++createCTagsWithLineNumbersCmd "" =+ ghciCreateTagsFile CTagsWithLineNumbers "tags"+createCTagsWithLineNumbersCmd file =+ ghciCreateTagsFile CTagsWithLineNumbers file++createCTagsWithRegExesCmd "" =+ ghciCreateTagsFile CTagsWithRegExes "tags"+createCTagsWithRegExesCmd file =+ ghciCreateTagsFile CTagsWithRegExes file++createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"+createETagsFileCmd file = ghciCreateTagsFile ETags file++data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes++ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()+ghciCreateTagsFile kind file = do+ createTagsFile kind file++-- ToDo:+-- - remove restriction that all modules must be interpreted+-- (problem: we don't know source locations for entities unless+-- we compiled the module.+--+-- - extract createTagsFile so it can be used from the command-line+-- (probably need to fix first problem before this is useful).+--+createTagsFile :: TagsKind -> FilePath -> GHCi ()+createTagsFile tagskind tagsFile = do+ graph <- GHC.getModuleGraph+ mtags <- mapM listModuleTags (map GHC.ms_mod $ GHC.mgModSummaries graph)+ either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags+ case either_res of+ Left e -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e+ Right _ -> return ()+++listModuleTags :: GHC.Module -> GHCi [TagInfo]+listModuleTags m = do+ is_interpreted <- GHC.moduleIsInterpreted m+ -- should we just skip these?+ when (not is_interpreted) $+ let mName = GHC.moduleNameString (GHC.moduleName m) in+ throwGhcException (CmdLineError ("module '" ++ mName ++ "' is not interpreted"))+ mbModInfo <- GHC.getModuleInfo m+ case mbModInfo of+ Nothing -> return []+ Just mInfo -> do+ dflags <- getDynFlags+ mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo+ let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual+ let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo+ let localNames = filter ((m==) . nameModule) names+ mbTyThings <- mapM GHC.lookupName localNames+ return $! [ tagInfo dflags unqual exported kind name realLoc+ | tyThing <- catMaybes mbTyThings+ , let name = getName tyThing+ , let exported = GHC.modInfoIsExportedName mInfo name+ , let kind = tyThing2TagKind tyThing+ , let loc = srcSpanStart (nameSrcSpan name)+ , RealSrcLoc realLoc <- [loc]+ ]++ where+ tyThing2TagKind (AnId _) = 'v'+ tyThing2TagKind (AConLike RealDataCon{}) = 'd'+ tyThing2TagKind (AConLike PatSynCon{}) = 'p'+ tyThing2TagKind (ATyCon _) = 't'+ tyThing2TagKind (ACoAxiom _) = 'x'+++data TagInfo = TagInfo+ { tagExported :: Bool -- is tag exported+ , tagKind :: Char -- tag kind+ , tagName :: String -- tag name+ , tagFile :: String -- file name+ , tagLine :: Int -- line number+ , tagCol :: Int -- column number+ , tagSrcInfo :: Maybe (String,Integer) -- source code line and char offset+ }+++-- get tag info, for later translation into Vim or Emacs style+tagInfo :: DynFlags -> PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc+ -> TagInfo+tagInfo dflags unqual exported kind name loc+ = TagInfo exported kind+ (showSDocForUser dflags unqual $ pprOccName (nameOccName name))+ (showSDocForUser dflags unqual $ ftext (srcLocFile loc))+ (srcLocLine loc) (srcLocCol loc) Nothing++-- throw an exception when someone tries to overwrite existing source file (fix for #10989)+writeTagsSafely :: FilePath -> String -> IO ()+writeTagsSafely file str = do+ dfe <- doesFileExist file+ if dfe && isSourceFilename file+ then throwGhcException (CmdLineError (file ++ " is existing source file. " +++ "Please specify another file name to store tags data"))+ else writeFile file str++collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())+-- ctags style with the Ex expression being just the line number, Vim et al+collateAndWriteTags CTagsWithLineNumbers file tagInfos = do+ let tags = unlines $ sort $ map showCTag tagInfos+ tryIO (writeTagsSafely file tags)++-- ctags style with the Ex expression being a regex searching the line, Vim et al+collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al+ tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos+ let tags = unlines $ sort $ map showCTag $concat tagInfoGroups+ tryIO (writeTagsSafely file tags)++collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs+ tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos+ let tagGroups = map processGroup tagInfoGroups+ tryIO (writeTagsSafely file $ concat tagGroups)++ where+ processGroup [] = throwGhcException (CmdLineError "empty tag file group??")+ processGroup group@(tagInfo:_) =+ let tags = unlines $ map showETag group in+ "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags+++makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]]+makeTagGroupsWithSrcInfo tagInfos = do+ let groups = groupBy ((==) `on` tagFile) $ sortBy (comparing tagFile) tagInfos+ mapM addTagSrcInfo groups++ where+ addTagSrcInfo [] = throwGhcException (CmdLineError "empty tag file group??")+ addTagSrcInfo group@(tagInfo:_) = do+ file <- readFile $tagFile tagInfo+ let sortedGroup = sortBy (comparing tagLine) group+ return $ perFile sortedGroup 1 0 $ lines file++ perFile allTags@(tag:tags) cnt pos allLs@(l:ls)+ | tagLine tag > cnt =+ perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls+ | tagLine tag == cnt =+ tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs+ perFile _ _ _ _ = []+++-- ctags format, for Vim et al+showCTag :: TagInfo -> String+showCTag ti =+ tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" +++ tagKind ti : ( if tagExported ti then "" else "\tfile:" )++ where+ tagCmd =+ case tagSrcInfo ti of+ Nothing -> show $tagLine ti+ Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/"++ where+ escapeSlashes '/' r = '\\' : '/' : r+ escapeSlashes '\\' r = '\\' : '\\' : r+ escapeSlashes c r = c : r+++-- etags format, for Emacs/XEmacs+showETag :: TagInfo -> String+showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo,+ tagSrcInfo = Just (srcLine,charPos) }+ = take (colNo - 1) srcLine ++ tag+ ++ "\x7f" ++ tag+ ++ "\x01" ++ show lineNo+ ++ "," ++ show charPos+showETag _ = throwGhcException (CmdLineError "missing source file info in showETag")
+ src-bin-861/Clash/Main.hs view
@@ -0,0 +1,1024 @@+{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables, TupleSections #-}+{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}++-----------------------------------------------------------------------------+--+-- GHC Driver program+--+-- (c) The University of Glasgow 2005+--+-----------------------------------------------------------------------------++module Clash.Main (defaultMain) where++-- For Int/Word size+#include "MachDeps.h"++-- The official GHC API+import qualified GHC+import GHC ( -- DynFlags(..), HscTarget(..),+ -- GhcMode(..), GhcLink(..),+ Ghc, GhcMonad(..),+ LoadHowMuch(..) )+import CmdLineParser++-- Implementations of the various modes (--show-iface, mkdependHS. etc.)+import LoadIface ( showIface )+import HscMain ( newHscEnv )+import DriverPipeline ( oneShot, compileFile )+import DriverMkDepend ( doMkDependHS )+import DriverBkp ( doBackpack )+#if defined(GHCI)+import Clash.GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )+#endif++-- Frontend plugins+#if defined(GHCI)+import DynamicLoading ( loadFrontendPlugin )+import Plugins+#else+import DynamicLoading ( pluginError )+#endif+import Module ( ModuleName )+++-- Various other random stuff that we need+import GHC.HandleEncoding+import Config+import Constants+import HscTypes+import Packages ( pprPackages, pprPackagesSimple )+import DriverPhases+import BasicTypes ( failed )+import DynFlags hiding (WarnReason(..))+import ErrUtils+import FastString+import Outputable+import SrcLoc+import Util+import Panic+import UniqSupply+import MonadUtils ( liftIO )+import DynamicLoading ( initializePlugins )++-- Imports for --abi-hash+import LoadIface ( loadUserInterface )+import Module ( mkModuleName )+import Finder ( findImportedModule, cannotFindModule )+import TcRnMonad ( initIfaceCheck )+import Binary ( openBinMem, put_ )+import BinFingerprint ( fingerprintBinMem )++-- Standard Haskell libraries+import System.IO+import System.Environment+import System.Exit+import System.FilePath+import Control.Monad+import Data.Char+import Data.List+import Data.Maybe++-- clash additions+import Paths_clash_ghc+import Clash.GHCi.UI (makeHDL)+import Exception (gcatch)+import Data.IORef (IORef, newIORef, readIORef)+import qualified Data.Version (showVersion)++import qualified Clash.Backend+import Clash.Backend.SystemVerilog (SystemVerilogState)+import Clash.Backend.VHDL (VHDLState)+import Clash.Backend.Verilog (VerilogState)+import Clash.Driver.Types+ (ClashOpts (..), defClashOpts)+import Clash.GHC.ClashFlags+import Clash.Netlist.BlackBox.Types (HdlSyn (..))+import Clash.Util (clashLibVersion)+import Clash.GHC.LoadModules (ghcLibDir, wantedLanguageExtensions)+import Clash.GHC.Util (handleClashException)++-----------------------------------------------------------------------------+-- ToDo:++-- time commands when run with -v+-- user ways+-- Win32 support: proper signal handling+-- reading the package configuration file is too slow+-- -K<size>++-----------------------------------------------------------------------------+-- GHC's command-line interface++defaultMain :: [String] -> IO ()+defaultMain = flip withArgs $ do+ initGCStatistics -- See Note [-Bsymbolic and hooks]+ hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering++ configureHandleEncoding+ GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do+ -- 1. extract the -B flag from the args+ argv0 <- getArgs++ -- let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0+ -- mbMinusB | null minusB_args = Nothing+ -- | otherwise = Just (drop 2 (last minusB_args))++ -- let argv2 = map (mkGeneralLocated "on the commandline") argv1+ libDir <- ghcLibDir++ let argv1 = map (mkGeneralLocated "on the commandline") argv0+ r <- newIORef defClashOpts+ (argv2, clashFlagWarnings) <- parseClashFlags r argv1++ -- 2. Parse the "mode" flags (--make, --interactive etc.)+ -- (mode, argv3, flagWarnings) <- parseModeFlags argv2+ (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2+ let flagWarnings = modeFlagWarnings ++ clashFlagWarnings++ -- If all we want to do is something like showing the version number+ -- then do it now, before we start a GHC session etc. This makes+ -- getting basic information much more resilient.++ -- In particular, if we wait until later before giving the version+ -- number then bootstrapping gets confused, as it tries to find out+ -- what version of GHC it's using before package.conf exists, so+ -- starting the session fails.+ case mode of+ Left preStartupMode ->+ do case preStartupMode of+ ShowSupportedExtensions -> showSupportedExtensions+ ShowVersion -> showVersion+ ShowNumVersion -> putStrLn cProjectVersion+ ShowOptions isInteractive -> showOptions isInteractive+ Right postStartupMode ->+ -- start our GHC session+ GHC.runGhc (Just libDir) $ do++ dflags <- GHC.getSessionDynFlags+ let dflagsExtra = wantedLanguageExtensions dflags++ ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise"+ ghcTyLitExtrPlugin = GHC.mkModuleName "GHC.TypeLits.Extra.Solver"+ ghcTyLitKNPlugin = GHC.mkModuleName "GHC.TypeLits.KnownNat.Solver"+ dflagsExtra1 = dflagsExtra+ { DynFlags.pluginModNames = nub $+ ghcTyLitNormPlugin : ghcTyLitExtrPlugin :+ ghcTyLitKNPlugin :+ DynFlags.pluginModNames dflagsExtra+ }++ case postStartupMode of+ Left preLoadMode ->+ liftIO $ do+ case preLoadMode of+ ShowInfo -> showInfo dflagsExtra1+ ShowGhcUsage -> showGhcUsage dflagsExtra1+ ShowGhciUsage -> showGhciUsage dflagsExtra1+ PrintWithDynFlags f -> putStrLn (f dflagsExtra1)+ Right postLoadMode ->+ main' postLoadMode dflagsExtra1 argv3 flagWarnings r++main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn]+ -> IORef ClashOpts+ -> Ghc ()+main' postLoadMode dflags0 args flagWarnings clashOpts = do+ -- set the default GhcMode, HscTarget and GhcLink. The HscTarget+ -- can be further adjusted on a module by module basis, using only+ -- the -fvia-C and -fasm flags. If the default HscTarget is not+ -- HscC or HscAsm, -fvia-C and -fasm have no effect.+ let dflt_target = hscTarget dflags0+ (mode, lang, link)+ = case postLoadMode of+ DoInteractive -> (CompManager, HscInterpreted, LinkInMemory)+ DoEval _ -> (CompManager, HscInterpreted, LinkInMemory)+ DoMake -> (CompManager, dflt_target, LinkBinary)+ DoBackpack -> (CompManager, dflt_target, LinkBinary)+ DoMkDependHS -> (MkDepend, dflt_target, LinkBinary)+ DoAbiHash -> (OneShot, dflt_target, LinkBinary)+ DoVHDL -> (CompManager, HscNothing, NoLink)+ DoVerilog -> (CompManager, HscNothing, NoLink)+ DoSystemVerilog -> (CompManager, HscNothing, NoLink)+ _ -> (OneShot, dflt_target, LinkBinary)++ let dflags1 = dflags0{ ghcMode = mode,+ hscTarget = lang,+ ghcLink = link,+ verbosity = case postLoadMode of+ DoEval _ -> 0+ _other -> 1+ }++ -- turn on -fimplicit-import-qualified for GHCi now, so that it+ -- can be overriden from the command-line+ -- XXX: this should really be in the interactive DynFlags, but+ -- we don't set that until later in interactiveUI+ -- We also set -fignore-optim-changes and -fignore-hpc-changes,+ -- which are program-level options. Again, this doesn't really+ -- feel like the right place to handle this, but we don't have+ -- a great story for the moment.+ dflags2 | DoInteractive <- postLoadMode = def_ghci_flags+ | DoEval _ <- postLoadMode = def_ghci_flags+ | otherwise = dflags1+ where def_ghci_flags = dflags1 `gopt_set` Opt_ImplicitImportQualified+ `gopt_set` Opt_IgnoreOptimChanges+ `gopt_set` Opt_IgnoreHpcChanges++ -- The rest of the arguments are "dynamic"+ -- Leftover ones are presumably files+ (dflags3, fileish_args, dynamicFlagWarnings) <-+ GHC.parseDynamicFlags dflags2 args++ let dflags4 = case lang of+ HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) ->+ let platform = targetPlatform dflags3+ dflags3a = updateWays $ dflags3 { ways = interpWays }+ dflags3b = foldl gopt_set dflags3a+ $ concatMap (wayGeneralFlags platform)+ interpWays+ dflags3c = foldl gopt_unset dflags3b+ $ concatMap (wayUnsetGeneralFlags platform)+ interpWays+ in dflags3c+ _ ->+ dflags3++ GHC.prettyPrintGhcErrors dflags4 $ do++ let flagWarnings' = flagWarnings ++ dynamicFlagWarnings++ handleSourceError (\e -> do+ GHC.printException e+ liftIO $ exitWith (ExitFailure 1)) $ do+ liftIO $ handleFlagWarnings dflags4 flagWarnings'++ liftIO $ showBanner postLoadMode dflags4++ let+ -- To simplify the handling of filepaths, we normalise all filepaths right+ -- away - e.g., for win32 platforms, backslashes are converted+ -- into forward slashes.+ normal_fileish_paths = map (normalise . unLoc) fileish_args+ (srcs, objs) = partition_args normal_fileish_paths [] []++ dflags5 = dflags4 { ldInputs = map (FileOption "") objs+ ++ ldInputs dflags4 }++ -- we've finished manipulating the DynFlags, update the session+ _ <- GHC.setSessionDynFlags dflags5+ dflags6 <- GHC.getSessionDynFlags+ hsc_env <- GHC.getSession++ ---------------- Display configuration -----------+ case verbosity dflags6 of+ v | v == 4 -> liftIO $ dumpPackagesSimple dflags6+ | v >= 5 -> liftIO $ dumpPackages dflags6+ | otherwise -> return ()++ liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6)+ ---------------- Final sanity checking -----------+ liftIO $ checkOptions postLoadMode dflags6 srcs objs++ ---------------- Do the business -----------+ handleSourceError (\e -> do+ GHC.printException e+ liftIO $ exitWith (ExitFailure 1)) $ do+ clashOpts' <- liftIO (readIORef clashOpts)+ let clash fun = gcatch (fun clashOpts srcs) (handleClashException dflags6 clashOpts')+ case postLoadMode of+ ShowInterface f -> liftIO $ doShowIface dflags6 f+ DoMake -> doMake srcs+ DoMkDependHS -> doMkDependHS (map fst srcs)+ StopBefore p -> liftIO (oneShot hsc_env p srcs)+ DoInteractive -> ghciUI clashOpts hsc_env dflags6 srcs Nothing+ DoEval exprs -> ghciUI clashOpts hsc_env dflags6 srcs $ Just $ reverse exprs+ DoAbiHash -> abiHash (map fst srcs)+ ShowPackages -> liftIO $ showPackages dflags6+ DoFrontend f -> doFrontend f srcs+ DoBackpack -> doBackpack (map fst srcs)+ DoVHDL -> clash makeVHDL+ DoVerilog -> clash makeVerilog+ DoSystemVerilog -> clash makeSystemVerilog++ liftIO $ dumpFinalStats dflags6++ghciUI :: IORef ClashOpts -> HscEnv -> DynFlags -> [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()+#if !defined(GHCI)+ghciUI _ _ _ _ _ = throwGhcException (CmdLineError "not built for interactive use")+#else+ghciUI opts hsc_env dflags0 srcs maybe_expr = do+ dflags1 <- liftIO (initializePlugins hsc_env dflags0)+ _ <- GHC.setSessionDynFlags dflags1+ interactiveUI (defaultGhciSettings opts) srcs maybe_expr+#endif++-- -----------------------------------------------------------------------------+-- Splitting arguments into source files and object files. This is where we+-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source+-- file indicating the phase specified by the -x option in force, if any.++partition_args :: [String] -> [(String, Maybe Phase)] -> [String]+ -> ([(String, Maybe Phase)], [String])+partition_args [] srcs objs = (reverse srcs, reverse objs)+partition_args ("-x":suff:args) srcs objs+ | "none" <- suff = partition_args args srcs objs+ | StopLn <- phase = partition_args args srcs (slurp ++ objs)+ | otherwise = partition_args rest (these_srcs ++ srcs) objs+ where phase = startPhase suff+ (slurp,rest) = break (== "-x") args+ these_srcs = zip slurp (repeat (Just phase))+partition_args (arg:args) srcs objs+ | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs+ | otherwise = partition_args args srcs (arg:objs)++ {-+ We split out the object files (.o, .dll) and add them+ to ldInputs for use by the linker.++ The following things should be considered compilation manager inputs:++ - haskell source files (strings ending in .hs, .lhs or other+ haskellish extension),++ - module names (not forgetting hierarchical module names),++ - things beginning with '-' are flags that were not recognised by+ the flag parser, and we want them to generate errors later in+ checkOptions, so we class them as source files (#5921)++ - and finally we consider everything without an extension to be+ a comp manager input, as shorthand for a .hs or .lhs filename.++ Everything else is considered to be a linker object, and passed+ straight through to the linker.+ -}+looks_like_an_input :: String -> Bool+looks_like_an_input m = isSourceFilename m+ || looksLikeModuleName m+ || "-" `isPrefixOf` m+ || not (hasExtension m)++-- -----------------------------------------------------------------------------+-- Option sanity checks++-- | Ensure sanity of options.+--+-- Throws 'UsageError' or 'CmdLineError' if not.+checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()+ -- Final sanity checking before kicking off a compilation (pipeline).+checkOptions mode dflags srcs objs = do+ -- Complain about any unknown flags+ let unknown_opts = [ f | (f@('-':_), _) <- srcs ]+ when (notNull unknown_opts) (unknownFlagsErr unknown_opts)++ when (notNull (filter wayRTSOnly (ways dflags))+ && isInterpretiveMode mode) $+ hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")++ -- -prof and --interactive are not a good combination+ when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays)+ && isInterpretiveMode mode+ && not (gopt Opt_ExternalInterpreter dflags)) $+ do throwGhcException (UsageError+ "-fexternal-interpreter is required when using --interactive with a non-standard way (-prof, -static, or -dynamic).")+ -- -ohi sanity check+ if (isJust (outputHi dflags) &&+ (isCompManagerMode mode || srcs `lengthExceeds` 1))+ then throwGhcException (UsageError "-ohi can only be used when compiling a single source file")+ else do++ -- -o sanity checking+ if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)+ && not (isLinkMode mode))+ then throwGhcException (UsageError "can't apply -o to multiple source files")+ else do++ let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)++ when (not_linking && not (null objs)) $+ hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)++ -- Check that there are some input files+ -- (except in the interactive case)+ if null srcs && (null objs || not_linking) && needsInputsMode mode+ then throwGhcException (UsageError "no input files")+ else do++ case mode of+ StopBefore HCc | hscTarget dflags /= HscC+ -> throwGhcException $ UsageError $+ "the option -C is only available with an unregisterised GHC"+ _ -> return ()++ -- Verify that output files point somewhere sensible.+ verifyOutputFiles dflags++-- Compiler output options++-- Called to verify that the output files point somewhere valid.+--+-- The assumption is that the directory portion of these output+-- options will have to exist by the time 'verifyOutputFiles'+-- is invoked.+--+-- We create the directories for -odir, -hidir, -outputdir etc. ourselves if+-- they don't exist, so don't check for those here (#2278).+verifyOutputFiles :: DynFlags -> IO ()+verifyOutputFiles dflags = do+ let ofile = outputFile dflags+ when (isJust ofile) $ do+ let fn = fromJust ofile+ flg <- doesDirNameExist fn+ when (not flg) (nonExistentDir "-o" fn)+ let ohi = outputHi dflags+ when (isJust ohi) $ do+ let hi = fromJust ohi+ flg <- doesDirNameExist hi+ when (not flg) (nonExistentDir "-ohi" hi)+ where+ nonExistentDir flg dir =+ throwGhcException (CmdLineError ("error: directory portion of " +++ show dir ++ " does not exist (used with " +++ show flg ++ " option.)"))++-----------------------------------------------------------------------------+-- GHC modes of operation++type Mode = Either PreStartupMode PostStartupMode+type PostStartupMode = Either PreLoadMode PostLoadMode++data PreStartupMode+ = ShowVersion -- ghc -V/--version+ | ShowNumVersion -- ghc --numeric-version+ | ShowSupportedExtensions -- ghc --supported-extensions+ | ShowOptions Bool {- isInteractive -} -- ghc --show-options++showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode+showVersionMode = mkPreStartupMode ShowVersion+showNumVersionMode = mkPreStartupMode ShowNumVersion+showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions+showOptionsMode = mkPreStartupMode (ShowOptions False)++mkPreStartupMode :: PreStartupMode -> Mode+mkPreStartupMode = Left++isShowVersionMode :: Mode -> Bool+isShowVersionMode (Left ShowVersion) = True+isShowVersionMode _ = False++isShowNumVersionMode :: Mode -> Bool+isShowNumVersionMode (Left ShowNumVersion) = True+isShowNumVersionMode _ = False++data PreLoadMode+ = ShowGhcUsage -- ghc -?+ | ShowGhciUsage -- ghci -?+ | ShowInfo -- ghc --info+ | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo++showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode+showGhcUsageMode = mkPreLoadMode ShowGhcUsage+showGhciUsageMode = mkPreLoadMode ShowGhciUsage+showInfoMode = mkPreLoadMode ShowInfo++printSetting :: String -> Mode+printSetting k = mkPreLoadMode (PrintWithDynFlags f)+ where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))+ $ lookup k (compilerInfo dflags)++mkPreLoadMode :: PreLoadMode -> Mode+mkPreLoadMode = Right . Left++isShowGhcUsageMode :: Mode -> Bool+isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True+isShowGhcUsageMode _ = False++isShowGhciUsageMode :: Mode -> Bool+isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True+isShowGhciUsageMode _ = False++data PostLoadMode+ = ShowInterface FilePath -- ghc --show-iface+ | DoMkDependHS -- ghc -M+ | StopBefore Phase -- ghc -E | -C | -S+ -- StopBefore StopLn is the default+ | DoMake -- ghc --make+ | DoBackpack -- ghc --backpack foo.bkp+ | DoInteractive -- ghc --interactive+ | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]+ | DoAbiHash -- ghc --abi-hash+ | ShowPackages -- ghc --show-packages+ | DoFrontend ModuleName -- ghc --frontend Plugin.Module+ | DoVHDL -- ghc --vhdl+ | DoVerilog -- ghc --verilog+ | DoSystemVerilog -- ghc --systemverilog++doMkDependHSMode, doMakeMode, doInteractiveMode,+ doAbiHashMode, showPackagesMode, doVHDLMode, doVerilogMode,+ doSystemVerilogMode :: Mode+doMkDependHSMode = mkPostLoadMode DoMkDependHS+doMakeMode = mkPostLoadMode DoMake+doInteractiveMode = mkPostLoadMode DoInteractive+doAbiHashMode = mkPostLoadMode DoAbiHash+showPackagesMode = mkPostLoadMode ShowPackages+doVHDLMode = mkPostLoadMode DoVHDL+doVerilogMode = mkPostLoadMode DoVerilog+doSystemVerilogMode = mkPostLoadMode DoSystemVerilog++showInterfaceMode :: FilePath -> Mode+showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)++stopBeforeMode :: Phase -> Mode+stopBeforeMode phase = mkPostLoadMode (StopBefore phase)++doEvalMode :: String -> Mode+doEvalMode str = mkPostLoadMode (DoEval [str])++doFrontendMode :: String -> Mode+doFrontendMode str = mkPostLoadMode (DoFrontend (mkModuleName str))++doBackpackMode :: Mode+doBackpackMode = mkPostLoadMode DoBackpack++mkPostLoadMode :: PostLoadMode -> Mode+mkPostLoadMode = Right . Right++isDoInteractiveMode :: Mode -> Bool+isDoInteractiveMode (Right (Right DoInteractive)) = True+isDoInteractiveMode _ = False++isStopLnMode :: Mode -> Bool+isStopLnMode (Right (Right (StopBefore StopLn))) = True+isStopLnMode _ = False++isDoMakeMode :: Mode -> Bool+isDoMakeMode (Right (Right DoMake)) = True+isDoMakeMode _ = False++isDoEvalMode :: Mode -> Bool+isDoEvalMode (Right (Right (DoEval _))) = True+isDoEvalMode _ = False++#if defined(GHCI)+isInteractiveMode :: PostLoadMode -> Bool+isInteractiveMode DoInteractive = True+isInteractiveMode _ = False+#endif++-- isInterpretiveMode: byte-code compiler involved+isInterpretiveMode :: PostLoadMode -> Bool+isInterpretiveMode DoInteractive = True+isInterpretiveMode (DoEval _) = True+isInterpretiveMode _ = False++needsInputsMode :: PostLoadMode -> Bool+needsInputsMode DoMkDependHS = True+needsInputsMode (StopBefore _) = True+needsInputsMode DoMake = True+needsInputsMode DoVHDL = True+needsInputsMode DoVerilog = True+needsInputsMode DoSystemVerilog = True+needsInputsMode _ = False++-- True if we are going to attempt to link in this mode.+-- (we might not actually link, depending on the GhcLink flag)+isLinkMode :: PostLoadMode -> Bool+isLinkMode (StopBefore StopLn) = True+isLinkMode DoMake = True+isLinkMode DoInteractive = True+isLinkMode (DoEval _) = True+isLinkMode _ = False++isCompManagerMode :: PostLoadMode -> Bool+isCompManagerMode DoMake = True+isCompManagerMode DoInteractive = True+isCompManagerMode (DoEval _) = True+isCompManagerMode DoVHDL = True+isCompManagerMode DoVerilog = True+isCompManagerMode DoSystemVerilog = True+isCompManagerMode _ = False++-- -----------------------------------------------------------------------------+-- Parsing the mode flag++parseModeFlags :: [Located String]+ -> IO (Mode,+ [Located String],+ [Warn])+parseModeFlags args = do+ let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =+ runCmdLine (processArgs mode_flags args)+ (Nothing, [], [])+ mode = case mModeFlag of+ Nothing -> doMakeMode+ Just (m, _) -> m++ -- See Note [Handling errors when parsing commandline flags]+ unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $+ map (("on the commandline", )) $ map (unLoc . errMsg) errs1 ++ errs2++ return (mode, flags' ++ leftover, warns)++type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])+ -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)+ -- so we collect the new ones and return them.++mode_flags :: [Flag ModeM]+mode_flags =+ [ ------- help / version ----------------------------------------------+ defFlag "?" (PassFlag (setMode showGhcUsageMode))+ , defFlag "-help" (PassFlag (setMode showGhcUsageMode))+ , defFlag "V" (PassFlag (setMode showVersionMode))+ , defFlag "-version" (PassFlag (setMode showVersionMode))+ , defFlag "-numeric-version" (PassFlag (setMode showNumVersionMode))+ , defFlag "-info" (PassFlag (setMode showInfoMode))+ , defFlag "-show-options" (PassFlag (setMode showOptionsMode))+ , defFlag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))+ , defFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))+ , defFlag "-show-packages" (PassFlag (setMode showPackagesMode))+ ] +++ [ defFlag k' (PassFlag (setMode (printSetting k)))+ | k <- ["Project version",+ "Project Git commit id",+ "Booter version",+ "Stage",+ "Build platform",+ "Host platform",+ "Target platform",+ "Have interpreter",+ "Object splitting supported",+ "Have native code generator",+ "Support SMP",+ "Unregisterised",+ "Tables next to code",+ "RTS ways",+ "Leading underscore",+ "Debug on",+ "LibDir",+ "Global Package DB",+ "C compiler flags",+ "C compiler link flags",+ "ld flags"],+ let k' = "-print-" ++ map (replaceSpace . toLower) k+ replaceSpace ' ' = '-'+ replaceSpace c = c+ ] +++ ------- interfaces ----------------------------------------------------+ [ defFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)+ "--show-iface"))++ ------- primary modes ------------------------------------------------+ , defFlag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f+ addFlag "-no-link" f))+ , defFlag "M" (PassFlag (setMode doMkDependHSMode))+ , defFlag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))+ , defFlag "C" (PassFlag (setMode (stopBeforeMode HCc)))+ , defFlag "S" (PassFlag (setMode (stopBeforeMode (As False))))+ , defFlag "-make" (PassFlag (setMode doMakeMode))+ , defFlag "-backpack" (PassFlag (setMode doBackpackMode))+ , defFlag "-interactive" (PassFlag (setMode doInteractiveMode))+ , defFlag "-abi-hash" (PassFlag (setMode doAbiHashMode))+ , defFlag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))+ , defFlag "-frontend" (SepArg (\s -> setMode (doFrontendMode s) "-frontend"))+ , defFlag "-vhdl" (PassFlag (setMode doVHDLMode))+ , defFlag "-verilog" (PassFlag (setMode doVerilogMode))+ , defFlag "-systemverilog" (PassFlag (setMode doSystemVerilogMode))+ ]++setMode :: Mode -> String -> EwM ModeM ()+setMode newMode newFlag = liftEwM $ do+ (mModeFlag, errs, flags') <- getCmdLineState+ let (modeFlag', errs') =+ case mModeFlag of+ Nothing -> ((newMode, newFlag), errs)+ Just (oldMode, oldFlag) ->+ case (oldMode, newMode) of+ -- -c/--make are allowed together, and mean --make -no-link+ _ | isStopLnMode oldMode && isDoMakeMode newMode+ || isStopLnMode newMode && isDoMakeMode oldMode ->+ ((doMakeMode, "--make"), [])++ -- If we have both --help and --interactive then we+ -- want showGhciUsage+ _ | isShowGhcUsageMode oldMode &&+ isDoInteractiveMode newMode ->+ ((showGhciUsageMode, oldFlag), [])+ | isShowGhcUsageMode newMode &&+ isDoInteractiveMode oldMode ->+ ((showGhciUsageMode, newFlag), [])++ -- If we have both -e and --interactive then -e always wins+ _ | isDoEvalMode oldMode &&+ isDoInteractiveMode newMode ->+ ((oldMode, oldFlag), [])+ | isDoEvalMode newMode &&+ isDoInteractiveMode oldMode ->+ ((newMode, newFlag), [])++ -- Otherwise, --help/--version/--numeric-version always win+ | isDominantFlag oldMode -> ((oldMode, oldFlag), [])+ | isDominantFlag newMode -> ((newMode, newFlag), [])+ -- We need to accumulate eval flags like "-e foo -e bar"+ (Right (Right (DoEval esOld)),+ Right (Right (DoEval [eNew]))) ->+ ((Right (Right (DoEval (eNew : esOld))), oldFlag),+ errs)+ -- Saying e.g. --interactive --interactive is OK+ _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)++ -- --interactive and --show-options are used together+ (Right (Right DoInteractive), Left (ShowOptions _)) ->+ ((Left (ShowOptions True),+ "--interactive --show-options"), errs)+ (Left (ShowOptions _), (Right (Right DoInteractive))) ->+ ((Left (ShowOptions True),+ "--show-options --interactive"), errs)+ -- Otherwise, complain+ _ -> let err = flagMismatchErr oldFlag newFlag+ in ((oldMode, oldFlag), err : errs)+ putCmdLineState (Just modeFlag', errs', flags')+ where isDominantFlag f = isShowGhcUsageMode f ||+ isShowGhciUsageMode f ||+ isShowVersionMode f ||+ isShowNumVersionMode f++flagMismatchErr :: String -> String -> String+flagMismatchErr oldFlag newFlag+ = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'"++addFlag :: String -> String -> EwM ModeM ()+addFlag s flag = liftEwM $ do+ (m, e, flags') <- getCmdLineState+ putCmdLineState (m, e, mkGeneralLocated loc s : flags')+ where loc = "addFlag by " ++ flag ++ " on the commandline"++-- ----------------------------------------------------------------------------+-- Run --make mode++doMake :: [(String,Maybe Phase)] -> Ghc ()+doMake srcs = do+ let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs++ hsc_env <- GHC.getSession++ -- if we have no haskell sources from which to do a dependency+ -- analysis, then just do one-shot compilation and/or linking.+ -- This means that "ghc Foo.o Bar.o -o baz" links the program as+ -- we expect.+ if (null hs_srcs)+ then liftIO (oneShot hsc_env StopLn srcs)+ else do++ o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)+ non_hs_srcs+ dflags <- GHC.getSessionDynFlags+ let dflags' = dflags { ldInputs = map (FileOption "") o_files+ ++ ldInputs dflags }+ _ <- GHC.setSessionDynFlags dflags'++ targets <- mapM (uncurry GHC.guessTarget) hs_srcs+ GHC.setTargets targets+ ok_flag <- GHC.load LoadAllTargets++ when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))+ return ()+++-- ---------------------------------------------------------------------------+-- --show-iface mode++doShowIface :: DynFlags -> FilePath -> IO ()+doShowIface dflags file = do+ hsc_env <- newHscEnv dflags+ showIface hsc_env file++-- ---------------------------------------------------------------------------+-- Various banners and verbosity output.++showBanner :: PostLoadMode -> DynFlags -> IO ()+showBanner _postLoadMode dflags = do+ let verb = verbosity dflags++#if defined(GHCI)+ -- Show the GHCi banner+ when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg+#endif++ -- Display details of the configuration in verbose mode+ when (verb >= 2) $+ do hPutStr stderr "Glasgow Haskell Compiler, Version "+ hPutStr stderr cProjectVersion+ hPutStr stderr ", stage "+ hPutStr stderr cStage+ hPutStr stderr " booted by GHC version "+ hPutStrLn stderr cBooterVersion++-- We print out a Read-friendly string, but a prettier one than the+-- Show instance gives us+showInfo :: DynFlags -> IO ()+showInfo dflags = do+ let sq x = " [" ++ x ++ "\n ]"+ putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags++showSupportedExtensions :: IO ()+showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions++showVersion :: IO ()+showVersion = putStrLn $ concat [ "Clash, version "+ , Data.Version.showVersion Paths_clash_ghc.version+ , " (using clash-lib, version: "+ , Data.Version.showVersion clashLibVersion+ , ")"+ ]++showOptions :: Bool -> IO ()+showOptions isInteractive = putStr (unlines availableOptions)+ where+ availableOptions = concat [+ flagsForCompletion isInteractive,+ map ('-':) (getFlagNames mode_flags)+ ]+ getFlagNames opts = map flagName opts++showGhcUsage :: DynFlags -> IO ()+showGhcUsage = showUsage False++showGhciUsage :: DynFlags -> IO ()+showGhciUsage = showUsage True++showUsage :: Bool -> DynFlags -> IO ()+showUsage ghci dflags = do+ let usage_path = if ghci then ghciUsagePath dflags+ else ghcUsagePath dflags+ usage <- readFile usage_path+ dump usage+ where+ dump "" = return ()+ dump ('$':'$':s) = putStr progName >> dump s+ dump (c:s) = putChar c >> dump s++dumpFinalStats :: DynFlags -> IO ()+dumpFinalStats dflags =+ when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags++dumpFastStringStats :: DynFlags -> IO ()+dumpFastStringStats dflags = do+ buckets <- getFastStringTable+ let (entries, longest, has_z) = countFS 0 0 0 buckets+ msg = text "FastString stats:" $$+ nest 4 (vcat [text "size: " <+> int (length buckets),+ text "entries: " <+> int entries,+ text "longest chain: " <+> int longest,+ text "has z-encoding: " <+> (has_z `pcntOf` entries)+ ])+ -- we usually get more "has z-encoding" than "z-encoded", because+ -- when we z-encode a string it might hash to the exact same string,+ -- which is not counted as "z-encoded". Only strings whose+ -- Z-encoding is different from the original string are counted in+ -- the "z-encoded" total.+ putMsg dflags msg+ where+ x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%'++countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int)+countFS entries longest has_z [] = (entries, longest, has_z)+countFS entries longest has_z (b:bs) =+ let+ len = length b+ longest' = max len longest+ entries' = entries + len+ has_zs = length (filter hasZEncoding b)+ in+ countFS entries' longest' (has_z + has_zs) bs++showPackages, dumpPackages, dumpPackagesSimple :: DynFlags -> IO ()+showPackages dflags = putStrLn (showSDoc dflags (pprPackages dflags))+dumpPackages dflags = putMsg dflags (pprPackages dflags)+dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple dflags)++-- -----------------------------------------------------------------------------+-- Frontend plugin support++doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()+#if !defined(GHCI)+doFrontend modname _ = pluginError [modname]+#else+doFrontend modname srcs = do+ hsc_env <- getSession+ frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname+ frontend frontend_plugin+ (reverse $ frontendPluginOpts (hsc_dflags hsc_env)) srcs+#endif++-- -----------------------------------------------------------------------------+-- ABI hash support++{-+ ghc --abi-hash Data.Foo System.Bar++Generates a combined hash of the ABI for modules Data.Foo and+System.Bar. The modules must already be compiled, and appropriate -i+options may be necessary in order to find the .hi files.++This is used by Cabal for generating the ComponentId for a+package. The ComponentId must change when the visible ABI of+the package chagnes, so during registration Cabal calls ghc --abi-hash+to get a hash of the package's ABI.+-}++-- | Print ABI hash of input modules.+--+-- The resulting hash is the MD5 of the GHC version used (Trac #5328,+-- see 'hiVersion') and of the existing ABI hash from each module (see+-- 'mi_mod_hash').+abiHash :: [String] -- ^ List of module names+ -> Ghc ()+abiHash strs = do+ hsc_env <- getSession+ let dflags = hsc_dflags hsc_env++ liftIO $ do++ let find_it str = do+ let modname = mkModuleName str+ r <- findImportedModule hsc_env modname Nothing+ case r of+ Found _ m -> return m+ _error -> throwGhcException $ CmdLineError $ showSDoc dflags $+ cannotFindModule dflags modname r++ mods <- mapM find_it strs++ let get_iface modl = loadUserInterface False (text "abiHash") modl+ ifaces <- initIfaceCheck (text "abiHash") hsc_env $ mapM get_iface mods++ bh <- openBinMem (3*1024) -- just less than a block+ put_ bh hiVersion+ -- package hashes change when the compiler version changes (for now)+ -- see #5328+ mapM_ (put_ bh . mi_mod_hash) ifaces+ f <- fingerprintBinMem bh++ putStrLn (showPpr dflags f)++-----------------------------------------------------------------------------+-- HDL Generation++makeHDL' :: Clash.Backend.Backend backend => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)+ -> IORef ClashOpts -> [(String,Maybe Phase)] -> Ghc ()+makeHDL' _ _ [] = throwGhcException (CmdLineError "No input files")+makeHDL' backend r srcs = makeHDL backend r $ fmap fst srcs++makeVHDL :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VHDLState)++makeVerilog :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VerilogState)++makeSystemVerilog :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> SystemVerilogState)++-- -----------------------------------------------------------------------------+-- Util++unknownFlagsErr :: [String] -> a+unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs+ where+ oneError f =+ "unrecognised flag: " ++ f ++ "\n" +++ (case match f (nubSort allNonDeprecatedFlags) of+ [] -> ""+ suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs))+ -- fixes #11789+ -- If the flag contains '=',+ -- this uses both the whole and the left side of '=' for comparing.+ match f allFlags+ | elem '=' f =+ let (flagsWithEq, flagsWithoutEq) = partition (elem '=') allFlags+ fName = takeWhile (/= '=') f+ in (fuzzyMatch f flagsWithEq) ++ (fuzzyMatch fName flagsWithoutEq)+ | otherwise = fuzzyMatch f allFlags++{- Note [-Bsymbolic and hooks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-Bsymbolic is a flag that prevents the binding of references to global+symbols to symbols outside the shared library being compiled (see `man+ld`). When dynamically linking, we don't use -Bsymbolic on the RTS+package: that is because we want hooks to be overridden by the user,+we don't want to constrain them to the RTS package.++Unfortunately this seems to have broken somehow on OS X: as a result,+defaultHooks (in hschooks.c) is not called, which does not initialize+the GC stats. As a result, this breaks things like `:set +s` in GHCi+(#8754). As a hacky workaround, we instead call 'defaultHooks'+directly to initalize the flags in the RTS.++A byproduct of this, I believe, is that hooks are likely broken on OS+X when dynamically linking. But this probably doesn't affect most+people since we're linking GHC dynamically, but most things themselves+link statically.+-}++foreign import ccall safe "initGCStatistics"+ initGCStatistics :: IO ()
+ src-bin-881/Clash/GHCi/Leak.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE RecordWildCards, LambdaCase #-}+module Clash.GHCi.Leak+ ( LeakIndicators+ , getLeakIndicators+ , checkLeakIndicators+ ) where++import Control.Monad+import Data.Bits+import DynFlags ( sTargetPlatform )+import Foreign.Ptr (ptrToIntPtr, intPtrToPtr)+import GHC+import GHC.Ptr (Ptr (..))+import Clash.GHCi.Util+import HscTypes+import Outputable+import Platform (target32Bit)+import Prelude+import System.Mem+import System.Mem.Weak+import UniqDFM++-- Checking for space leaks in GHCi. See #15111, and the+-- -fghci-leak-check flag.++data LeakIndicators = LeakIndicators [LeakModIndicators]++data LeakModIndicators = LeakModIndicators+ { leakMod :: Weak HomeModInfo+ , leakIface :: Weak ModIface+ , leakDetails :: Weak ModDetails+ , leakLinkable :: Maybe (Weak Linkable)+ }++-- | Grab weak references to some of the data structures representing+-- the currently loaded modules.+getLeakIndicators :: HscEnv -> IO LeakIndicators+getLeakIndicators HscEnv{..} =+ fmap LeakIndicators $+ forM (eltsUDFM hsc_HPT) $ \hmi@HomeModInfo{..} -> do+ leakMod <- mkWeakPtr hmi Nothing+ leakIface <- mkWeakPtr hm_iface Nothing+ leakDetails <- mkWeakPtr hm_details Nothing+ leakLinkable <- mapM (`mkWeakPtr` Nothing) hm_linkable+ return $ LeakModIndicators{..}++-- | Look at the LeakIndicators collected by an earlier call to+-- `getLeakIndicators`, and print messasges if any of them are still+-- alive.+checkLeakIndicators :: DynFlags -> LeakIndicators -> IO ()+checkLeakIndicators dflags (LeakIndicators leakmods) = do+ performGC+ forM_ leakmods $ \LeakModIndicators{..} -> do+ deRefWeak leakMod >>= \case+ Nothing -> return ()+ Just hmi ->+ report ("HomeModInfo for " +++ showSDoc dflags (ppr (mi_module (hm_iface hmi)))) (Just hmi)+ deRefWeak leakIface >>= report "ModIface"+ deRefWeak leakDetails >>= report "ModDetails"+ forM_ leakLinkable $ \l -> deRefWeak l >>= report "Linkable"+ where+ report :: String -> Maybe a -> IO ()+ report _ Nothing = return ()+ report msg (Just a) = do+ addr <- anyToPtr a+ putStrLn ("-fghci-leak-check: " ++ msg ++ " is still alive at " +++ show (maskTagBits addr))++ tagBits+ | target32Bit (sTargetPlatform (settings dflags)) = 2+ | otherwise = 3++ maskTagBits :: Ptr a -> Ptr a+ maskTagBits p = intPtrToPtr (ptrToIntPtr p .&. complement (shiftL 1 tagBits - 1))
+ src-bin-881/Clash/GHCi/UI.hs view
@@ -0,0 +1,4104 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS -fno-cse #-}+-- -fno-cse is needed for GLOBAL_VAR's to behave properly++-----------------------------------------------------------------------------+--+-- GHC Interactive User Interface+--+-- (c) The GHC Team 2005-2006+--+-----------------------------------------------------------------------------++module Clash.GHCi.UI (+ interactiveUI,+ GhciSettings(..),+ defaultGhciSettings,+ ghciCommands,+ ghciWelcomeMsg,+ makeHDL+ ) where++#include "HsVersions.h"++-- GHCi+import qualified Clash.GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls' )+import Clash.GHCi.UI.Monad hiding ( args, runStmt )+import Clash.GHCi.UI.Tags+import Clash.GHCi.UI.Info+import Debugger++-- The GHC interface+import GHCi+import GHCi.RemoteTypes+import GHCi.BreakArray+import DynFlags+import ErrUtils hiding (traceCmd)+import Finder+import GhcMonad ( modifySession )+import qualified GHC+import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..),+ TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,+ GetDocsFailure(..),+ getModuleGraph, handleSourceError )+import HscMain (hscParseDeclsWithLocation, hscParseStmtWithLocation)+import HsImpExp+import HsSyn+import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,+ setInteractivePrintName, hsc_dflags, msObjFilePath, runInteractiveHsc )+import Module+import Name+import Packages ( trusted, getPackageDetails, getInstalledPackageDetails,+ listVisibleModuleNames, pprFlag )+import IfaceSyn ( showToHeader )+import PprTyThing+import PrelNames+import RdrName ( getGRE_NameQualifier_maybes, getRdrName )+import SrcLoc+import qualified Lexer++import StringBuffer+import Outputable hiding ( printForUser, printForUserPartWay )++import DynamicLoading ( initializePlugins )++-- Other random utilities+import BasicTypes hiding ( isTopLevel )+import Digraph+import Encoding+import FastString+import Linker+import Maybes ( orElse, expectJust )+import NameSet+import Panic hiding ( showException )+import Util+import qualified GHC.LanguageExtensions as LangExt+import Bag (unitBag)++-- Haskell Libraries+import System.Console.Haskeline as Haskeline++import Control.Applicative hiding (empty)+import Control.DeepSeq (deepseq)+import Control.Monad as Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except++import Data.Array+import qualified Data.ByteString.Char8 as BS+import Data.Char+import Data.Function+import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )+import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,+ partition, sort, sortBy )+import qualified Data.Set as S+import Data.Maybe+import Data.Map (Map)+import qualified Data.Map as M+import Data.Time.LocalTime ( getZonedTime )+import Data.Time.Format ( formatTime, defaultTimeLocale )+import Data.Version ( showVersion )+import Prelude hiding ((<>))++import Exception hiding (catch)+import Foreign hiding (void)+import GHC.Stack hiding (SrcLoc(..))++import System.Directory+import System.Environment+import System.Exit ( exitWith, ExitCode(..) )+import System.FilePath+import System.Info+import System.IO+import System.IO.Error+import System.IO.Unsafe ( unsafePerformIO )+import System.Process+import Text.Printf+import Text.Read ( readMaybe )+import Text.Read.Lex (isSymbolChar)++import Unsafe.Coerce++#if !defined(mingw32_HOST_OS)+import System.Posix hiding ( getEnv )+#else+import qualified System.Win32+#endif++import GHC.IO.Exception ( IOErrorType(InvalidArgument) )+import GHC.IO.Handle ( hFlushAll )+import GHC.TopHandler ( topHandler )++import Clash.GHCi.Leak++-- clash additions+import qualified Clash.Backend+import Clash.Backend.SystemVerilog (SystemVerilogState)+import Clash.Backend.VHDL (VHDLState)+import Clash.Backend.Verilog (VerilogState)+import qualified Clash.Driver+import Clash.Driver.Types (ClashOpts(..))+import Clash.GHC.Evaluator+import Clash.GHC.GenerateBindings+import Clash.GHC.NetlistTypes+import Clash.GHCi.Common+import Clash.Netlist.BlackBox.Types (HdlSyn)+import Clash.Util (clashLibVersion, reportTimeDiff)+import qualified Data.Time.Clock as Clock+import qualified Paths_clash_ghc++import Clash.Annotations.BitRepresentation.Internal (buildCustomReprs)++-----------------------------------------------------------------------------++data GhciSettings = GhciSettings {+ availableCommands :: [Command],+ shortHelpText :: String,+ fullHelpText :: String,+ defPrompt :: PromptFunction,+ defPromptCont :: PromptFunction+ }++defaultGhciSettings :: IORef ClashOpts -> GhciSettings+defaultGhciSettings opts =+ GhciSettings {+ availableCommands = ghciCommands opts,+ shortHelpText = defShortHelpText,+ defPrompt = default_prompt,+ defPromptCont = default_prompt_cont,+ fullHelpText = defFullHelpText+ }++ghciWelcomeMsg :: String+ghciWelcomeMsg = "Clashi, version " ++ Data.Version.showVersion Paths_clash_ghc.version +++ " (using clash-lib, version " ++ Data.Version.showVersion clashLibVersion +++ "):\nhttp://www.clash-lang.org/ :? for help"++ghciCommands :: IORef ClashOpts -> [Command]+ghciCommands opts = map mkCmd [+ -- Hugs users are accustomed to :e, so make sure it doesn't overlap+ ("?", keepGoing help, noCompletion),+ ("add", keepGoingPaths addModule, completeFilename),+ ("abandon", keepGoing abandonCmd, noCompletion),+ ("break", keepGoing breakCmd, completeIdentifier),+ ("back", keepGoing backCmd, noCompletion),+ ("browse", keepGoing' (browseCmd False), completeModule),+ ("browse!", keepGoing' (browseCmd True), completeModule),+ ("cd", keepGoing' changeDirectory, completeFilename),+ ("check", keepGoing' checkModule, completeHomeModule),+ ("continue", keepGoing continueCmd, noCompletion),+ ("cmd", keepGoing cmdCmd, completeExpression),+ ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename),+ ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename),+ ("def", keepGoing (defineMacro False), completeExpression),+ ("def!", keepGoing (defineMacro True), completeExpression),+ ("delete", keepGoing deleteCmd, noCompletion),+ ("doc", keepGoing' docCmd, completeIdentifier),+ ("edit", keepGoing' editFile, completeFilename),+ ("etags", keepGoing createETagsFileCmd, completeFilename),+ ("force", keepGoing forceCmd, completeExpression),+ ("forward", keepGoing forwardCmd, noCompletion),+ ("help", keepGoing help, noCompletion),+ ("history", keepGoing historyCmd, noCompletion),+ ("info", keepGoing' (info False), completeIdentifier),+ ("info!", keepGoing' (info True), completeIdentifier),+ ("issafe", keepGoing' isSafeCmd, completeModule),+ ("kind", keepGoing' (kindOfType False), completeIdentifier),+ ("kind!", keepGoing' (kindOfType True), completeIdentifier),+ ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),+ ("load!", keepGoingPaths loadModuleDefer, completeHomeModuleOrFile),+ ("list", keepGoing' listCmd, noCompletion),+ ("module", keepGoing moduleCmd, completeSetModule),+ ("main", keepGoing runMain, completeFilename),+ ("print", keepGoing printCmd, completeExpression),+ ("quit", quit, noCompletion),+ ("reload", keepGoing' reloadModule, noCompletion),+ ("reload!", keepGoing' reloadModuleDefer, noCompletion),+ ("run", keepGoing runRun, completeFilename),+ ("script", keepGoing' scriptCmd, completeFilename),+ ("set", keepGoing setCmd, completeSetOptions),+ ("seti", keepGoing setiCmd, completeSeti),+ ("show", keepGoing showCmd, completeShowOptions),+ ("showi", keepGoing showiCmd, completeShowiOptions),+ ("sprint", keepGoing sprintCmd, completeExpression),+ ("step", keepGoing stepCmd, completeIdentifier),+ ("steplocal", keepGoing stepLocalCmd, completeIdentifier),+ ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),+ ("type", keepGoing' typeOfExpr, completeExpression),+ ("trace", keepGoing traceCmd, completeExpression),+ ("unadd", keepGoingPaths unAddModule, completeFilename),+ ("undef", keepGoing undefineMacro, completeMacro),+ ("unset", keepGoing unsetOptions, completeSetOptions),+ ("where", keepGoing whereCmd, noCompletion),+ ("vhdl", keepGoingPaths (makeVHDL opts), completeHomeModuleOrFile),+ ("verilog", keepGoingPaths (makeVerilog opts), completeHomeModuleOrFile),+ ("systemverilog", keepGoingPaths (makeSystemVerilog opts), completeHomeModuleOrFile)+ ] ++ map mkCmdHidden [ -- hidden commands+ ("all-types", keepGoing' allTypesCmd),+ ("complete", keepGoing completeCmd),+ ("loc-at", keepGoing' locAtCmd),+ ("type-at", keepGoing' typeAtCmd),+ ("uses", keepGoing' usesCmd)+ ]+ where+ mkCmd (n,a,c) = Command { cmdName = n+ , cmdAction = a+ , cmdHidden = False+ , cmdCompletionFunc = c+ }++ mkCmdHidden (n,a) = Command { cmdName = n+ , cmdAction = a+ , cmdHidden = True+ , cmdCompletionFunc = noCompletion+ }++-- We initialize readline (in the interactiveUI function) to use+-- word_break_chars as the default set of completion word break characters.+-- This can be overridden for a particular command (for example, filename+-- expansion shouldn't consider '/' to be a word break) by setting the third+-- entry in the Command tuple above.+--+-- NOTE: in order for us to override the default correctly, any custom entry+-- must be a SUBSET of word_break_chars.+word_break_chars :: String+word_break_chars = spaces ++ specials ++ symbols++symbols, specials, spaces :: String+symbols = "!#$%&*+/<=>?@\\^|-~"+specials = "(),;[]`{}"+spaces = " \t\n"++flagWordBreakChars :: String+flagWordBreakChars = " \t\n"+++keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)+keepGoing a str = keepGoing' (lift . a) str++keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool+keepGoing' a str = a str >> return False++keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)+keepGoingPaths a str+ = do case toArgs str of+ Left err -> liftIO $ hPutStrLn stderr err+ Right args -> a args+ return False++defShortHelpText :: String+defShortHelpText = "use :? for help.\n"++defFullHelpText :: String+defFullHelpText =+ " Commands available from the prompt:\n" +++ "\n" +++ " <statement> evaluate/run <statement>\n" +++ " : repeat last command\n" +++ " :{\\n ..lines.. \\n:}\\n multiline command\n" +++ " :add [*]<module> ... add module(s) to the current target set\n" +++ " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" +++ " (!: more details; *: all top-level names)\n" +++ " :cd <dir> change directory to <dir>\n" +++ " :cmd <expr> run the commands returned by <expr>::IO String\n" +++ " :complete <dom> [<rng>] <s> list completions for partial input string\n" +++ " :ctags[!] [<file>] create tags file <file> for Vi (default: \"tags\")\n" +++ " (!: use regex instead of line number)\n" +++ " :def <cmd> <expr> define command :<cmd> (later defined command has\n" +++ " precedence, ::<cmd> is always a builtin command)\n" +++ " :doc <name> display docs for the given name (experimental)\n" +++ " :edit <file> edit file\n" +++ " :edit edit last module\n" +++ " :etags [<file>] create tags file <file> for Emacs (default: \"TAGS\")\n" +++ " :help, :? display this list of commands\n" +++ " :info[!] [<name> ...] display information about the given names\n" +++ " (!: do not filter instances)\n" +++ " :issafe [<mod>] display safe haskell information of module <mod>\n" +++ " :kind[!] <type> show the kind of <type>\n" +++ " (!: also print the normalised type)\n" +++ " :load[!] [*]<module> ... load module(s) and their dependents\n" +++ " (!: defer type errors)\n" +++ " :main [<arguments> ...] run the main function with the given arguments\n" +++ " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" +++ " :quit exit GHCi\n" +++ " :reload[!] reload the current module set\n" +++ " (!: defer type errors)\n" +++ " :run function [<arguments> ...] run the function with the given arguments\n" +++ " :script <file> run the script <file>\n" +++ " :type <expr> show the type of <expr>\n" +++ " :type +d <expr> show the type of <expr>, defaulting type variables\n" +++ " :type +v <expr> show the type of <expr>, with its specified tyvars\n" +++ " :unadd <module> ... remove module(s) from the current target set\n" +++ " :undef <cmd> undefine user-defined command :<cmd>\n" +++ " :!<command> run the shell command <command>\n" +++ " :vhdl synthesize currently loaded module to vhdl\n" +++ " :vhdl [<module>] synthesize specified modules/files to vhdl\n" +++ " :verilog synthesize currently loaded module to verilog\n" +++ " :verilog [<module>] synthesize specified modules/files to verilog\n" +++ " :systemverilog synthesize currently loaded module to systemverilog\n" +++ " :systemverilog [<module>] synthesize specified modules/files to systemverilog\n" +++ "\n" +++ " -- Commands for debugging:\n" +++ "\n" +++ " :abandon at a breakpoint, abandon current computation\n" +++ " :back [<n>] go back in the history N steps (after :trace)\n" +++ " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" +++ " :break <name> set a breakpoint on the specified function\n" +++ " :continue resume after a breakpoint\n" +++ " :delete <number> delete the specified breakpoint\n" +++ " :delete * delete all breakpoints\n" +++ " :force <expr> print <expr>, forcing unevaluated parts\n" +++ " :forward [<n>] go forward in the history N step s(after :back)\n" +++ " :history [<n>] after :trace, show the execution history\n" +++ " :list show the source code around current breakpoint\n" +++ " :list <identifier> show the source code for <identifier>\n" +++ " :list [<module>] <line> show the source code around line number <line>\n" +++ " :print [<name> ...] show a value without forcing its computation\n" +++ " :sprint [<name> ...] simplified version of :print\n" +++ " :step single-step after stopping at a breakpoint\n"+++ " :step <expr> single-step into <expr>\n"+++ " :steplocal single-step within the current top-level binding\n"+++ " :stepmodule single-step restricted to the current module\n"+++ " :trace trace after stopping at a breakpoint\n"+++ " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++++ "\n" +++ " -- Commands for changing settings:\n" +++ "\n" +++ " :set <option> ... set options\n" +++ " :seti <option> ... set options for interactive evaluation only\n" +++ " :set args <arg> ... set the arguments returned by System.getArgs\n" +++ " :set prog <progname> set the value returned by System.getProgName\n" +++ " :set prompt <prompt> set the prompt used in GHCi\n" +++ " :set prompt-cont <prompt> set the continuation prompt used in GHCi\n" +++ " :set prompt-function <expr> set the function to handle the prompt\n" +++ " :set prompt-cont-function <expr>" +++ "set the function to handle the continuation prompt\n" +++ " :set editor <cmd> set the command used for :edit\n" +++ " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" +++ " :unset <option> ... unset options\n" +++ "\n" +++ " Options for ':set' and ':unset':\n" +++ "\n" +++ " +m allow multiline commands\n" +++ " +r revert top-level expressions after each evaluation\n" +++ " +s print timing/memory stats after each evaluation\n" +++ " +t print type after evaluation\n" +++ " +c collect type/location info after loading modules\n" +++ " -<flags> most GHC command line flags can also be set here\n" +++ " (eg. -v2, -XFlexibleInstances, etc.)\n" +++ " for GHCi-specific flags, see User's Guide,\n"+++ " Flag reference, Interactive-mode options\n" +++ "\n" +++ " -- Commands for displaying information:\n" +++ "\n" +++ " :show bindings show the current bindings made at the prompt\n" +++ " :show breaks show the active breakpoints\n" +++ " :show context show the breakpoint context\n" +++ " :show imports show the current imports\n" +++ " :show linker show current linker state\n" +++ " :show modules show the currently loaded modules\n" +++ " :show packages show the currently active package flags\n" +++ " :show paths show the currently active search paths\n" +++ " :show language show the currently active language flags\n" +++ " :show targets show the current set of targets\n" +++ " :show <setting> show value of <setting>, which is one of\n" +++ " [args, prog, editor, stop]\n" +++ " :showi language show language flags for interactive evaluation\n" +++ "\n"++findEditor :: IO String+findEditor = do+ getEnv "EDITOR"+ `catchIO` \_ -> do+#if defined(mingw32_HOST_OS)+ win <- System.Win32.getWindowsDirectory+ return (win </> "notepad.exe")+#else+ return ""+#endif++default_progname, default_stop :: String+default_progname = "<interactive>"+default_stop = ""++default_prompt, default_prompt_cont :: PromptFunction+default_prompt = generatePromptFunctionFromString "%s> "+default_prompt_cont = generatePromptFunctionFromString "%s| "++default_args :: [String]+default_args = []++interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]+ -> Ghc ()+interactiveUI config srcs maybe_exprs = do+ -- HACK! If we happen to get into an infinite loop (eg the user+ -- types 'let x=x in x' at the prompt), then the thread will block+ -- on a blackhole, and become unreachable during GC. The GC will+ -- detect that it is unreachable and send it the NonTermination+ -- exception. However, since the thread is unreachable, everything+ -- it refers to might be finalized, including the standard Handles.+ -- This sounds like a bug, but we don't have a good solution right+ -- now.+ _ <- liftIO $ newStablePtr stdin+ _ <- liftIO $ newStablePtr stdout+ _ <- liftIO $ newStablePtr stderr++ -- Initialise buffering for the *interpreted* I/O system+ (nobuffering, flush) <- initInterpBuffering++ -- The initial set of DynFlags used for interactive evaluation is the same+ -- as the global DynFlags, plus -XExtendedDefaultRules and+ -- -XNoMonomorphismRestriction.+ -- See note [Changing language extensions for interactive evaluation] #10857+ dflags <- getDynFlags+ let dflags' = (xopt_set_unlessExplSpec+ LangExt.ExtendedDefaultRules xopt_set)+ . (xopt_set_unlessExplSpec+ LangExt.MonomorphismRestriction xopt_unset)+ $ dflags+ GHC.setInteractiveDynFlags dflags'++ lastErrLocationsRef <- liftIO $ newIORef []+ progDynFlags <- GHC.getProgramDynFlags+ _ <- GHC.setProgramDynFlags $+ -- Ensure we don't override the user's log action lest we break+ -- -ddump-json (#14078)+ progDynFlags { log_action = ghciLogAction (log_action progDynFlags)+ lastErrLocationsRef }++ when (isNothing maybe_exprs) $ do+ -- Only for GHCi (not runghc and ghc -e):++ -- Turn buffering off for the compiled program's stdout/stderr+ turnOffBuffering_ nobuffering+ -- Turn buffering off for GHCi's stdout+ liftIO $ hFlush stdout+ liftIO $ hSetBuffering stdout NoBuffering+ -- We don't want the cmd line to buffer any input that might be+ -- intended for the program, so unbuffer stdin.+ liftIO $ hSetBuffering stdin NoBuffering+ liftIO $ hSetBuffering stderr NoBuffering+#if defined(mingw32_HOST_OS)+ -- On Unix, stdin will use the locale encoding. The IO library+ -- doesn't do this on Windows (yet), so for now we use UTF-8,+ -- for consistency with GHC 6.10 and to make the tests work.+ liftIO $ hSetEncoding stdin utf8+#endif++ default_editor <- liftIO $ findEditor+ eval_wrapper <- mkEvalWrapper default_progname default_args+ let prelude_import = simpleImportDecl preludeModuleName+ startGHCi (runGHCi srcs maybe_exprs)+ GHCiState{ progname = default_progname,+ args = default_args,+ evalWrapper = eval_wrapper,+ prompt = defPrompt config,+ prompt_cont = defPromptCont config,+ stop = default_stop,+ editor = default_editor,+ options = [],+ -- We initialize line number as 0, not 1, because we use+ -- current line number while reporting errors which is+ -- incremented after reading a line.+ line_number = 0,+ break_ctr = 0,+ breaks = [],+ tickarrays = emptyModuleEnv,+ ghci_commands = availableCommands config,+ ghci_macros = [],+ last_command = Nothing,+ cmd_wrapper = (cmdSuccess =<<),+ cmdqueue = [],+ remembered_ctx = [],+ transient_ctx = [],+ extra_imports = [],+ prelude_imports = [prelude_import],+ ghc_e = isJust maybe_exprs,+ short_help = shortHelpText config,+ long_help = fullHelpText config,+ lastErrorLocations = lastErrLocationsRef,+ mod_infos = M.empty,+ flushStdHandles = flush,+ noBuffering = nobuffering+ }++ return ()++{-+Note [Changing language extensions for interactive evaluation]+--------------------------------------------------------------+GHCi maintains two sets of options:++- The "loading options" apply when loading modules+- The "interactive options" apply when evaluating expressions and commands+ typed at the GHCi prompt.++The loading options are mostly created in ghc/Main.hs:main' from the command+line flags. In the function ghc/GHCi/UI.hs:interactiveUI the loading options+are copied to the interactive options.++These interactive options (but not the loading options!) are supplemented+unconditionally by setting ExtendedDefaultRules ON and+MonomorphismRestriction OFF. The unconditional setting of these options+eventually overwrite settings already specified at the command line.++Therefore instead of unconditionally setting ExtendedDefaultRules and+NoMonomorphismRestriction for the interactive options, we use the function+'xopt_set_unlessExplSpec' to first check whether the extension has already+specified at the command line.++The ghci config file has not yet been processed.+-}++resetLastErrorLocations :: GHCi ()+resetLastErrorLocations = do+ st <- getGHCiState+ liftIO $ writeIORef (lastErrorLocations st) []++ghciLogAction :: LogAction -> IORef [(FastString, Int)] -> LogAction+ghciLogAction old_log_action lastErrLocations+ dflags flag severity srcSpan style msg = do+ old_log_action dflags flag severity srcSpan style msg+ case severity of+ SevError -> case srcSpan of+ RealSrcSpan rsp -> modifyIORef lastErrLocations+ (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])+ _ -> return ()+ _ -> return ()++withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a+withGhcAppData right left = do+ either_dir <- tryIO (getAppUserDataDirectory "clash")+ case either_dir of+ Right dir ->+ do createDirectoryIfMissing False dir `catchIO` \_ -> return ()+ right dir+ _ -> left++runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()+runGHCi paths maybe_exprs = do+ dflags <- getDynFlags+ let+ ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags++ current_dir = return (Just ".clashi")++ app_user_dir = liftIO $ withGhcAppData+ (\dir -> return (Just (dir </> "clashi.conf")))+ (return Nothing)++ home_dir = do+ either_dir <- liftIO $ tryIO (getEnv "HOME")+ case either_dir of+ Right home -> return (Just (home </> ".clashi"))+ _ -> return Nothing++ canonicalizePath' :: FilePath -> IO (Maybe FilePath)+ canonicalizePath' fp = liftM Just (canonicalizePath fp)+ `catchIO` \_ -> return Nothing++ sourceConfigFile :: FilePath -> GHCi ()+ sourceConfigFile file = do+ exists <- liftIO $ doesFileExist file+ when exists $ do+ either_hdl <- liftIO $ tryIO (openFile file ReadMode)+ case either_hdl of+ Left _e -> return ()+ -- NOTE: this assumes that runInputT won't affect the terminal;+ -- can we assume this will always be the case?+ -- This would be a good place for runFileInputT.+ Right hdl ->+ do runInputTWithPrefs defaultPrefs defaultSettings $+ runCommands $ fileLoop hdl+ liftIO (hClose hdl `catchIO` \_ -> return ())+ -- Don't print a message if this is really ghc -e (#11478).+ -- Also, let the user silence the message with -v0+ -- (the default verbosity in GHCi is 1).+ when (isNothing maybe_exprs && verbosity dflags > 0) $+ liftIO $ putStrLn ("Loaded Clashi configuration from " ++ file)++ --++ setGHCContextFromGHCiState++ dot_cfgs <- if ignore_dot_ghci then return [] else do+ dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]+ liftIO $ filterM checkFileAndDirPerms dot_files+ mdot_cfgs <- liftIO $ mapM canonicalizePath' dot_cfgs++ let arg_cfgs = reverse $ ghciScripts dflags+ -- -ghci-script are collected in reverse order+ -- We don't require that a script explicitly added by -ghci-script+ -- is owned by the current user. (#6017)+ mapM_ sourceConfigFile $ nub $ (catMaybes mdot_cfgs) ++ arg_cfgs+ -- nub, because we don't want to read .ghci twice if the CWD is $HOME.++ -- Perform a :load for files given on the GHCi command line+ -- When in -e mode, if the load fails then we want to stop+ -- immediately rather than going on to evaluate the expression.+ when (not (null paths)) $ do+ ok <- ghciHandle (\e -> do showException e; return Failed) $+ -- TODO: this is a hack.+ runInputTWithPrefs defaultPrefs defaultSettings $+ loadModule paths+ when (isJust maybe_exprs && failed ok) $+ liftIO (exitWith (ExitFailure 1))++ installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)++ -- if verbosity is greater than 0, or we are connected to a+ -- terminal, display the prompt in the interactive loop.+ is_tty <- liftIO (hIsTerminalDevice stdin)+ let show_prompt = verbosity dflags > 0 || is_tty++ -- reset line number+ modifyGHCiState $ \st -> st{line_number=0}++ case maybe_exprs of+ Nothing ->+ do+ -- enter the interactive loop+ runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty+ Just exprs -> do+ -- just evaluate the expression we were given+ enqueueCommands exprs+ let hdle e = do st <- getGHCiState+ -- flush the interpreter's stdout/stderr on exit (#3890)+ flushInterpBuffers+ -- Jump through some hoops to get the+ -- current progname in the exception text:+ -- <progname>: <exception>+ liftIO $ withProgName (progname st)+ $ topHandler e+ -- this used to be topHandlerFastExit, see #2228+ runInputTWithPrefs defaultPrefs defaultSettings $ do+ -- make `ghc -e` exit nonzero on invalid input, see Trac #7962+ _ <- runCommands' hdle+ (Just $ hdle (toException $ ExitFailure 1) >> return ())+ (return Nothing)+ return ()++ -- and finally, exit+ liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving Clashi."++runGHCiInput :: InputT GHCi a -> GHCi a+runGHCiInput f = do+ dflags <- getDynFlags+ let ghciHistory = gopt Opt_GhciHistory dflags+ let localGhciHistory = gopt Opt_LocalGhciHistory dflags+ currentDirectory <- liftIO $ getCurrentDirectory++ histFile <- case (ghciHistory, localGhciHistory) of+ (True, True) -> return (Just (currentDirectory </> ".clashi_history"))+ (True, _) -> liftIO $ withGhcAppData+ (\dir -> return (Just (dir </> "clashi_history"))) (return Nothing)+ _ -> return Nothing++ runInputT+ (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})+ f++-- | How to get the next input line from the user+nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)+nextInputLine show_prompt is_tty+ | is_tty = do+ prmpt <- if show_prompt then lift mkPrompt else return ""+ r <- getInputLine prmpt+ incrementLineNo+ return r+ | otherwise = do+ when show_prompt $ lift mkPrompt >>= liftIO . putStr+ fileLoop stdin++-- NOTE: We only read .ghci files if they are owned by the current user,+-- and aren't world writable (files owned by root are ok, see #9324).+-- Otherwise, we could be accidentally running code planted by+-- a malicious third party.++-- Furthermore, We only read ./.ghci if . is owned by the current user+-- and isn't writable by anyone else. I think this is sufficient: we+-- don't need to check .. and ../.. etc. because "." always refers to+-- the same directory while a process is running.++checkFileAndDirPerms :: FilePath -> IO Bool+checkFileAndDirPerms file = do+ file_ok <- checkPerms file+ -- Do not check dir perms when .ghci doesn't exist, otherwise GHCi will+ -- print some confusing and useless warnings in some cases (e.g. in+ -- travis). Note that we can't add a test for this, as all ghci tests should+ -- run with -ignore-dot-ghci, which means we never get here.+ if file_ok then checkPerms (getDirectory file) else return False+ where+ getDirectory f = case takeDirectory f of+ "" -> "."+ d -> d++checkPerms :: FilePath -> IO Bool+#if defined(mingw32_HOST_OS)+checkPerms _ = return True+#else+checkPerms file =+ handleIO (\_ -> return False) $ do+ st <- getFileStatus file+ me <- getRealUserID+ let mode = System.Posix.fileMode st+ ok = (fileOwner st == me || fileOwner st == 0) &&+ groupWriteMode /= mode `intersectFileModes` groupWriteMode &&+ otherWriteMode /= mode `intersectFileModes` otherWriteMode+ unless ok $+ -- #8248: Improving warning to include a possible fix.+ putStrLn $ "*** WARNING: " ++ file +++ " is writable by someone else, IGNORING!" +++ "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"+ return ok+#endif++incrementLineNo :: InputT GHCi ()+incrementLineNo = modifyGHCiState incLineNo+ where+ incLineNo st = st { line_number = line_number st + 1 }++fileLoop :: Handle -> InputT GHCi (Maybe String)+fileLoop hdl = do+ l <- liftIO $ tryIO $ hGetLine hdl+ case l of+ Left e | isEOFError e -> return Nothing+ | -- as we share stdin with the program, the program+ -- might have already closed it, so we might get a+ -- handle-closed exception. We therefore catch that+ -- too.+ isIllegalOperation e -> return Nothing+ | InvalidArgument <- etype -> return Nothing+ | otherwise -> liftIO $ ioError e+ where etype = ioeGetErrorType e+ -- treat InvalidArgument in the same way as EOF:+ -- this can happen if the user closed stdin, or+ -- perhaps did getContents which closes stdin at+ -- EOF.+ Right l' -> do+ incrementLineNo+ return (Just l')++formatCurrentTime :: String -> IO String+formatCurrentTime format =+ getZonedTime >>= return . (formatTime defaultTimeLocale format)++getUserName :: IO String+getUserName = do+#if defined(mingw32_HOST_OS)+ getEnv "USERNAME"+ `catchIO` \e -> do+ putStrLn $ show e+ return ""+#else+ getLoginName+#endif++getInfoForPrompt :: GHCi (SDoc, [String], Int)+getInfoForPrompt = do+ st <- getGHCiState+ imports <- GHC.getContext+ resumes <- GHC.getResumeContext++ context_bit <-+ case resumes of+ [] -> return empty+ r:_ -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (brackets (ppr (GHC.resumeSpan r)) <> space)+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ pan <- GHC.getHistorySpan hist+ return (brackets (ppr (negate ix) <> char ':'+ <+> ppr pan) <> space)++ let+ dots | _:rs <- resumes, not (null rs) = text "... "+ | otherwise = empty++ rev_imports = reverse imports -- rightmost are the most recent++ myIdeclName d | Just m <- ideclAs d = unLoc m+ | otherwise = unLoc (ideclName d)++ modules_names =+ ['*':(moduleNameString m) | IIModule m <- rev_imports] +++ [moduleNameString (myIdeclName d) | IIDecl d <- rev_imports]+ line = 1 + line_number st++ return (dots <> context_bit, modules_names, line)++parseCallEscape :: String -> (String, String)+parseCallEscape s+ | not (all isSpace beforeOpen) = ("", "")+ | null sinceOpen = ("", "")+ | null sinceClosed = ("", "")+ | null cmd = ("", "")+ | otherwise = (cmd, tail sinceClosed)+ where+ (beforeOpen, sinceOpen) = span (/='(') s+ (cmd, sinceClosed) = span (/=')') (tail sinceOpen)++checkPromptStringForErrors :: String -> Maybe String+checkPromptStringForErrors ('%':'c':'a':'l':'l':xs) =+ case parseCallEscape xs of+ ("", "") -> Just ("Incorrect %call syntax. " +++ "Should be %call(a command and arguments).")+ (_, afterClosed) -> checkPromptStringForErrors afterClosed+checkPromptStringForErrors ('%':'%':xs) = checkPromptStringForErrors xs+checkPromptStringForErrors (_:xs) = checkPromptStringForErrors xs+checkPromptStringForErrors "" = Nothing++generatePromptFunctionFromString :: String -> PromptFunction+generatePromptFunctionFromString promptS modules_names line =+ processString promptS+ where+ processString :: String -> GHCi SDoc+ processString ('%':'s':xs) =+ liftM2 (<>) (return modules_list) (processString xs)+ where+ modules_list = hsep $ map text modules_names+ processString ('%':'l':xs) =+ liftM2 (<>) (return $ ppr line) (processString xs)+ processString ('%':'d':xs) =+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%a %b %d"+ processString ('%':'t':xs) =+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%H:%M:%S"+ processString ('%':'T':xs) = do+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%I:%M:%S"+ processString ('%':'@':xs) = do+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%I:%M %P"+ processString ('%':'A':xs) = do+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%H:%M"+ processString ('%':'u':xs) =+ liftM2 (<>) (liftM text user_name) (processString xs)+ where+ user_name = liftIO $ getUserName+ processString ('%':'w':xs) =+ liftM2 (<>) (liftM text current_directory) (processString xs)+ where+ current_directory = liftIO $ getCurrentDirectory+ processString ('%':'o':xs) =+ liftM ((text os) <>) (processString xs)+ processString ('%':'a':xs) =+ liftM ((text arch) <>) (processString xs)+ processString ('%':'N':xs) =+ liftM ((text compilerName) <>) (processString xs)+ processString ('%':'V':xs) =+ liftM ((text $ showVersion compilerVersion) <>) (processString xs)+ processString ('%':'c':'a':'l':'l':xs) = do+ respond <- liftIO $ do+ (code, out, err) <-+ readProcessWithExitCode+ (head list_words) (tail list_words) ""+ `catchIO` \e -> return (ExitFailure 1, "", show e)+ case code of+ ExitSuccess -> return out+ _ -> do+ hPutStrLn stderr err+ return ""+ liftM ((text respond) <>) (processString afterClosed)+ where+ (cmd, afterClosed) = parseCallEscape xs+ list_words = words cmd+ processString ('%':'%':xs) =+ liftM ((char '%') <>) (processString xs)+ processString (x:xs) =+ liftM (char x <>) (processString xs)+ processString "" =+ return empty++mkPrompt :: GHCi String+mkPrompt = do+ st <- getGHCiState+ dflags <- getDynFlags+ (context, modules_names, line) <- getInfoForPrompt++ prompt_string <- (prompt st) modules_names line+ let prompt_doc = context <> prompt_string++ return (showSDoc dflags prompt_doc)++queryQueue :: GHCi (Maybe String)+queryQueue = do+ st <- getGHCiState+ case cmdqueue st of+ [] -> return Nothing+ c:cs -> do setGHCiState st{ cmdqueue = cs }+ return (Just c)++-- Reconfigurable pretty-printing Ticket #5461+installInteractivePrint :: Maybe String -> Bool -> GHCi ()+installInteractivePrint Nothing _ = return ()+installInteractivePrint (Just ipFun) exprmode = do+ ok <- trySuccess $ do+ names <- GHC.parseName ipFun+ let name = case names of+ name':_ -> name'+ [] -> panic "installInteractivePrint"+ modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name+ in he{hsc_IC = new_ic})+ return Succeeded++ when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))++-- | The main read-eval-print loop+runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()+runCommands gCmd = runCommands' handler Nothing gCmd >> return ()++runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler+ -> Maybe (GHCi ()) -- ^ Source error handler+ -> InputT GHCi (Maybe String)+ -> InputT GHCi (Maybe Bool)+ -- We want to return () here, but have to return (Maybe Bool)+ -- because gmask is not polymorphic enough: we want to use+ -- unmask at two different types.+runCommands' eh sourceErrorHandler gCmd = gmask $ \unmask -> do+ b <- ghandle (\e -> case fromException e of+ Just UserInterrupt -> return $ Just False+ _ -> case fromException e of+ Just ghce ->+ do liftIO (print (ghce :: GhcException))+ return Nothing+ _other ->+ liftIO (Exception.throwIO e))+ (unmask $ runOneCommand eh gCmd)+ case b of+ Nothing -> return Nothing+ Just success -> do+ unless success $ maybe (return ()) lift sourceErrorHandler+ unmask $ runCommands' eh sourceErrorHandler gCmd++-- | Evaluate a single line of user input (either :<command> or Haskell code).+-- A result of Nothing means there was no more input to process.+-- Otherwise the result is Just b where b is True if the command succeeded;+-- this is relevant only to ghc -e, which will exit with status 1+-- if the command was unsuccessful. GHCi will continue in either case.+runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)+ -> InputT GHCi (Maybe Bool)+runOneCommand eh gCmd = do+ -- run a previously queued command if there is one, otherwise get new+ -- input from user+ mb_cmd0 <- noSpace (lift queryQueue)+ mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0+ case mb_cmd1 of+ Nothing -> return Nothing+ Just c -> do+ st <- getGHCiState+ ghciHandle (\e -> lift $ eh e >>= return . Just) $+ handleSourceError printErrorAndFail $+ cmd_wrapper st $ doCommand c+ -- source error's are handled by runStmt+ -- is the handler necessary here?+ where+ printErrorAndFail err = do+ GHC.printException err+ return $ Just False -- Exit ghc -e, but not GHCi++ noSpace q = q >>= maybe (return Nothing)+ (\c -> case removeSpaces c of+ "" -> noSpace q+ ":{" -> multiLineCmd q+ _ -> return (Just c) )+ multiLineCmd q = do+ st <- getGHCiState+ let p = prompt st+ setGHCiState st{ prompt = prompt_cont st }+ mb_cmd <- collectCommand q "" `GHC.gfinally`+ modifyGHCiState (\st' -> st' { prompt = p })+ return mb_cmd+ -- we can't use removeSpaces for the sublines here, so+ -- multiline commands are somewhat more brittle against+ -- fileformat errors (such as \r in dos input on unix),+ -- we get rid of any extra spaces for the ":}" test;+ -- we also avoid silent failure if ":}" is not found;+ -- and since there is no (?) valid occurrence of \r (as+ -- opposed to its String representation, "\r") inside a+ -- ghci command, we replace any such with ' ' (argh:-(+ collectCommand q c = q >>=+ maybe (liftIO (ioError collectError))+ (\l->if removeSpaces l == ":}"+ then return (Just c)+ else collectCommand q (c ++ "\n" ++ map normSpace l))+ where normSpace '\r' = ' '+ normSpace x = x+ -- SDM (2007-11-07): is userError the one to use here?+ collectError = userError "unterminated multiline command :{ .. :}"++ -- | Handle a line of input+ doCommand :: String -> InputT GHCi CommandResult++ -- command+ doCommand stmt | stmt'@(':' : cmd) <- removeSpaces stmt = do+ (stats, result) <- runWithStats (const Nothing) $ specialCommand cmd+ let processResult True = Nothing+ processResult False = Just True+ return $ CommandComplete stmt' (processResult <$> result) stats++ -- haskell+ doCommand stmt = do+ -- if 'stmt' was entered via ':{' it will contain '\n's+ let stmt_nl_cnt = length [ () | '\n' <- stmt ]+ ml <- lift $ isOptionSet Multiline+ if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input+ then do+ fst_line_num <- line_number <$> getGHCiState+ mb_stmt <- checkInputForLayout stmt gCmd+ case mb_stmt of+ Nothing -> return CommandIncomplete+ Just ml_stmt -> do+ -- temporarily compensate line-number for multi-line input+ (stats, result) <- runAndPrintStats runAllocs $ lift $+ runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion+ return $+ CommandComplete ml_stmt (Just . runSuccess <$> result) stats+ else do -- single line input and :{ - multiline input+ last_line_num <- line_number <$> getGHCiState+ -- reconstruct first line num from last line num and stmt+ let fst_line_num | stmt_nl_cnt > 0 = last_line_num - (stmt_nl_cnt2 + 1)+ | otherwise = last_line_num -- single line input+ stmt_nl_cnt2 = length [ () | '\n' <- stmt' ]+ stmt' = dropLeadingWhiteLines stmt -- runStmt doesn't like leading empty lines+ -- temporarily compensate line-number for multi-line input+ (stats, result) <- runAndPrintStats runAllocs $ lift $+ runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion+ return $ CommandComplete stmt' (Just . runSuccess <$> result) stats++ -- runStmt wrapper for temporarily overridden line-number+ runStmtWithLineNum :: Int -> String -> SingleStep+ -> GHCi (Maybe GHC.ExecResult)+ runStmtWithLineNum lnum stmt step = do+ st0 <- getGHCiState+ setGHCiState st0 { line_number = lnum }+ result <- runStmt stmt step+ -- restore original line_number+ getGHCiState >>= \st -> setGHCiState st { line_number = line_number st0 }+ return result++ -- note: this is subtly different from 'unlines . dropWhile (all isSpace) . lines'+ dropLeadingWhiteLines s | (l0,'\n':r) <- break (=='\n') s+ , all isSpace l0 = dropLeadingWhiteLines r+ | otherwise = s+++-- #4316+-- lex the input. If there is an unclosed layout context, request input+checkInputForLayout :: String -> InputT GHCi (Maybe String)+ -> InputT GHCi (Maybe String)+checkInputForLayout stmt getStmt = do+ dflags' <- getDynFlags+ let dflags = xopt_set dflags' LangExt.AlternativeLayoutRule+ st0 <- getGHCiState+ let buf' = stringToStringBuffer stmt+ loc = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1+ pstate = Lexer.mkPState dflags buf' loc+ case Lexer.unP goToEnd pstate of+ (Lexer.POk _ False) -> return $ Just stmt+ _other -> do+ st1 <- getGHCiState+ let p = prompt st1+ setGHCiState st1{ prompt = prompt_cont st1 }+ mb_stmt <- ghciHandle (\ex -> case fromException ex of+ Just UserInterrupt -> return Nothing+ _ -> case fromException ex of+ Just ghce ->+ do liftIO (print (ghce :: GhcException))+ return Nothing+ _other -> liftIO (Exception.throwIO ex))+ getStmt+ modifyGHCiState (\st' -> st' { prompt = p })+ -- the recursive call does not recycle parser state+ -- as we use a new string buffer+ case mb_stmt of+ Nothing -> return Nothing+ Just str -> if str == ""+ then return $ Just stmt+ else do+ checkInputForLayout (stmt++"\n"++str) getStmt+ where goToEnd = do+ eof <- Lexer.nextIsEOF+ if eof+ then Lexer.activeContext+ else Lexer.lexer False return >> goToEnd++enqueueCommands :: [String] -> GHCi ()+enqueueCommands cmds = do+ -- make sure we force any exceptions in the commands while we're+ -- still inside the exception handler, otherwise bad things will+ -- happen (see #10501)+ cmds `deepseq` return ()+ modifyGHCiState $ \st -> st{ cmdqueue = cmds ++ cmdqueue st }++-- | Entry point to execute some haskell code from user.+-- The return value True indicates success, as in `runOneCommand`.+runStmt :: String -> SingleStep -> GHCi (Maybe GHC.ExecResult)+runStmt input step = do+ dflags <- GHC.getInteractiveDynFlags+ -- In GHCi, we disable `-fdefer-type-errors`, as well as `-fdefer-type-holes`+ -- and `-fdefer-out-of-scope-variables` for **naked expressions**. The+ -- declarations and statements are not affected.+ -- See Note [Deferred type errors in GHCi] in typecheck/TcRnDriver.hs+ st <- getGHCiState+ let source = progname st+ let line = line_number st++ if | GHC.isStmt dflags input -> do+ hsc_env <- GHC.getSession+ mb_stmt <- liftIO (runInteractiveHsc hsc_env (hscParseStmtWithLocation source line input))+ case mb_stmt of+ Nothing ->+ -- empty statement / comment+ return (Just exec_complete)+ Just stmt ->+ run_stmt stmt++ | GHC.isImport dflags input -> run_import++ -- Every import declaration should be handled by `run_import`. As GHCi+ -- in general only accepts one command at a time, we simply throw an+ -- exception when the input contains multiple commands of which at least+ -- one is an import command (see #10663).+ | GHC.hasImport dflags input -> throwGhcException+ (CmdLineError "error: expecting a single import declaration")++ -- Otherwise assume a declaration (or a list of declarations)+ -- Note: `GHC.isDecl` returns False on input like+ -- `data Infix a b = a :@: b; infixl 4 :@:`+ -- and should therefore not be used here.+ | otherwise -> do+ hsc_env <- GHC.getSession+ decls <- liftIO (hscParseDeclsWithLocation hsc_env source line input)+ run_decls decls+ where+ exec_complete = GHC.ExecComplete (Right []) 0++ run_import = do+ addImportToContext input+ return (Just exec_complete)++ run_stmt :: GhciLStmt GhcPs -> GHCi (Maybe GHC.ExecResult)+ run_stmt stmt = do+ m_result <- GhciMonad.runStmt stmt input step+ case m_result of+ Nothing -> return Nothing+ Just result -> Just <$> afterRunStmt (const True) result++ -- `x = y` (a declaration) should be treated as `let x = y` (a statement).+ -- The reason is because GHCi wasn't designed to support `x = y`, but then+ -- b98ff3 (#7253) added support for it, except it did not do a good job and+ -- caused problems like:+ --+ -- - not adding the binders defined this way in the necessary places caused+ -- `x = y` to not work in some cases (#12091).+ -- - some GHCi command crashed after `x = y` (#15721)+ -- - warning generation did not work for `x = y` (#11606)+ -- - because `x = y` is a declaration (instead of a statement) differences+ -- in generated code caused confusion (#16089)+ --+ -- Instead of dealing with all these problems individually here we fix this+ -- mess by just treating `x = y` as `let x = y`.+ run_decls :: [LHsDecl GhcPs] -> GHCi (Maybe GHC.ExecResult)+ -- Only turn `FunBind` and `VarBind` into statements, other bindings+ -- (e.g. `PatBind`) need to stay as decls.+ run_decls [L l (ValD _ bind@FunBind{})] = run_stmt (mk_stmt l bind)+ run_decls [L l (ValD _ bind@VarBind{})] = run_stmt (mk_stmt l bind)+ -- Note that any `x = y` declarations below will be run as declarations+ -- instead of statements (e.g. `...; x = y; ...`)+ run_decls decls = do+ -- In the new IO library, read handles buffer data even if the Handle+ -- is set to NoBuffering. This causes problems for GHCi where there+ -- are really two stdin Handles. So we flush any bufferred data in+ -- GHCi's stdin Handle here (only relevant if stdin is attached to+ -- a file, otherwise the read buffer can't be flushed).+ _ <- liftIO $ tryIO $ hFlushAll stdin+ m_result <- GhciMonad.runDecls' decls+ forM m_result $ \result ->+ afterRunStmt (const True) (GHC.ExecComplete (Right result) 0)++ mk_stmt :: SrcSpan -> HsBind GhcPs -> GhciLStmt GhcPs+ mk_stmt loc bind =+ let l = L loc+ in l (LetStmt noExt (l (HsValBinds noExt (ValBinds noExt (unitBag (l bind)) []))))++-- | Clean up the GHCi environment after a statement has run+afterRunStmt :: (SrcSpan -> Bool) -> GHC.ExecResult -> GHCi GHC.ExecResult+afterRunStmt step_here run_result = do+ resumes <- GHC.getResumeContext+ case run_result of+ GHC.ExecComplete{..} ->+ case execResult of+ Left ex -> liftIO $ Exception.throwIO ex+ Right names -> do+ show_types <- isOptionSet ShowType+ when show_types $ printTypeOfNames names+ GHC.ExecBreak names mb_info+ | isNothing mb_info ||+ step_here (GHC.resumeSpan $ head resumes) -> do+ mb_id_loc <- toBreakIdAndLocation mb_info+ let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc+ if (null bCmd)+ then printStoppedAtBreakInfo (head resumes) names+ else enqueueCommands [bCmd]+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]+ return ()+ | otherwise -> resume step_here GHC.SingleStep >>=+ afterRunStmt step_here >> return ()++ flushInterpBuffers+ withSignalHandlers $ do+ b <- isOptionSet RevertCAFs+ when b revertCAFs++ return run_result++runSuccess :: Maybe GHC.ExecResult -> Bool+runSuccess run_result+ | Just (GHC.ExecComplete { execResult = Right _ }) <- run_result = True+ | otherwise = False++runAllocs :: Maybe GHC.ExecResult -> Maybe Integer+runAllocs m = do+ res <- m+ case res of+ GHC.ExecComplete{..} -> Just (fromIntegral execAllocation)+ _ -> Nothing++toBreakIdAndLocation ::+ Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))+toBreakIdAndLocation Nothing = return Nothing+toBreakIdAndLocation (Just inf) = do+ let md = GHC.breakInfo_module inf+ nm = GHC.breakInfo_number inf+ st <- getGHCiState+ return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,+ breakModule loc == md,+ breakTick loc == nm ]++printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()+printStoppedAtBreakInfo res names = do+ printForUser $ pprStopped res+ -- printTypeOfNames session names+ let namesSorted = sortBy compareNames names+ tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted+ docs <- mapM pprTypeAndContents [i | AnId i <- tythings]+ printForUserPartWay $ vcat docs++printTypeOfNames :: [Name] -> GHCi ()+printTypeOfNames names+ = mapM_ (printTypeOfName ) $ sortBy compareNames names++compareNames :: Name -> Name -> Ordering+n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2+ where compareWith n = (getOccString n, getSrcSpan n)++printTypeOfName :: Name -> GHCi ()+printTypeOfName n+ = do maybe_tything <- GHC.lookupName n+ case maybe_tything of+ Nothing -> return ()+ Just thing -> printTyThing thing+++data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand++-- | Entry point for execution a ':<command>' input from user+specialCommand :: String -> InputT GHCi Bool+specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)+specialCommand str = do+ let (cmd,rest) = break isSpace str+ maybe_cmd <- lift $ lookupCommand cmd+ htxt <- short_help <$> getGHCiState+ case maybe_cmd of+ GotCommand cmd -> (cmdAction cmd) (dropWhile isSpace rest)+ BadCommand ->+ do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"+ ++ htxt)+ return False+ NoLastCommand ->+ do liftIO $ hPutStr stdout ("there is no last command to perform\n"+ ++ htxt)+ return False++shellEscape :: String -> GHCi Bool+shellEscape str = liftIO (system str >> return False)++lookupCommand :: String -> GHCi (MaybeCommand)+lookupCommand "" = do+ st <- getGHCiState+ case last_command st of+ Just c -> return $ GotCommand c+ Nothing -> return NoLastCommand+lookupCommand str = do+ mc <- lookupCommand' str+ modifyGHCiState (\st -> st { last_command = mc })+ return $ case mc of+ Just c -> GotCommand c+ Nothing -> BadCommand++lookupCommand' :: String -> GHCi (Maybe Command)+lookupCommand' ":" = return Nothing+lookupCommand' str' = do+ macros <- ghci_macros <$> getGHCiState+ ghci_cmds <- ghci_commands <$> getGHCiState++ let ghci_cmds_nohide = filter (not . cmdHidden) ghci_cmds++ let (str, xcmds) = case str' of+ ':' : rest -> (rest, []) -- "::" selects a builtin command+ _ -> (str', macros) -- otherwise include macros in lookup++ lookupExact s = find $ (s ==) . cmdName+ lookupPrefix s = find $ (s `isPrefixOf`) . cmdName++ -- hidden commands can only be matched exact+ builtinPfxMatch = lookupPrefix str ghci_cmds_nohide++ -- first, look for exact match (while preferring macros); then, look+ -- for first prefix match (preferring builtins), *unless* a macro+ -- overrides the builtin; see #8305 for motivation+ return $ lookupExact str xcmds <|>+ lookupExact str ghci_cmds <|>+ (builtinPfxMatch >>= \c -> lookupExact (cmdName c) xcmds) <|>+ builtinPfxMatch <|>+ lookupPrefix str xcmds++getCurrentBreakSpan :: GHCi (Maybe SrcSpan)+getCurrentBreakSpan = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (Just (GHC.resumeSpan r))+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ pan <- GHC.getHistorySpan hist+ return (Just pan)++getCallStackAtCurrentBreakpoint :: GHCi (Maybe [String])+getCallStackAtCurrentBreakpoint = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ hsc_env <- GHC.getSession+ Just <$> liftIO (costCentreStackInfo hsc_env (GHC.resumeCCS r))++getCurrentBreakModule :: GHCi (Maybe Module)+getCurrentBreakModule = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ return $ Just $ GHC.getHistoryModule hist++-----------------------------------------------------------------------------+--+-- Commands+--+-----------------------------------------------------------------------------++noArgs :: GHCi () -> String -> GHCi ()+noArgs m "" = m+noArgs _ _ = liftIO $ putStrLn "This command takes no arguments"++withSandboxOnly :: String -> GHCi () -> GHCi ()+withSandboxOnly cmd this = do+ dflags <- getDynFlags+ if not (gopt Opt_GhciSandbox dflags)+ then printForUser (text cmd <+>+ ptext (sLit "is not supported with -fno-ghci-sandbox"))+ else this++-----------------------------------------------------------------------------+-- :help++help :: String -> GHCi ()+help _ = do+ txt <- long_help `fmap` getGHCiState+ liftIO $ putStr txt++-----------------------------------------------------------------------------+-- :info++info :: Bool -> String -> InputT GHCi ()+info _ "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'")+info allInfo s = handleSourceError GHC.printException $ do+ unqual <- GHC.getPrintUnqual+ dflags <- getDynFlags+ sdocs <- mapM (infoThing allInfo) (words s)+ mapM_ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs++infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc+infoThing allInfo str = do+ names <- GHC.parseName str+ mb_stuffs <- mapM (GHC.getInfo allInfo) names+ let filtered = filterOutChildren (\(t,_f,_ci,_fi,_sd) -> t)+ (catMaybes mb_stuffs)+ return $ vcat (intersperse (text "") $ map pprInfo filtered)++ -- Filter out names whose parent is also there Good+ -- example is '[]', which is both a type and data+ -- constructor in the same type+filterOutChildren :: (a -> TyThing) -> [a] -> [a]+filterOutChildren get_thing xs+ = filterOut has_parent xs+ where+ all_names = mkNameSet (map (getName . get_thing) xs)+ has_parent x = case tyThingParent_maybe (get_thing x) of+ Just p -> getName p `elemNameSet` all_names+ Nothing -> False++pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc+pprInfo (thing, fixity, cls_insts, fam_insts, docs)+ = docs+ $$ pprTyThingInContextLoc thing+ $$ show_fixity+ $$ vcat (map GHC.pprInstance cls_insts)+ $$ vcat (map GHC.pprFamInst fam_insts)+ where+ show_fixity+ | fixity == GHC.defaultFixity = empty+ | otherwise = ppr fixity <+> pprInfixName (GHC.getName thing)++-----------------------------------------------------------------------------+-- :main++runMain :: String -> GHCi ()+runMain s = case toArgs s of+ Left err -> liftIO (hPutStrLn stderr err)+ Right args ->+ do dflags <- getDynFlags+ let main = fromMaybe "main" (mainFunIs dflags)+ -- Wrap the main function in 'void' to discard its value instead+ -- of printing it (#9086). See Haskell 2010 report Chapter 5.+ doWithArgs args $ "Control.Monad.void (" ++ main ++ ")"++-----------------------------------------------------------------------------+-- :run++runRun :: String -> GHCi ()+runRun s = case toCmdArgs s of+ Left err -> liftIO (hPutStrLn stderr err)+ Right (cmd, args) -> doWithArgs args cmd++doWithArgs :: [String] -> String -> GHCi ()+doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " +++ show args ++ " (" ++ cmd ++ ")"]++-----------------------------------------------------------------------------+-- :cd++changeDirectory :: String -> InputT GHCi ()+changeDirectory "" = do+ -- :cd on its own changes to the user's home directory+ either_dir <- liftIO $ tryIO getHomeDirectory+ case either_dir of+ Left _e -> return ()+ Right dir -> changeDirectory dir+changeDirectory dir = do+ graph <- GHC.getModuleGraph+ when (not (null $ GHC.mgModSummaries graph)) $+ liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."+ GHC.setTargets []+ _ <- GHC.load LoadAllTargets+ lift $ setContextAfterLoad False []+ GHC.workingDirectoryChanged+ dir' <- expandPath dir+ liftIO $ setCurrentDirectory dir'+ dflags <- getDynFlags+ -- With -fexternal-interpreter, we have to change the directory of the subprocess too.+ -- (this gives consistent behaviour with and without -fexternal-interpreter)+ when (gopt Opt_ExternalInterpreter dflags) $ do+ hsc_env <- GHC.getSession+ fhv <- compileGHCiExpr $+ "System.Directory.setCurrentDirectory " ++ show dir'+ liftIO $ evalIO hsc_env fhv++trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag+trySuccess act =+ handleSourceError (\e -> do GHC.printException e+ return Failed) $ do+ act++-----------------------------------------------------------------------------+-- :edit++editFile :: String -> InputT GHCi ()+editFile str =+ do file <- if null str then lift chooseEditFile else expandPath str+ st <- getGHCiState+ errs <- liftIO $ readIORef $ lastErrorLocations st+ let cmd = editor st+ when (null cmd)+ $ throwGhcException (CmdLineError "editor not set, use :set editor")+ lineOpt <- liftIO $ do+ let sameFile p1 p2 = liftA2 (==) (canonicalizePath p1) (canonicalizePath p2)+ `catchIO` (\_ -> return False)++ curFileErrs <- filterM (\(f, _) -> unpackFS f `sameFile` file) errs+ return $ case curFileErrs of+ (_, line):_ -> " +" ++ show line+ _ -> ""+ let cmdArgs = ' ':(file ++ lineOpt)+ code <- liftIO $ system (cmd ++ cmdArgs)++ when (code == ExitSuccess)+ $ reloadModule ""++-- The user didn't specify a file so we pick one for them.+-- Our strategy is to pick the first module that failed to load,+-- or otherwise the first target.+--+-- XXX: Can we figure out what happened if the depndecy analysis fails+-- (e.g., because the porgrammeer mistyped the name of a module)?+-- XXX: Can we figure out the location of an error to pass to the editor?+-- XXX: if we could figure out the list of errors that occured during the+-- last load/reaload, then we could start the editor focused on the first+-- of those.+chooseEditFile :: GHCi String+chooseEditFile =+ do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x++ graph <- GHC.getModuleGraph+ failed_graph <-+ GHC.mkModuleGraph <$> filterM hasFailed (GHC.mgModSummaries graph)+ let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing+ pick xs = case xs of+ x : _ -> GHC.ml_hs_file (GHC.ms_location x)+ _ -> Nothing++ case pick (order failed_graph) of+ Just file -> return file+ Nothing ->+ do targets <- GHC.getTargets+ case msum (map fromTarget targets) of+ Just file -> return file+ Nothing -> throwGhcException (CmdLineError "No files to edit.")++ where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f+ fromTarget _ = Nothing -- when would we get a module target?+++-----------------------------------------------------------------------------+-- :def++defineMacro :: Bool{-overwrite-} -> String -> GHCi ()+defineMacro _ (':':_) =+ liftIO $ putStrLn "macro name cannot start with a colon"+defineMacro overwrite s = do+ let (macro_name, definition) = break isSpace s+ macros <- ghci_macros <$> getGHCiState+ let defined = map cmdName macros+ if null macro_name+ then if null defined+ then liftIO $ putStrLn "no macros defined"+ else liftIO $ putStr ("the following macros are defined:\n" +++ unlines defined)+ else do+ if (not overwrite && macro_name `elem` defined)+ then throwGhcException (CmdLineError+ ("macro '" ++ macro_name ++ "' is already defined"))+ else do++ -- compile the expression+ handleSourceError GHC.printException $ do+ step <- getGhciStepIO+ expr <- GHC.parseExpr definition+ -- > ghciStepIO . definition :: String -> IO String+ let stringTy = nlHsTyVar stringTy_RDR+ ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy+ body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)+ `mkHsApp` (nlHsPar expr)+ tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM)+ new_expr = L (getLoc expr) $ ExprWithTySig noExt body tySig+ hv <- GHC.compileParsedExprRemote new_expr++ let newCmd = Command { cmdName = macro_name+ , cmdAction = lift . runMacro hv+ , cmdHidden = False+ , cmdCompletionFunc = noCompletion+ }++ -- later defined macros have precedence+ modifyGHCiState $ \s ->+ let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]+ in s { ghci_macros = newCmd : filtered }++runMacro :: GHC.ForeignHValue{-String -> IO String-} -> String -> GHCi Bool+runMacro fun s = do+ hsc_env <- GHC.getSession+ str <- liftIO $ evalStringToIOString hsc_env fun s+ enqueueCommands (lines str)+ return False+++-----------------------------------------------------------------------------+-- :undef++undefineMacro :: String -> GHCi ()+undefineMacro str = mapM_ undef (words str)+ where undef macro_name = do+ cmds <- ghci_macros <$> getGHCiState+ if (macro_name `notElem` map cmdName cmds)+ then throwGhcException (CmdLineError+ ("macro '" ++ macro_name ++ "' is not defined"))+ else do+ -- This is a tad racy but really, it's a shell+ modifyGHCiState $ \s ->+ s { ghci_macros = filter ((/= macro_name) . cmdName)+ (ghci_macros s) }+++-----------------------------------------------------------------------------+-- :cmd++cmdCmd :: String -> GHCi ()+cmdCmd str = handleSourceError GHC.printException $ do+ step <- getGhciStepIO+ expr <- GHC.parseExpr str+ -- > ghciStepIO str :: IO String+ let new_expr = step `mkHsApp` expr+ hv <- GHC.compileParsedExprRemote new_expr++ hsc_env <- GHC.getSession+ cmds <- liftIO $ evalString hsc_env hv+ enqueueCommands (lines cmds)++-- | Generate a typed ghciStepIO expression+-- @ghciStepIO :: Ty String -> IO String@.+getGhciStepIO :: GHCi (LHsExpr GhcPs)+getGhciStepIO = do+ ghciTyConName <- GHC.getGHCiMonad+ let stringTy = nlHsTyVar stringTy_RDR+ ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy+ ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy+ body = nlHsVar (getRdrName ghciStepIoMName)+ tySig = mkLHsSigWcType (ghciM `nlHsFunTy` ioM)+ return $ noLoc $ ExprWithTySig noExt body tySig++-----------------------------------------------------------------------------+-- :check++checkModule :: String -> InputT GHCi ()+checkModule m = do+ let modl = GHC.mkModuleName m+ ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do+ r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl+ dflags <- getDynFlags+ liftIO $ putStrLn $ showSDoc dflags $+ case GHC.moduleInfo r of+ cm | Just scope <- GHC.modInfoTopLevelScope cm ->+ let+ (loc, glob) = ASSERT( all isExternalName scope )+ partition ((== modl) . GHC.moduleName . GHC.nameModule) scope+ in+ (text "global names: " <+> ppr glob) $$+ (text "local names: " <+> ppr loc)+ _ -> empty+ return True+ afterLoad (successIf ok) False++-----------------------------------------------------------------------------+-- :doc++docCmd :: String -> InputT GHCi ()+docCmd "" =+ throwGhcException (CmdLineError "syntax: ':doc <thing-you-want-docs-for>'")+docCmd s = do+ -- TODO: Maybe also get module headers for module names+ names <- GHC.parseName s+ e_docss <- mapM GHC.getDocs names+ sdocs <- mapM (either handleGetDocsFailure (pure . pprDocs)) e_docss+ let sdocs' = vcat (intersperse (text "") sdocs)+ unqual <- GHC.getPrintUnqual+ dflags <- getDynFlags+ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs'++-- TODO: also print arg docs.+pprDocs :: (Maybe HsDocString, Map Int HsDocString) -> SDoc+pprDocs (mb_decl_docs, _arg_docs) =+ maybe+ (text "<has no documentation>")+ (text . unpackHDS)+ mb_decl_docs++handleGetDocsFailure :: GHC.GhcMonad m => GetDocsFailure -> m SDoc+handleGetDocsFailure no_docs = do+ dflags <- getDynFlags+ let msg = showPpr dflags no_docs+ throwGhcException $ case no_docs of+ NameHasNoModule {} -> Sorry msg+ NoDocsInIface {} -> InstallationError msg+ InteractiveName -> ProgramError msg++-----------------------------------------------------------------------------+-- :load, :add, :reload++-- | Sets '-fdefer-type-errors' if 'defer' is true, executes 'load' and unsets+-- '-fdefer-type-errors' again if it has not been set before.+wrapDeferTypeErrors :: InputT GHCi a -> InputT GHCi a+wrapDeferTypeErrors load =+ gbracket+ (do+ -- Force originalFlags to avoid leaking the associated HscEnv+ !originalFlags <- getDynFlags+ void $ GHC.setProgramDynFlags $+ setGeneralFlag' Opt_DeferTypeErrors originalFlags+ return originalFlags)+ (\originalFlags -> void $ GHC.setProgramDynFlags originalFlags)+ (\_ -> load)++loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag+loadModule fs = do+ (_, result) <- runAndPrintStats (const Nothing) (loadModule' fs)+ either (liftIO . Exception.throwIO) return result++-- | @:load@ command+loadModule_ :: [FilePath] -> InputT GHCi ()+loadModule_ fs = void $ loadModule (zip fs (repeat Nothing))++loadModuleDefer :: [FilePath] -> InputT GHCi ()+loadModuleDefer = wrapDeferTypeErrors . loadModule_++loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag+loadModule' files = do+ let (filenames, phases) = unzip files+ exp_filenames <- mapM expandPath filenames+ let files' = zip exp_filenames phases+ targets <- mapM (uncurry GHC.guessTarget) files'++ -- NOTE: we used to do the dependency anal first, so that if it+ -- fails we didn't throw away the current set of modules. This would+ -- require some re-working of the GHC interface, so we'll leave it+ -- as a ToDo for now.++ hsc_env <- GHC.getSession++ -- Grab references to the currently loaded modules so that we can+ -- see if they leak.+ let !dflags = hsc_dflags hsc_env+ leak_indicators <- if gopt Opt_GhciLeakCheck dflags+ then liftIO $ getLeakIndicators hsc_env+ else return (panic "no leak indicators")++ -- unload first+ _ <- GHC.abandonAll+ lift discardActiveBreakPoints+ GHC.setTargets []+ _ <- GHC.load LoadAllTargets++ GHC.setTargets targets+ success <- doLoadAndCollectInfo False LoadAllTargets+ when (gopt Opt_GhciLeakCheck dflags) $+ liftIO $ checkLeakIndicators dflags leak_indicators+ return success++-- | @:add@ command+addModule :: [FilePath] -> InputT GHCi ()+addModule files = do+ lift revertCAFs -- always revert CAFs on load/add.+ files' <- mapM expandPath files+ targets <- mapM (\m -> GHC.guessTarget m Nothing) files'+ targets' <- filterM checkTarget targets+ -- remove old targets with the same id; e.g. for :add *M+ mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets' ]+ mapM_ GHC.addTarget targets'+ _ <- doLoadAndCollectInfo False LoadAllTargets+ return ()+ where+ checkTarget :: Target -> InputT GHCi Bool+ checkTarget (Target (TargetModule m) _ _) = checkTargetModule m+ checkTarget (Target (TargetFile f _) _ _) = liftIO $ checkTargetFile f++ checkTargetModule :: ModuleName -> InputT GHCi Bool+ checkTargetModule m = do+ hsc_env <- GHC.getSession+ result <- liftIO $+ Finder.findImportedModule hsc_env m (Just (fsLit "this"))+ case result of+ Found _ _ -> return True+ _ -> (liftIO $ putStrLn $+ "Module " ++ moduleNameString m ++ " not found") >> return False++ checkTargetFile :: String -> IO Bool+ checkTargetFile f = do+ exists <- (doesFileExist f) :: IO Bool+ unless exists $ putStrLn $ "File " ++ f ++ " not found"+ return exists++-- | @:unadd@ command+unAddModule :: [FilePath] -> InputT GHCi ()+unAddModule files = do+ files' <- mapM expandPath files+ targets <- mapM (\m -> GHC.guessTarget m Nothing) files'+ mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]+ _ <- doLoadAndCollectInfo False LoadAllTargets+ return ()++-- | @:reload@ command+reloadModule :: String -> InputT GHCi ()+reloadModule m = void $ doLoadAndCollectInfo True loadTargets+ where+ loadTargets | null m = LoadAllTargets+ | otherwise = LoadUpTo (GHC.mkModuleName m)++reloadModuleDefer :: String -> InputT GHCi ()+reloadModuleDefer = wrapDeferTypeErrors . reloadModule++-- | Load/compile targets and (optionally) collect module-info+--+-- This collects the necessary SrcSpan annotated type information (via+-- 'collectInfo') required by the @:all-types@, @:loc-at@, @:type-at@,+-- and @:uses@ commands.+--+-- Meta-info collection is not enabled by default and needs to be+-- enabled explicitly via @:set +c@. The reason is that collecting+-- the type-information for all sub-spans can be quite expensive, and+-- since those commands are designed to be used by editors and+-- tooling, it's useless to collect this data for normal GHCi+-- sessions.+doLoadAndCollectInfo :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag+doLoadAndCollectInfo retain_context howmuch = do+ doCollectInfo <- lift (isOptionSet CollectInfo)++ doLoad retain_context howmuch >>= \case+ Succeeded | doCollectInfo -> do+ mod_summaries <- GHC.mgModSummaries <$> getModuleGraph+ loaded <- filterM GHC.isLoaded $ map GHC.ms_mod_name mod_summaries+ v <- mod_infos <$> getGHCiState+ !newInfos <- collectInfo v loaded+ modifyGHCiState (\st -> st { mod_infos = newInfos })+ return Succeeded+ flag -> return flag++doLoad :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag+doLoad retain_context howmuch = do+ -- turn off breakpoints before we load: we can't turn them off later, because+ -- the ModBreaks will have gone away.+ lift discardActiveBreakPoints++ lift resetLastErrorLocations+ -- Enable buffering stdout and stderr as we're compiling. Keeping these+ -- handles unbuffered will just slow the compilation down, especially when+ -- compiling in parallel.+ gbracket (liftIO $ do hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering)+ (\_ ->+ liftIO $ do hSetBuffering stdout NoBuffering+ hSetBuffering stderr NoBuffering) $ \_ -> do+ ok <- trySuccess $ GHC.load howmuch+ afterLoad ok retain_context+ return ok+++afterLoad :: SuccessFlag+ -> Bool -- keep the remembered_ctx, as far as possible (:reload)+ -> InputT GHCi ()+afterLoad ok retain_context = do+ lift revertCAFs -- always revert CAFs on load.+ lift discardTickArrays+ loaded_mods <- getLoadedModules+ modulesLoadedMsg ok loaded_mods+ lift $ setContextAfterLoad retain_context loaded_mods++setContextAfterLoad :: Bool -> [GHC.ModSummary] -> GHCi ()+setContextAfterLoad keep_ctxt [] = do+ setContextKeepingPackageModules keep_ctxt []+setContextAfterLoad keep_ctxt ms = do+ -- load a target if one is available, otherwise load the topmost module.+ targets <- GHC.getTargets+ case [ m | Just m <- map (findTarget ms) targets ] of+ [] ->+ let graph = GHC.mkModuleGraph ms+ graph' = flattenSCCs (GHC.topSortModuleGraph True graph Nothing)+ in load_this (last graph')+ (m:_) ->+ load_this m+ where+ findTarget mds t+ = case filter (`matches` t) mds of+ [] -> Nothing+ (m:_) -> Just m++ summary `matches` Target (TargetModule m) _ _+ = GHC.ms_mod_name summary == m+ summary `matches` Target (TargetFile f _) _ _+ | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'+ _ `matches` _+ = False++ load_this summary | m <- GHC.ms_mod summary = do+ is_interp <- GHC.moduleIsInterpreted m+ dflags <- getDynFlags+ let star_ok = is_interp && not (safeLanguageOn dflags)+ -- We import the module with a * iff+ -- - it is interpreted, and+ -- - -XSafe is off (it doesn't allow *-imports)+ let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)]+ | otherwise = [mkIIDecl (GHC.moduleName m)]+ setContextKeepingPackageModules keep_ctxt new_ctx+++-- | Keep any package modules (except Prelude) when changing the context.+setContextKeepingPackageModules+ :: Bool -- True <=> keep all of remembered_ctx+ -- False <=> just keep package imports+ -> [InteractiveImport] -- new context+ -> GHCi ()++setContextKeepingPackageModules keep_ctx trans_ctx = do++ st <- getGHCiState+ let rem_ctx = remembered_ctx st+ new_rem_ctx <- if keep_ctx then return rem_ctx+ else keepPackageImports rem_ctx+ setGHCiState st{ remembered_ctx = new_rem_ctx,+ transient_ctx = filterSubsumed new_rem_ctx trans_ctx }+ setGHCContextFromGHCiState++-- | Filters a list of 'InteractiveImport', clearing out any home package+-- imports so only imports from external packages are preserved. ('IIModule'+-- counts as a home package import, because we are only able to bring a+-- full top-level into scope when the source is available.)+keepPackageImports :: [InteractiveImport] -> GHCi [InteractiveImport]+keepPackageImports = filterM is_pkg_import+ where+ is_pkg_import :: InteractiveImport -> GHCi Bool+ is_pkg_import (IIModule _) = return False+ is_pkg_import (IIDecl d)+ = do e <- gtry $ GHC.findModule mod_name (fmap sl_fs $ ideclPkgQual d)+ case e :: Either SomeException Module of+ Left _ -> return False+ Right m -> return (not (isHomeModule m))+ where+ mod_name = unLoc (ideclName d)+++modulesLoadedMsg :: SuccessFlag -> [GHC.ModSummary] -> InputT GHCi ()+modulesLoadedMsg ok mods = do+ dflags <- getDynFlags+ unqual <- GHC.getPrintUnqual++ msg <- if gopt Opt_ShowLoadedModules dflags+ then do+ mod_names <- mapM mod_name mods+ let mod_commas+ | null mods = text "none."+ | otherwise = hsep (punctuate comma mod_names) <> text "."+ return $ status <> text ", modules loaded:" <+> mod_commas+ else do+ return $ status <> text ","+ <+> speakNOf (length mods) (text "module") <+> "loaded."++ when (verbosity dflags > 0) $+ liftIO $ putStrLn $ showSDocForUser dflags unqual msg+ where+ status = case ok of+ Failed -> text "Failed"+ Succeeded -> text "Ok"++ mod_name mod = do+ is_interpreted <- GHC.moduleIsBootOrNotObjectLinkable mod+ return $ if is_interpreted+ then ppr (GHC.ms_mod mod)+ else ppr (GHC.ms_mod mod)+ <+> parens (text $ normalise $ msObjFilePath mod)+ -- Fix #9887++-- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors+-- and printing 'throwE' strings to 'stderr'+runExceptGhcMonad :: GHC.GhcMonad m => ExceptT SDoc m () -> m ()+runExceptGhcMonad act = handleSourceError GHC.printException $+ either handleErr pure =<<+ runExceptT act+ where+ handleErr sdoc = do+ dflags <- getDynFlags+ liftIO . hPutStrLn stderr . showSDocForUser dflags alwaysQualify $ sdoc++-- | Inverse of 'runExceptT' for \"pure\" computations+-- (c.f. 'except' for 'Except')+exceptT :: Applicative m => Either e a -> ExceptT e m a+exceptT = ExceptT . pure++makeHDL' :: Clash.Backend.Backend backend+ => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)+ -> IORef ClashOpts+ -> [FilePath]+ -> InputT GHCi ()+makeHDL' backend opts lst = makeHDL backend opts =<< case lst of+ srcs@(_:_) -> return srcs+ [] -> do+ modGraph <- GHC.getModuleGraph+ let sortedGraph = GHC.topSortModuleGraph False modGraph Nothing+ return $ case (reverse sortedGraph) of+ ((AcyclicSCC top) : _) -> maybeToList $ (GHC.ml_hs_file . GHC.ms_location) top+ _ -> []++makeHDL :: GHC.GhcMonad m+ => Clash.Backend.Backend backend+ => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)+ -> IORef ClashOpts+ -> [FilePath]+ -> m ()+makeHDL backend optsRef srcs = do+ dflags <- GHC.getSessionDynFlags+ liftIO $ do startTime <- Clock.getCurrentTime+ opts0 <- readIORef optsRef+ let opts1 = opts0 { opt_color = useColor dflags }+ let iw = opt_intWidth opts1+ fp = opt_floatSupport opts1+ syn = opt_hdlSyn opts1+ color = opt_color opts1+ esc = opt_escapedIds opts1+ frcUdf = opt_forceUndefined opts1+ hdl = Clash.Backend.hdlKind backend'+ -- determine whether `-outputdir` was used+ outputDir = do odir <- objectDir dflags+ hidir <- hiDir dflags+ sdir <- stubDir dflags+ ddir <- dumpDir dflags+ if all (== odir) [hidir,sdir,ddir]+ then Just odir+ else Nothing+ idirs = importPaths dflags+ opts2 = opts1 { opt_hdlDir = maybe outputDir Just (opt_hdlDir opts1)+ , opt_importPaths = idirs}+ backend' = backend iw syn esc frcUdf++ checkMonoLocalBinds dflags+ checkImportDirs opts0 idirs++ primDirs <- Clash.Backend.primDirs backend'++ forM_ srcs $ \src -> do+ -- Generate bindings:+ let dbs = reverse [p | PackageDB (PkgConfFile p) <- packageDBFlags dflags]+ (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs) <-+ generateBindings color primDirs idirs dbs hdl src (Just dflags)+ prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime+ let prepStartDiff = reportTimeDiff prepTime startTime+ putStrLn $ "GHC+Clash: Loading modules cumulatively took " ++ prepStartDiff++ -- Generate HDL:+ Clash.Driver.generateHDL+ (buildCustomReprs reprs)+ bindingsMap+ (Just backend')+ primMap+ tcm+ tupTcm+ (ghcTypeToHWType iw fp)+ reduceConstant+ topEntities+ opts2+ (startTime,prepTime)++makeVHDL :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeVHDL = makeHDL' (Clash.Backend.initBackend @VHDLState)++makeVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeVerilog = makeHDL' (Clash.Backend.initBackend @VerilogState)++makeSystemVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeSystemVerilog = makeHDL' (Clash.Backend.initBackend @SystemVerilogState)++-----------------------------------------------------------------------------+-- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.++typeOfExpr :: String -> InputT GHCi ()+typeOfExpr str = handleSourceError GHC.printException $ do+ let (mode, expr_str) = case break isSpace str of+ ("+d", rest) -> (GHC.TM_Default, dropWhile isSpace rest)+ ("+v", rest) -> (GHC.TM_NoInst, dropWhile isSpace rest)+ _ -> (GHC.TM_Inst, str)+ ty <- GHC.exprType mode expr_str+ printForUser $ sep [text expr_str, nest 2 (dcolon <+> pprTypeForUser ty)]++-----------------------------------------------------------------------------+-- | @:type-at@ command++typeAtCmd :: String -> InputT GHCi ()+typeAtCmd str = runExceptGhcMonad $ do+ (span',sample) <- exceptT $ parseSpanArg str+ infos <- mod_infos <$> getGHCiState+ (info, ty) <- findType infos span' sample+ lift $ printForUserModInfo (modinfoInfo info)+ (sep [text sample,nest 2 (dcolon <+> ppr ty)])++-----------------------------------------------------------------------------+-- | @:uses@ command++usesCmd :: String -> InputT GHCi ()+usesCmd str = runExceptGhcMonad $ do+ (span',sample) <- exceptT $ parseSpanArg str+ infos <- mod_infos <$> getGHCiState+ uses <- findNameUses infos span' sample+ forM_ uses (liftIO . putStrLn . showSrcSpan)++-----------------------------------------------------------------------------+-- | @:loc-at@ command++locAtCmd :: String -> InputT GHCi ()+locAtCmd str = runExceptGhcMonad $ do+ (span',sample) <- exceptT $ parseSpanArg str+ infos <- mod_infos <$> getGHCiState+ (_,_,sp) <- findLoc infos span' sample+ liftIO . putStrLn . showSrcSpan $ sp++-----------------------------------------------------------------------------+-- | @:all-types@ command++allTypesCmd :: String -> InputT GHCi ()+allTypesCmd _ = runExceptGhcMonad $ do+ infos <- mod_infos <$> getGHCiState+ forM_ (M.elems infos) $ \mi ->+ forM_ (modinfoSpans mi) (lift . printSpan)+ where+ printSpan span'+ | Just ty <- spaninfoType span' = do+ df <- getDynFlags+ let tyInfo = unwords . words $+ showSDocForUser df alwaysQualify (pprTypeForUser ty)+ liftIO . putStrLn $+ showRealSrcSpan (spaninfoSrcSpan span') ++ ": " ++ tyInfo+ | otherwise = return ()++-----------------------------------------------------------------------------+-- Helpers for locAtCmd/typeAtCmd/usesCmd++-- | Parse a span: <module-name/filepath> <sl> <sc> <el> <ec> <string>+parseSpanArg :: String -> Either SDoc (RealSrcSpan,String)+parseSpanArg s = do+ (fp,s0) <- readAsString (skipWs s)+ s0' <- skipWs1 s0+ (sl,s1) <- readAsInt s0'+ s1' <- skipWs1 s1+ (sc,s2) <- readAsInt s1'+ s2' <- skipWs1 s2+ (el,s3) <- readAsInt s2'+ s3' <- skipWs1 s3+ (ec,s4) <- readAsInt s3'++ trailer <- case s4 of+ [] -> Right ""+ _ -> skipWs1 s4++ let fs = mkFastString fp+ span' = mkRealSrcSpan (mkRealSrcLoc fs sl sc)+ (mkRealSrcLoc fs el ec)++ return (span',trailer)+ where+ readAsInt :: String -> Either SDoc (Int,String)+ readAsInt "" = Left "Premature end of string while expecting Int"+ readAsInt s0 = case reads s0 of+ [s_rest] -> Right s_rest+ _ -> Left ("Couldn't read" <+> text (show s0) <+> "as Int")++ readAsString :: String -> Either SDoc (String,String)+ readAsString s0+ | '"':_ <- s0 = case reads s0 of+ [s_rest] -> Right s_rest+ _ -> leftRes+ | s_rest@(_:_,_) <- breakWs s0 = Right s_rest+ | otherwise = leftRes+ where+ leftRes = Left ("Couldn't read" <+> text (show s0) <+> "as String")++ skipWs1 :: String -> Either SDoc String+ skipWs1 (c:cs) | isWs c = Right (skipWs cs)+ skipWs1 s0 = Left ("Expected whitespace in" <+> text (show s0))++ isWs = (`elem` [' ','\t'])+ skipWs = dropWhile isWs+ breakWs = break isWs+++-- | Pretty-print \"real\" 'SrcSpan's as+-- @<filename>:(<line>,<col>)-(<line-end>,<col-end>)@+-- while simply unpacking 'UnhelpfulSpan's+showSrcSpan :: SrcSpan -> String+showSrcSpan (UnhelpfulSpan s) = unpackFS s+showSrcSpan (RealSrcSpan spn) = showRealSrcSpan spn++-- | Variant of 'showSrcSpan' for 'RealSrcSpan's+showRealSrcSpan :: RealSrcSpan -> String+showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc+ , ")-(", show el, ",", show ec, ")"+ ]+ where+ fp = unpackFS (srcSpanFile spn)+ sl = srcSpanStartLine spn+ sc = srcSpanStartCol spn+ el = srcSpanEndLine spn+ ec = srcSpanEndCol spn++-----------------------------------------------------------------------------+-- | @:kind@ command++kindOfType :: Bool -> String -> InputT GHCi ()+kindOfType norm str = handleSourceError GHC.printException $ do+ (ty, kind) <- GHC.typeKind norm str+ printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind+ , ppWhen norm $ equals <+> pprTypeForUser ty ]++-----------------------------------------------------------------------------+-- :quit++quit :: String -> InputT GHCi Bool+quit _ = return True+++-----------------------------------------------------------------------------+-- :script++-- running a script file #1363++scriptCmd :: String -> InputT GHCi ()+scriptCmd ws = do+ case words ws of+ [s] -> runScript s+ _ -> throwGhcException (CmdLineError "syntax: :script <filename>")++runScript :: String -- ^ filename+ -> InputT GHCi ()+runScript filename = do+ filename' <- expandPath filename+ either_script <- liftIO $ tryIO (openFile filename' ReadMode)+ case either_script of+ Left _err -> throwGhcException (CmdLineError $ "IO error: \""++filename++"\" "+ ++(ioeGetErrorString _err))+ Right script -> do+ st <- getGHCiState+ let prog = progname st+ line = line_number st+ setGHCiState st{progname=filename',line_number=0}+ scriptLoop script+ liftIO $ hClose script+ new_st <- getGHCiState+ setGHCiState new_st{progname=prog,line_number=line}+ where scriptLoop script = do+ res <- runOneCommand handler $ fileLoop script+ case res of+ Nothing -> return ()+ Just s -> if s+ then scriptLoop script+ else return ()++-----------------------------------------------------------------------------+-- :issafe++-- Displaying Safe Haskell properties of a module++isSafeCmd :: String -> InputT GHCi ()+isSafeCmd m =+ case words m of+ [s] | looksLikeModuleName s -> do+ md <- lift $ lookupModule s+ isSafeModule md+ [] -> do md <- guessCurrentModule "issafe"+ isSafeModule md+ _ -> throwGhcException (CmdLineError "syntax: :issafe <module>")++isSafeModule :: Module -> InputT GHCi ()+isSafeModule m = do+ mb_mod_info <- GHC.getModuleInfo m+ when (isNothing mb_mod_info)+ (throwGhcException $ CmdLineError $ "unknown module: " ++ mname)++ dflags <- getDynFlags+ let iface = GHC.modInfoIface $ fromJust mb_mod_info+ when (isNothing iface)+ (throwGhcException $ CmdLineError $ "can't load interface file for module: " +++ (GHC.moduleNameString $ GHC.moduleName m))++ (msafe, pkgs) <- GHC.moduleTrustReqs m+ let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface+ pkg = if packageTrusted dflags m then "trusted" else "untrusted"+ (good, bad) = tallyPkgs dflags pkgs++ -- print info to user...+ liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"+ liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")+ when (not $ S.null good)+ (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " +++ (intercalate ", " $ map (showPpr dflags) (S.toList good)))+ case msafe && S.null bad of+ True -> liftIO $ putStrLn $ mname ++ " is trusted!"+ False -> do+ when (not $ null bad)+ (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "+ ++ (intercalate ", " $ map (showPpr dflags) (S.toList bad)))+ liftIO $ putStrLn $ mname ++ " is NOT trusted!"++ where+ mname = GHC.moduleNameString $ GHC.moduleName m++ packageTrusted dflags md+ | thisPackage dflags == moduleUnitId md = True+ | otherwise = trusted $ getPackageDetails dflags (moduleUnitId md)++ tallyPkgs dflags deps | not (packageTrustOn dflags) = (S.empty, S.empty)+ | otherwise = S.partition part deps+ where part pkg = trusted $ getInstalledPackageDetails dflags pkg++-----------------------------------------------------------------------------+-- :browse++-- Browsing a module's contents++browseCmd :: Bool -> String -> InputT GHCi ()+browseCmd bang m =+ case words m of+ ['*':s] | looksLikeModuleName s -> do+ md <- lift $ wantInterpretedModule s+ browseModule bang md False+ [s] | looksLikeModuleName s -> do+ md <- lift $ lookupModule s+ browseModule bang md True+ [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")+ browseModule bang md True+ _ -> throwGhcException (CmdLineError "syntax: :browse <module>")++guessCurrentModule :: String -> InputT GHCi Module+-- Guess which module the user wants to browse. Pick+-- modules that are interpreted first. The most+-- recently-added module occurs last, it seems.+guessCurrentModule cmd+ = do imports <- GHC.getContext+ when (null imports) $ throwGhcException $+ CmdLineError (':' : cmd ++ ": no current module")+ case (head imports) of+ IIModule m -> GHC.findModule m Nothing+ IIDecl d -> GHC.findModule (unLoc (ideclName d))+ (fmap sl_fs $ ideclPkgQual d)++-- without bang, show items in context of their parents and omit children+-- with bang, show class methods and data constructors separately, and+-- indicate import modules, to aid qualifying unqualified names+-- with sorted, sort items alphabetically+browseModule :: Bool -> Module -> Bool -> InputT GHCi ()+browseModule bang modl exports_only = do+ -- :browse reports qualifiers wrt current context+ unqual <- GHC.getPrintUnqual++ mb_mod_info <- GHC.getModuleInfo modl+ case mb_mod_info of+ Nothing -> throwGhcException (CmdLineError ("unknown module: " +++ GHC.moduleNameString (GHC.moduleName modl)))+ Just mod_info -> do+ dflags <- getDynFlags+ let names+ | exports_only = GHC.modInfoExports mod_info+ | otherwise = GHC.modInfoTopLevelScope mod_info+ `orElse` []++ -- sort alphabetically name, but putting locally-defined+ -- identifiers first. We would like to improve this; see #1799.+ sorted_names = loc_sort local ++ occ_sort external+ where+ (local,external) = ASSERT( all isExternalName names )+ partition ((==modl) . nameModule) names+ occ_sort = sortBy (compare `on` nameOccName)+ -- try to sort by src location. If the first name in our list+ -- has a good source location, then they all should.+ loc_sort ns+ | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n)+ = sortBy (compare `on` nameSrcSpan) ns+ | otherwise+ = occ_sort ns++ mb_things <- mapM GHC.lookupName sorted_names+ let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)++ rdr_env <- GHC.getGRE++ let things | bang = catMaybes mb_things+ | otherwise = filtered_things+ pretty | bang = pprTyThing showToHeader+ | otherwise = pprTyThingInContext showToHeader++ labels [] = text "-- not currently imported"+ labels l = text $ intercalate "\n" $ map qualifier l++ qualifier :: Maybe [ModuleName] -> String+ qualifier = maybe "-- defined locally"+ (("-- imported via "++) . intercalate ", "+ . map GHC.moduleNameString)+ importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env++ modNames :: [[Maybe [ModuleName]]]+ modNames = map (importInfo . GHC.getName) things++ -- annotate groups of imports with their import modules+ -- the default ordering is somewhat arbitrary, so we group+ -- by header and sort groups; the names themselves should+ -- really come in order of source appearance.. (trac #1799)+ annotate mts = concatMap (\(m,ts)->labels m:ts)+ $ sortBy cmpQualifiers $ grp mts+ where cmpQualifiers =+ compare `on` (map (fmap (map moduleNameFS)) . fst)+ grp [] = []+ grp mts@((m,_):_) = (m,map snd g) : grp ng+ where (g,ng) = partition ((==m).fst) mts++ let prettyThings, prettyThings' :: [SDoc]+ prettyThings = map pretty things+ prettyThings' | bang = annotate $ zip modNames prettyThings+ | otherwise = prettyThings+ liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings')+ -- ToDo: modInfoInstances currently throws an exception for+ -- package modules. When it works, we can do this:+ -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))+++-----------------------------------------------------------------------------+-- :module++-- Setting the module context. For details on context handling see+-- "remembered_ctx" and "transient_ctx" in GhciMonad.++moduleCmd :: String -> GHCi ()+moduleCmd str+ | all sensible strs = cmd+ | otherwise = throwGhcException (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")+ where+ (cmd, strs) =+ case str of+ '+':stuff -> rest addModulesToContext stuff+ '-':stuff -> rest remModulesFromContext stuff+ stuff -> rest setContext stuff++ rest op stuff = (op as bs, stuffs)+ where (as,bs) = partitionWith starred stuffs+ stuffs = words stuff++ sensible ('*':m) = looksLikeModuleName m+ sensible m = looksLikeModuleName m++ starred ('*':m) = Left (GHC.mkModuleName m)+ starred m = Right (GHC.mkModuleName m)+++-- -----------------------------------------------------------------------------+-- Four ways to manipulate the context:+-- (a) :module +<stuff>: addModulesToContext+-- (b) :module -<stuff>: remModulesFromContext+-- (c) :module <stuff>: setContext+-- (d) import <module>...: addImportToContext++addModulesToContext :: [ModuleName] -> [ModuleName] -> GHCi ()+addModulesToContext starred unstarred = restoreContextOnFailure $ do+ addModulesToContext_ starred unstarred++addModulesToContext_ :: [ModuleName] -> [ModuleName] -> GHCi ()+addModulesToContext_ starred unstarred = do+ mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)+ setGHCContextFromGHCiState++remModulesFromContext :: [ModuleName] -> [ModuleName] -> GHCi ()+remModulesFromContext starred unstarred = do+ -- we do *not* call restoreContextOnFailure here. If the user+ -- is trying to fix up a context that contains errors by removing+ -- modules, we don't want GHC to silently put them back in again.+ mapM_ rm (starred ++ unstarred)+ setGHCContextFromGHCiState+ where+ rm :: ModuleName -> GHCi ()+ rm str = do+ m <- moduleName <$> lookupModuleName str+ let filt = filter ((/=) m . iiModuleName)+ modifyGHCiState $ \st ->+ st { remembered_ctx = filt (remembered_ctx st)+ , transient_ctx = filt (transient_ctx st) }++setContext :: [ModuleName] -> [ModuleName] -> GHCi ()+setContext starred unstarred = restoreContextOnFailure $ do+ modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }+ -- delete the transient context+ addModulesToContext_ starred unstarred++addImportToContext :: String -> GHCi ()+addImportToContext str = restoreContextOnFailure $ do+ idecl <- GHC.parseImportDecl str+ addII (IIDecl idecl) -- #5836+ setGHCContextFromGHCiState++-- Util used by addImportToContext and addModulesToContext+addII :: InteractiveImport -> GHCi ()+addII iidecl = do+ checkAdd iidecl+ modifyGHCiState $ \st ->+ st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st)+ , transient_ctx = filter (not . (iidecl `iiSubsumes`))+ (transient_ctx st)+ }++-- Sometimes we can't tell whether an import is valid or not until+-- we finally call 'GHC.setContext'. e.g.+--+-- import System.IO (foo)+--+-- will fail because System.IO does not export foo. In this case we+-- don't want to store the import in the context permanently, so we+-- catch the failure from 'setGHCContextFromGHCiState' and set the+-- context back to what it was.+--+-- See #6007+--+restoreContextOnFailure :: GHCi a -> GHCi a+restoreContextOnFailure do_this = do+ st <- getGHCiState+ let rc = remembered_ctx st; tc = transient_ctx st+ do_this `gonException` (modifyGHCiState $ \st' ->+ st' { remembered_ctx = rc, transient_ctx = tc })++-- -----------------------------------------------------------------------------+-- Validate a module that we want to add to the context++checkAdd :: InteractiveImport -> GHCi ()+checkAdd ii = do+ dflags <- getDynFlags+ let safe = safeLanguageOn dflags+ case ii of+ IIModule modname+ | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"+ | otherwise -> wantInterpretedModuleName modname >> return ()++ IIDecl d -> do+ let modname = unLoc (ideclName d)+ pkgqual = ideclPkgQual d+ m <- GHC.lookupModule modname (fmap sl_fs pkgqual)+ when safe $ do+ t <- GHC.isModuleTrusted m+ when (not t) $ throwGhcException $ ProgramError $ ""++-- -----------------------------------------------------------------------------+-- Update the GHC API's view of the context++-- | Sets the GHC context from the GHCi state. The GHC context is+-- always set this way, we never modify it incrementally.+--+-- We ignore any imports for which the ModuleName does not currently+-- exist. This is so that the remembered_ctx can contain imports for+-- modules that are not currently loaded, perhaps because we just did+-- a :reload and encountered errors.+--+-- Prelude is added if not already present in the list. Therefore to+-- override the implicit Prelude import you can say 'import Prelude ()'+-- at the prompt, just as in Haskell source.+--+setGHCContextFromGHCiState :: GHCi ()+setGHCContextFromGHCiState = do+ st <- getGHCiState+ -- re-use checkAdd to check whether the module is valid. If the+ -- module does not exist, we do *not* want to print an error+ -- here, we just want to silently keep the module in the context+ -- until such time as the module reappears again. So we ignore+ -- the actual exception thrown by checkAdd, using tryBool to+ -- turn it into a Bool.+ iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st)++ prel_iidecls <- getImplicitPreludeImports iidecls+ valid_prel_iidecls <- filterM (tryBool . checkAdd) prel_iidecls++ extra_imports <- filterM (tryBool . checkAdd) (map IIDecl (extra_imports st))++ GHC.setContext $ iidecls ++ extra_imports ++ valid_prel_iidecls+++getImplicitPreludeImports :: [InteractiveImport] -> GHCi [InteractiveImport]+getImplicitPreludeImports iidecls = do+ -- allow :seti to override -XNoImplicitPrelude+ st <- getGHCiState++ -- We add the prelude imports if there are no *-imports, and we also+ -- allow each prelude import to be subsumed by another explicit import+ -- of the same module. This means that you can override the prelude import+ -- with "import Prelude hiding (map)", for example.+ let prel_iidecls =+ if not (any isIIModule iidecls)+ then [ IIDecl imp+ | imp <- prelude_imports st+ , not (any (sameImpModule imp) iidecls) ]+ else []++ return prel_iidecls++-- -----------------------------------------------------------------------------+-- Utils on InteractiveImport++mkIIModule :: ModuleName -> InteractiveImport+mkIIModule = IIModule++mkIIDecl :: ModuleName -> InteractiveImport+mkIIDecl = IIDecl . simpleImportDecl++iiModules :: [InteractiveImport] -> [ModuleName]+iiModules is = [m | IIModule m <- is]++isIIModule :: InteractiveImport -> Bool+isIIModule (IIModule _) = True+isIIModule _ = False++iiModuleName :: InteractiveImport -> ModuleName+iiModuleName (IIModule m) = m+iiModuleName (IIDecl d) = unLoc (ideclName d)++preludeModuleName :: ModuleName+preludeModuleName = GHC.mkModuleName "Clash.Prelude"++sameImpModule :: ImportDecl GhcPs -> InteractiveImport -> Bool+sameImpModule _ (IIModule _) = False -- we only care about imports here+sameImpModule imp (IIDecl d) = unLoc (ideclName d) == unLoc (ideclName imp)++addNotSubsumed :: InteractiveImport+ -> [InteractiveImport] -> [InteractiveImport]+addNotSubsumed i is+ | any (`iiSubsumes` i) is = is+ | otherwise = i : filter (not . (i `iiSubsumes`)) is++-- | @filterSubsumed is js@ returns the elements of @js@ not subsumed+-- by any of @is@.+filterSubsumed :: [InteractiveImport] -> [InteractiveImport]+ -> [InteractiveImport]+filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js++-- | Returns True if the left import subsumes the right one. Doesn't+-- need to be 100% accurate, conservatively returning False is fine.+-- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in+-- plusProv will ensue (#5904))+--+-- Note that an IIModule does not necessarily subsume an IIDecl,+-- because e.g. a module might export a name that is only available+-- qualified within the module itself.+--+-- Note that 'import M' does not necessarily subsume 'import M(foo)',+-- because M might not export foo and we want an error to be produced+-- in that case.+--+iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool+iiSubsumes (IIModule m1) (IIModule m2) = m1==m2+iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude+ = unLoc (ideclName d1) == unLoc (ideclName d2)+ && ideclAs d1 == ideclAs d2+ && (not (ideclQualified d1) || ideclQualified d2)+ && (ideclHiding d1 `hidingSubsumes` ideclHiding d2)+ where+ _ `hidingSubsumes` Just (False,L _ []) = True+ Just (False, L _ xs) `hidingSubsumes` Just (False,L _ ys)+ = all (`elem` xs) ys+ h1 `hidingSubsumes` h2 = h1 == h2+iiSubsumes _ _ = False+++----------------------------------------------------------------------------+-- :set++-- set options in the interpreter. Syntax is exactly the same as the+-- ghc command line, except that certain options aren't available (-C,+-- -E etc.)+--+-- This is pretty fragile: most options won't work as expected. ToDo:+-- figure out which ones & disallow them.++setCmd :: String -> GHCi ()+setCmd "" = showOptions False+setCmd "-a" = showOptions True+setCmd str+ = case getCmd str of+ Right ("args", rest) ->+ case toArgs rest of+ Left err -> liftIO (hPutStrLn stderr err)+ Right args -> setArgs args+ Right ("prog", rest) ->+ case toArgs rest of+ Right [prog] -> setProg prog+ _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")++ Right ("prompt", rest) ->+ setPromptString setPrompt (dropWhile isSpace rest)+ "syntax: set prompt <string>"+ Right ("prompt-function", rest) ->+ setPromptFunc setPrompt $ dropWhile isSpace rest+ Right ("prompt-cont", rest) ->+ setPromptString setPromptCont (dropWhile isSpace rest)+ "syntax: :set prompt-cont <string>"+ Right ("prompt-cont-function", rest) ->+ setPromptFunc setPromptCont $ dropWhile isSpace rest++ Right ("editor", rest) -> setEditor $ dropWhile isSpace rest+ Right ("stop", rest) -> setStop $ dropWhile isSpace rest+ _ -> case toArgs str of+ Left err -> liftIO (hPutStrLn stderr err)+ Right wds -> setOptions wds++setiCmd :: String -> GHCi ()+setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False+setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True+setiCmd str =+ case toArgs str of+ Left err -> liftIO (hPutStrLn stderr err)+ Right wds -> newDynFlags True wds++showOptions :: Bool -> GHCi ()+showOptions show_all+ = do st <- getGHCiState+ dflags <- getDynFlags+ let opts = options st+ liftIO $ putStrLn (showSDoc dflags (+ text "options currently set: " <>+ if null opts+ then text "none."+ else hsep (map (\o -> char '+' <> text (optToStr o)) opts)+ ))+ getDynFlags >>= liftIO . showDynFlags show_all+++showDynFlags :: Bool -> DynFlags -> IO ()+showDynFlags show_all dflags = do+ showLanguages' show_all dflags+ putStrLn $ showSDoc dflags $+ text "GHCi-specific dynamic flag settings:" $$+ nest 2 (vcat (map (setting "-f" "-fno-" gopt) ghciFlags))+ putStrLn $ showSDoc dflags $+ text "other dynamic, non-language, flag settings:" $$+ nest 2 (vcat (map (setting "-f" "-fno-" gopt) others))+ putStrLn $ showSDoc dflags $+ text "warning settings:" $$+ nest 2 (vcat (map (setting "-W" "-Wno-" wopt) DynFlags.wWarningFlags))+ where+ setting prefix noPrefix test flag+ | quiet = empty+ | is_on = text prefix <> text name+ | otherwise = text noPrefix <> text name+ where name = flagSpecName flag+ f = flagSpecFlag flag+ is_on = test f dflags+ quiet = not show_all && test f default_dflags == is_on++ llvmConfig = (llvmTargets dflags, llvmPasses dflags)++ default_dflags = defaultDynFlags (settings dflags) llvmConfig++ (ghciFlags,others) = partition (\f -> flagSpecFlag f `elem` flgs)+ DynFlags.fFlags+ flgs = [ Opt_PrintExplicitForalls+ , Opt_PrintExplicitKinds+ , Opt_PrintUnicodeSyntax+ , Opt_PrintBindResult+ , Opt_BreakOnException+ , Opt_BreakOnError+ , Opt_PrintEvldWithShow+ ]++setArgs, setOptions :: [String] -> GHCi ()+setProg, setEditor, setStop :: String -> GHCi ()++setArgs args = do+ st <- getGHCiState+ wrapper <- mkEvalWrapper (progname st) args+ setGHCiState st { GhciMonad.args = args, evalWrapper = wrapper }++setProg prog = do+ st <- getGHCiState+ wrapper <- mkEvalWrapper prog (GhciMonad.args st)+ setGHCiState st { progname = prog, evalWrapper = wrapper }++setEditor cmd = modifyGHCiState (\st -> st { editor = cmd })++setStop str@(c:_) | isDigit c+ = do let (nm_str,rest) = break (not.isDigit) str+ nm = read nm_str+ st <- getGHCiState+ let old_breaks = breaks st+ if all ((/= nm) . fst) old_breaks+ then printForUser (text "Breakpoint" <+> ppr nm <+>+ text "does not exist")+ else do+ let new_breaks = map fn old_breaks+ fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })+ | otherwise = (i,loc)+ setGHCiState st{ breaks = new_breaks }+setStop cmd = modifyGHCiState (\st -> st { stop = cmd })++setPrompt :: PromptFunction -> GHCi ()+setPrompt v = modifyGHCiState (\st -> st {prompt = v})++setPromptCont :: PromptFunction -> GHCi ()+setPromptCont v = modifyGHCiState (\st -> st {prompt_cont = v})++setPromptFunc :: (PromptFunction -> GHCi ()) -> String -> GHCi ()+setPromptFunc fSetPrompt s = do+ -- We explicitly annotate the type of the expression to ensure+ -- that unsafeCoerce# is passed the exact type necessary rather+ -- than a more general one+ let exprStr = "(" ++ s ++ ") :: [String] -> Int -> IO String"+ (HValue funValue) <- GHC.compileExpr exprStr+ fSetPrompt (convertToPromptFunction $ unsafeCoerce funValue)+ where+ convertToPromptFunction :: ([String] -> Int -> IO String)+ -> PromptFunction+ convertToPromptFunction func = (\mods line -> liftIO $+ liftM text (func mods line))++setPromptString :: (PromptFunction -> GHCi ()) -> String -> String -> GHCi ()+setPromptString fSetPrompt value err = do+ if null value+ then liftIO $ hPutStrLn stderr $ err+ else case value of+ ('\"':_) ->+ case reads value of+ [(value', xs)] | all isSpace xs ->+ setParsedPromptString fSetPrompt value'+ _ -> liftIO $ hPutStrLn stderr+ "Can't parse prompt string. Use Haskell syntax."+ _ ->+ setParsedPromptString fSetPrompt value++setParsedPromptString :: (PromptFunction -> GHCi ()) -> String -> GHCi ()+setParsedPromptString fSetPrompt s = do+ case (checkPromptStringForErrors s) of+ Just err ->+ liftIO $ hPutStrLn stderr err+ Nothing ->+ fSetPrompt $ generatePromptFunctionFromString s++setOptions wds =+ do -- first, deal with the GHCi opts (+s, +t, etc.)+ let (plus_opts, minus_opts) = partitionWith isPlus wds+ mapM_ setOpt plus_opts+ -- then, dynamic flags+ when (not (null minus_opts)) $ newDynFlags False minus_opts++newDynFlags :: Bool -> [String] -> GHCi ()+newDynFlags interactive_only minus_opts = do+ let lopts = map noLoc minus_opts++ idflags0 <- GHC.getInteractiveDynFlags+ (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts++ liftIO $ handleFlagWarnings idflags1 warns+ when (not $ null leftovers)+ (throwGhcException . CmdLineError+ $ "Some flags have not been recognized: "+ ++ (concat . intersperse ", " $ map unLoc leftovers))++ when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do+ liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"+ -- Load any new plugins+ hsc_env0 <- GHC.getSession+ idflags2 <- liftIO (initializePlugins hsc_env0 idflags1)+ GHC.setInteractiveDynFlags idflags2+ installInteractivePrint (interactivePrint idflags1) False++ dflags0 <- getDynFlags++ when (not interactive_only) $ do+ (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts+ new_pkgs <- GHC.setProgramDynFlags dflags1++ -- if the package flags changed, reset the context and link+ -- the new packages.+ hsc_env <- GHC.getSession+ let dflags2 = hsc_dflags hsc_env+ when (packageFlagsChanged dflags2 dflags0) $ do+ when (verbosity dflags2 > 0) $+ liftIO . putStrLn $+ "package flags have changed, resetting and loading new packages..."+ GHC.setTargets []+ _ <- GHC.load LoadAllTargets+ liftIO $ linkPackages hsc_env new_pkgs+ -- package flags changed, we can't re-use any of the old context+ setContextAfterLoad False []+ -- and copy the package state to the interactive DynFlags+ idflags <- GHC.getInteractiveDynFlags+ GHC.setInteractiveDynFlags+ idflags{ pkgState = pkgState dflags2+ , pkgDatabase = pkgDatabase dflags2+ , packageFlags = packageFlags dflags2 }++ let ld0length = length $ ldInputs dflags0+ fmrk0length = length $ cmdlineFrameworks dflags0++ newLdInputs = drop ld0length (ldInputs dflags2)+ newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)++ hsc_env' = hsc_env { hsc_dflags =+ dflags2 { ldInputs = newLdInputs+ , cmdlineFrameworks = newCLFrameworks } }++ when (not (null newLdInputs && null newCLFrameworks)) $+ liftIO $ linkCmdLineLibs hsc_env'++ return ()+++unsetOptions :: String -> GHCi ()+unsetOptions str+ = -- first, deal with the GHCi opts (+s, +t, etc.)+ let opts = words str+ (minus_opts, rest1) = partition isMinus opts+ (plus_opts, rest2) = partitionWith isPlus rest1+ (other_opts, rest3) = partition (`elem` map fst defaulters) rest2++ defaulters =+ [ ("args" , setArgs default_args)+ , ("prog" , setProg default_progname)+ , ("prompt" , setPrompt default_prompt)+ , ("prompt-cont", setPromptCont default_prompt_cont)+ , ("editor" , liftIO findEditor >>= setEditor)+ , ("stop" , setStop default_stop)+ ]++ no_flag ('-':'f':rest) = return ("-fno-" ++ rest)+ no_flag ('-':'X':rest) = return ("-XNo" ++ rest)+ no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f))++ in if (not (null rest3))+ then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))+ else do+ mapM_ (fromJust.flip lookup defaulters) other_opts++ mapM_ unsetOpt plus_opts++ no_flags <- mapM no_flag minus_opts+ when (not (null no_flags)) $ newDynFlags False no_flags++isMinus :: String -> Bool+isMinus ('-':_) = True+isMinus _ = False++isPlus :: String -> Either String String+isPlus ('+':opt) = Left opt+isPlus other = Right other++setOpt, unsetOpt :: String -> GHCi ()++setOpt str+ = case strToGHCiOpt str of+ Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))+ Just o -> setOption o++unsetOpt str+ = case strToGHCiOpt str of+ Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))+ Just o -> unsetOption o++strToGHCiOpt :: String -> (Maybe GHCiOption)+strToGHCiOpt "m" = Just Multiline+strToGHCiOpt "s" = Just ShowTiming+strToGHCiOpt "t" = Just ShowType+strToGHCiOpt "r" = Just RevertCAFs+strToGHCiOpt "c" = Just CollectInfo+strToGHCiOpt _ = Nothing++optToStr :: GHCiOption -> String+optToStr Multiline = "m"+optToStr ShowTiming = "s"+optToStr ShowType = "t"+optToStr RevertCAFs = "r"+optToStr CollectInfo = "c"+++-- ---------------------------------------------------------------------------+-- :show++showCmd :: String -> GHCi ()+showCmd "" = showOptions False+showCmd "-a" = showOptions True+showCmd str = do+ st <- getGHCiState+ dflags <- getDynFlags++ let lookupCmd :: String -> Maybe (GHCi ())+ lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds++ -- (show in help?, command name, action)+ action :: String -> GHCi () -> (Bool, String, GHCi ())+ action name m = (True, name, m)++ hidden :: String -> GHCi () -> (Bool, String, GHCi ())+ hidden name m = (False, name, m)++ cmds =+ [ action "args" $ liftIO $ putStrLn (show (GhciMonad.args st))+ , action "prog" $ liftIO $ putStrLn (show (progname st))+ , action "editor" $ liftIO $ putStrLn (show (editor st))+ , action "stop" $ liftIO $ putStrLn (show (stop st))+ , action "imports" $ showImports+ , action "modules" $ showModules+ , action "bindings" $ showBindings+ , action "linker" $ getDynFlags >>= liftIO . showLinkerState+ , action "breaks" $ showBkptTable+ , action "context" $ showContext+ , action "packages" $ showPackages+ , action "paths" $ showPaths+ , action "language" $ showLanguages+ , hidden "languages" $ showLanguages -- backwards compat+ , hidden "lang" $ showLanguages -- useful abbreviation+ , action "targets" $ showTargets+ ]++ case words str of+ [w] | Just action <- lookupCmd w -> action++ _ -> let helpCmds = [ text name | (True, name, _) <- cmds ]+ in throwGhcException $ CmdLineError $ showSDoc dflags+ $ hang (text "syntax:") 4+ $ hang (text ":show") 6+ $ brackets (fsep $ punctuate (text " |") helpCmds)++showiCmd :: String -> GHCi ()+showiCmd str = do+ case words str of+ ["languages"] -> showiLanguages -- backwards compat+ ["language"] -> showiLanguages+ ["lang"] -> showiLanguages -- useful abbreviation+ _ -> throwGhcException (CmdLineError ("syntax: :showi language"))++showImports :: GHCi ()+showImports = do+ st <- getGHCiState+ dflags <- getDynFlags+ let rem_ctx = reverse (remembered_ctx st)+ trans_ctx = transient_ctx st++ show_one (IIModule star_m)+ = ":module +*" ++ moduleNameString star_m+ show_one (IIDecl imp) = showPpr dflags imp++ prel_iidecls <- getImplicitPreludeImports (rem_ctx ++ trans_ctx)++ let show_prel p = show_one p ++ " -- implicit"+ show_extra p = show_one (IIDecl p) ++ " -- fixed"++ trans_comment s = s ++ " -- added automatically" :: String+ --+ liftIO $ mapM_ putStrLn (map show_one rem_ctx +++ map (trans_comment . show_one) trans_ctx +++ map show_prel prel_iidecls +++ map show_extra (extra_imports st))++showModules :: GHCi ()+showModules = do+ loaded_mods <- getLoadedModules+ -- we want *loaded* modules only, see #1734+ let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)+ mapM_ show_one loaded_mods++getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]+getLoadedModules = do+ graph <- GHC.getModuleGraph+ filterM (GHC.isLoaded . GHC.ms_mod_name) (GHC.mgModSummaries graph)++showBindings :: GHCi ()+showBindings = do+ bindings <- GHC.getBindings+ (insts, finsts) <- GHC.getInsts+ let idocs = map GHC.pprInstanceHdr insts+ fidocs = map GHC.pprFamInst finsts+ binds = filter (not . isDerivedOccName . getOccName) bindings -- #12525+ -- See Note [Filter bindings]+ docs <- mapM makeDoc (reverse binds)+ -- reverse so the new ones come last+ mapM_ printForUserPartWay (docs ++ idocs ++ fidocs)+ where+ makeDoc (AnId i) = pprTypeAndContents i+ makeDoc tt = do+ mb_stuff <- GHC.getInfo False (getName tt)+ return $ maybe (text "") pprTT mb_stuff++ pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc+ pprTT (thing, fixity, _cls_insts, _fam_insts, _docs)+ = pprTyThing showToHeader thing+ $$ show_fixity+ where+ show_fixity+ | fixity == GHC.defaultFixity = empty+ | otherwise = ppr fixity <+> ppr (GHC.getName thing)+++printTyThing :: TyThing -> GHCi ()+printTyThing tyth = printForUser (pprTyThing showToHeader tyth)++{-+Note [Filter bindings]+~~~~~~~~~~~~~~~~~~~~~~++If we don't filter the bindings returned by the function GHC.getBindings,+then the :show bindings command will also show unwanted bound names,+internally generated by GHC, eg:+ $tcFoo :: GHC.Types.TyCon = _+ $trModule :: GHC.Types.Module = _ .++The filter was introduced as a fix for Trac #12525 [1]. Comment:1 [2] to this+ticket contains an analysis of the situation and suggests the solution+implemented above.++The same filter was also implemented to fix Trac #11051 [3]. See the+Note [What to show to users] in compiler/main/InteractiveEval.hs++[1] https://ghc.haskell.org/trac/ghc/ticket/12525+[2] https://ghc.haskell.org/trac/ghc/ticket/12525#comment:1+[3] https://ghc.haskell.org/trac/ghc/ticket/11051+-}+++showBkptTable :: GHCi ()+showBkptTable = do+ st <- getGHCiState+ printForUser $ prettyLocations (breaks st)++showContext :: GHCi ()+showContext = do+ resumes <- GHC.getResumeContext+ printForUser $ vcat (map pp_resume (reverse resumes))+ where+ pp_resume res =+ ptext (sLit "--> ") <> text (GHC.resumeStmt res)+ $$ nest 2 (pprStopped res)++pprStopped :: GHC.Resume -> SDoc+pprStopped res =+ ptext (sLit "Stopped in")+ <+> ((case mb_mod_name of+ Nothing -> empty+ Just mod_name -> text (moduleNameString mod_name) <> char '.')+ <> text (GHC.resumeDecl res))+ <> char ',' <+> ppr (GHC.resumeSpan res)+ where+ mb_mod_name = moduleName <$> GHC.breakInfo_module <$> GHC.resumeBreakInfo res++showPackages :: GHCi ()+showPackages = do+ dflags <- getDynFlags+ let pkg_flags = packageFlags dflags+ liftIO $ putStrLn $ showSDoc dflags $+ text ("active package flags:"++if null pkg_flags then " none" else "") $$+ nest 2 (vcat (map pprFlag pkg_flags))++showPaths :: GHCi ()+showPaths = do+ dflags <- getDynFlags+ liftIO $ do+ cwd <- getCurrentDirectory+ putStrLn $ showSDoc dflags $+ text "current working directory: " $$+ nest 2 (text cwd)+ let ipaths = importPaths dflags+ putStrLn $ showSDoc dflags $+ text ("module import search paths:"++if null ipaths then " none" else "") $$+ nest 2 (vcat (map text ipaths))++showLanguages :: GHCi ()+showLanguages = getDynFlags >>= liftIO . showLanguages' False++showiLanguages :: GHCi ()+showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False++showLanguages' :: Bool -> DynFlags -> IO ()+showLanguages' show_all dflags =+ putStrLn $ showSDoc dflags $ vcat+ [ text "base language is: " <>+ case language dflags of+ Nothing -> text "Haskell2010"+ Just Haskell98 -> text "Haskell98"+ Just Haskell2010 -> text "Haskell2010"+ , (if show_all then text "all active language options:"+ else text "with the following modifiers:") $$+ nest 2 (vcat (map (setting xopt) DynFlags.xFlags))+ ]+ where+ setting test flag+ | quiet = empty+ | is_on = text "-X" <> text name+ | otherwise = text "-XNo" <> text name+ where name = flagSpecName flag+ f = flagSpecFlag flag+ is_on = test f dflags+ quiet = not show_all && test f default_dflags == is_on++ llvmConfig = (llvmTargets dflags, llvmPasses dflags)++ default_dflags =+ defaultDynFlags (settings dflags) llvmConfig `lang_set`+ case language dflags of+ Nothing -> Just Haskell2010+ other -> other++showTargets :: GHCi ()+showTargets = mapM_ showTarget =<< GHC.getTargets+ where+ showTarget :: Target -> GHCi ()+ showTarget (Target (TargetFile f _) _ _) = liftIO (putStrLn f)+ showTarget (Target (TargetModule m) _ _) =+ liftIO (putStrLn $ moduleNameString m)++-- -----------------------------------------------------------------------------+-- Completion++completeCmd :: String -> GHCi ()+completeCmd argLine0 = case parseLine argLine0 of+ Just ("repl", resultRange, left) -> do+ (unusedLine,compls) <- ghciCompleteWord (reverse left,"")+ let compls' = takeRange resultRange compls+ liftIO . putStrLn $ unwords [ show (length compls'), show (length compls), show (reverse unusedLine) ]+ forM_ (takeRange resultRange compls) $ \(Completion r _ _) -> do+ liftIO $ print r+ _ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>")+ where+ parseLine argLine+ | null argLine = Nothing+ | null rest1 = Nothing+ | otherwise = (,,) dom <$> resRange <*> s+ where+ (dom, rest1) = breakSpace argLine+ (rng, rest2) = breakSpace rest1+ resRange | head rest1 == '"' = parseRange ""+ | otherwise = parseRange rng+ s | head rest1 == '"' = readMaybe rest1 :: Maybe String+ | otherwise = readMaybe rest2+ breakSpace = fmap (dropWhile isSpace) . break isSpace++ takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub++ -- syntax: [n-][m] with semantics "drop (n-1) . take m"+ parseRange :: String -> Maybe (Maybe Int,Maybe Int)+ parseRange s = case span isDigit s of+ (_, "") ->+ -- upper limit only+ Just (Nothing, bndRead s)+ (s1, '-' : s2)+ | all isDigit s2 ->+ Just (bndRead s1, bndRead s2)+ _ ->+ Nothing+ where+ bndRead x = if null x then Nothing else Just (read x)++++completeGhciCommand, completeMacro, completeIdentifier, completeModule,+ completeSetModule, completeSeti, completeShowiOptions,+ completeHomeModule, completeSetOptions, completeShowOptions,+ completeHomeModuleOrFile, completeExpression+ :: CompletionFunc GHCi++-- | Provide completions for last word in a given string.+--+-- Takes a tuple of two strings. First string is a reversed line to be+-- completed. Second string is likely unused, 'completeCmd' always passes an+-- empty string as second item in tuple.+ghciCompleteWord :: CompletionFunc GHCi+ghciCompleteWord line@(left,_) = case firstWord of+ -- If given string starts with `:` colon, and there is only one following+ -- word then provide REPL command completions. If there is more than one+ -- word complete either filename or builtin ghci commands or macros.+ ':':cmd | null rest -> completeGhciCommand line+ | otherwise -> do+ completion <- lookupCompletion cmd+ completion line+ -- If given string starts with `import` keyword provide module name+ -- completions+ "import" -> completeModule line+ -- otherwise provide identifier completions+ _ -> completeExpression line+ where+ (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left+ lookupCompletion ('!':_) = return completeFilename+ lookupCompletion c = do+ maybe_cmd <- lookupCommand' c+ case maybe_cmd of+ Just cmd -> return (cmdCompletionFunc cmd)+ Nothing -> return completeFilename++completeGhciCommand = wrapCompleter " " $ \w -> do+ macros <- ghci_macros <$> getGHCiState+ cmds <- ghci_commands `fmap` getGHCiState+ let macro_names = map (':':) . map cmdName $ macros+ let command_names = map (':':) . map cmdName $ filter (not . cmdHidden) cmds+ let{ candidates = case w of+ ':' : ':' : _ -> map (':':) command_names+ _ -> nub $ macro_names ++ command_names }+ return $ filter (w `isPrefixOf`) candidates++completeMacro = wrapIdentCompleter $ \w -> do+ cmds <- ghci_macros <$> getGHCiState+ return (filter (w `isPrefixOf`) (map cmdName cmds))++completeIdentifier line@(left, _) =+ -- Note: `left` is a reversed input+ case left of+ (x:_) | isSymbolChar x -> wrapCompleter (specials ++ spaces) complete line+ _ -> wrapIdentCompleter complete line+ where+ complete w = do+ rdrs <- GHC.getRdrNamesInScope+ dflags <- GHC.getSessionDynFlags+ return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))++completeModule = wrapIdentCompleter $ \w -> do+ dflags <- GHC.getSessionDynFlags+ let pkg_mods = allVisibleModules dflags+ loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules+ return $ filter (w `isPrefixOf`)+ $ map (showPpr dflags) $ loaded_mods ++ pkg_mods++completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do+ dflags <- GHC.getSessionDynFlags+ modules <- case m of+ Just '-' -> do+ imports <- GHC.getContext+ return $ map iiModuleName imports+ _ -> do+ let pkg_mods = allVisibleModules dflags+ loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules+ return $ loaded_mods ++ pkg_mods+ return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules++completeHomeModule = wrapIdentCompleter listHomeModules++listHomeModules :: String -> GHCi [String]+listHomeModules w = do+ g <- GHC.getModuleGraph+ let home_mods = map GHC.ms_mod_name (GHC.mgModSummaries g)+ dflags <- getDynFlags+ return $ sort $ filter (w `isPrefixOf`)+ $ map (showPpr dflags) home_mods++completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) opts)+ where opts = "args":"prog":"prompt":"prompt-cont":"prompt-function":+ "prompt-cont-function":"editor":"stop":flagList+ flagList = map head $ group $ sort allNonDeprecatedFlags++completeSeti = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) flagList)+ where flagList = map head $ group $ sort allNonDeprecatedFlags++completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) opts)+ where opts = ["args", "prog", "editor", "stop",+ "modules", "bindings", "linker", "breaks",+ "context", "packages", "paths", "language", "imports"]++completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) ["language"])++completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars+ $ unionComplete (fmap (map simpleCompletion) . listHomeModules)+ listFiles++unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]+unionComplete f1 f2 line = do+ cs1 <- f1 line+ cs2 <- f2 line+ return (cs1 ++ cs2)++wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi+wrapCompleter breakChars fun = completeWord Nothing breakChars+ $ fmap (map simpleCompletion . nubSort) . fun++wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi+wrapIdentCompleter = wrapCompleter word_break_chars++wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi+wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars+ $ \rest -> fmap (map simpleCompletion . nubSort) . fun (getModifier rest)+ where+ getModifier = find (`elem` modifChars)++-- | Return a list of visible module names for autocompletion.+-- (NB: exposed != visible)+allVisibleModules :: DynFlags -> [ModuleName]+allVisibleModules dflags = listVisibleModuleNames dflags++completeExpression = completeQuotedWord (Just '\\') "\"" listFiles+ completeIdentifier+++-- -----------------------------------------------------------------------------+-- commands for debugger++sprintCmd, printCmd, forceCmd :: String -> GHCi ()+sprintCmd = pprintCommand False False+printCmd = pprintCommand True False+forceCmd = pprintCommand False True++pprintCommand :: Bool -> Bool -> String -> GHCi ()+pprintCommand bind force str = do+ pprintClosureCommand bind force str++stepCmd :: String -> GHCi ()+stepCmd arg = withSandboxOnly ":step" $ step arg+ where+ step [] = doContinue (const True) GHC.SingleStep+ step expression = runStmt expression GHC.SingleStep >> return ()++stepLocalCmd :: String -> GHCi ()+stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg+ where+ step expr+ | not (null expr) = stepCmd expr+ | otherwise = do+ mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing -> stepCmd []+ Just loc -> do+ md <- fromMaybe (panic "stepLocalCmd") <$> getCurrentBreakModule+ current_toplevel_decl <- enclosingTickSpan md loc+ doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep++stepModuleCmd :: String -> GHCi ()+stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg+ where+ step expr+ | not (null expr) = stepCmd expr+ | otherwise = do+ mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing -> stepCmd []+ Just pan -> do+ let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span+ doContinue f GHC.SingleStep++-- | Returns the span of the largest tick containing the srcspan given+enclosingTickSpan :: Module -> SrcSpan -> GHCi RealSrcSpan+enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"+enclosingTickSpan md (RealSrcSpan src) = do+ ticks <- getTickArray md+ let line = srcSpanStartLine src+ ASSERT(inRange (bounds ticks) line) do+ let enclosing_spans = [ pan | (_,pan) <- ticks ! line+ , realSrcSpanEnd pan >= realSrcSpanEnd src]+ return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans+ where++leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering+leftmostLargestRealSrcSpan a b =+ (realSrcSpanStart a `compare` realSrcSpanStart b)+ `thenCmp`+ (realSrcSpanEnd b `compare` realSrcSpanEnd a)++traceCmd :: String -> GHCi ()+traceCmd arg+ = withSandboxOnly ":trace" $ tr arg+ where+ tr [] = doContinue (const True) GHC.RunAndLogSteps+ tr expression = runStmt expression GHC.RunAndLogSteps >> return ()++continueCmd :: String -> GHCi ()+continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion++-- doContinue :: SingleStep -> GHCi ()+doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()+doContinue pre step = do+ runResult <- resume pre step+ _ <- afterRunStmt pre runResult+ return ()++abandonCmd :: String -> GHCi ()+abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do+ b <- GHC.abandon -- the prompt will change to indicate the new context+ when (not b) $ liftIO $ putStrLn "There is no computation running."++deleteCmd :: String -> GHCi ()+deleteCmd argLine = withSandboxOnly ":delete" $ do+ deleteSwitch $ words argLine+ where+ deleteSwitch :: [String] -> GHCi ()+ deleteSwitch [] =+ liftIO $ putStrLn "The delete command requires at least one argument."+ -- delete all break points+ deleteSwitch ("*":_rest) = discardActiveBreakPoints+ deleteSwitch idents = do+ mapM_ deleteOneBreak idents+ where+ deleteOneBreak :: String -> GHCi ()+ deleteOneBreak str+ | all isDigit str = deleteBreak (read str)+ | otherwise = return ()++historyCmd :: String -> GHCi ()+historyCmd arg+ | null arg = history 20+ | all isDigit arg = history (read arg)+ | otherwise = liftIO $ putStrLn "Syntax: :history [num]"+ where+ history num = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> liftIO $ putStrLn "Not stopped at a breakpoint"+ (r:_) -> do+ let hist = GHC.resumeHistory r+ (took,rest) = splitAt num hist+ case hist of+ [] -> liftIO $ putStrLn $+ "Empty history. Perhaps you forgot to use :trace?"+ _ -> do+ pans <- mapM GHC.getHistorySpan took+ let nums = map (printf "-%-3d:") [(1::Int)..]+ names = map GHC.historyEnclosingDecls took+ printForUser (vcat(zipWith3+ (\x y z -> x <+> y <+> z)+ (map text nums)+ (map (bold . hcat . punctuate colon . map text) names)+ (map (parens . ppr) pans)))+ liftIO $ putStrLn $ if null rest then "<end of history>" else "..."++bold :: SDoc -> SDoc+bold c | do_bold = text start_bold <> c <> text end_bold+ | otherwise = c++backCmd :: String -> GHCi ()+backCmd arg+ | null arg = back 1+ | all isDigit arg = back (read arg)+ | otherwise = liftIO $ putStrLn "Syntax: :back [num]"+ where+ back num = withSandboxOnly ":back" $ do+ (names, _, pan, _) <- GHC.back num+ printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan+ printTypeOfNames names+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]++forwardCmd :: String -> GHCi ()+forwardCmd arg+ | null arg = forward 1+ | all isDigit arg = forward (read arg)+ | otherwise = liftIO $ putStrLn "Syntax: :back [num]"+ where+ forward num = withSandboxOnly ":forward" $ do+ (names, ix, pan, _) <- GHC.forward num+ printForUser $ (if (ix == 0)+ then ptext (sLit "Stopped at")+ else ptext (sLit "Logged breakpoint at")) <+> ppr pan+ printTypeOfNames names+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]++-- handle the "break" command+breakCmd :: String -> GHCi ()+breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine++breakSwitch :: [String] -> GHCi ()+breakSwitch [] = do+ liftIO $ putStrLn "The break command requires at least one argument."+breakSwitch (arg1:rest)+ | looksLikeModuleName arg1 && not (null rest) = do+ md <- wantInterpretedModule arg1+ breakByModule md rest+ | all isDigit arg1 = do+ imports <- GHC.getContext+ case iiModules imports of+ (mn : _) -> do+ md <- lookupModuleName mn+ breakByModuleLine md (read arg1) rest+ [] -> do+ liftIO $ putStrLn "No modules are loaded with debugging support."+ | otherwise = do -- try parsing it as an identifier+ wantNameFromInterpretedModule noCanDo arg1 $ \name -> do+ maybe_info <- GHC.getModuleInfo (GHC.nameModule name)+ case maybe_info of+ Nothing -> noCanDo name (ptext (sLit "cannot get module info"))+ Just minf ->+ ASSERT( isExternalName name )+ findBreakAndSet (GHC.nameModule name) $+ findBreakForBind name (GHC.modInfoModBreaks minf)+ where+ noCanDo n why = printForUser $+ text "cannot set breakpoint on " <> ppr n <> text ": " <> why++breakByModule :: Module -> [String] -> GHCi ()+breakByModule md (arg1:rest)+ | all isDigit arg1 = do -- looks like a line number+ breakByModuleLine md (read arg1) rest+breakByModule _ _+ = breakSyntax++breakByModuleLine :: Module -> Int -> [String] -> GHCi ()+breakByModuleLine md line args+ | [] <- args = findBreakAndSet md $ maybeToList . findBreakByLine line+ | [col] <- args, all isDigit col =+ findBreakAndSet md $ maybeToList . findBreakByCoord Nothing (line, read col)+ | otherwise = breakSyntax++breakSyntax :: a+breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")++findBreakAndSet :: Module -> (TickArray -> [(Int, RealSrcSpan)]) -> GHCi ()+findBreakAndSet md lookupTickTree = do+ tickArray <- getTickArray md+ (breakArray, _) <- getModBreak md+ case lookupTickTree tickArray of+ [] -> liftIO $ putStrLn $ "No breakpoints found at that location."+ some -> mapM_ (breakAt breakArray) some+ where+ breakAt breakArray (tick, pan) = do+ setBreakFlag True breakArray tick+ (alreadySet, nm) <-+ recordBreak $ BreakLocation+ { breakModule = md+ , breakLoc = RealSrcSpan pan+ , breakTick = tick+ , onBreakCmd = ""+ }+ printForUser $+ text "Breakpoint " <> ppr nm <>+ if alreadySet+ then text " was already set at " <> ppr pan+ else text " activated at " <> ppr pan++-- When a line number is specified, the current policy for choosing+-- the best breakpoint is this:+-- - the leftmost complete subexpression on the specified line, or+-- - the leftmost subexpression starting on the specified line, or+-- - the rightmost subexpression enclosing the specified line+--+findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan)+findBreakByLine line arr+ | not (inRange (bounds arr) line) = Nothing+ | otherwise =+ listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd) comp) `mplus`+ listToMaybe (sortBy (compare `on` snd) incomp) `mplus`+ listToMaybe (sortBy (flip compare `on` snd) ticks)+ where+ ticks = arr ! line++ starts_here = [ (ix,pan) | (ix, pan) <- ticks,+ GHC.srcSpanStartLine pan == line ]++ (comp, incomp) = partition ends_here starts_here+ where ends_here (_,pan) = GHC.srcSpanEndLine pan == line++-- The aim is to find the breakpoints for all the RHSs of the+-- equations corresponding to a binding. So we find all breakpoints+-- for+-- (a) this binder only (not a nested declaration)+-- (b) that do not have an enclosing breakpoint+findBreakForBind :: Name -> GHC.ModBreaks -> TickArray+ -> [(BreakIndex,RealSrcSpan)]+findBreakForBind name modbreaks _ = filter (not . enclosed) ticks+ where+ ticks = [ (index, span)+ | (index, [n]) <- assocs (GHC.modBreaks_decls modbreaks),+ n == occNameString (nameOccName name),+ RealSrcSpan span <- [GHC.modBreaks_locs modbreaks ! index] ]+ enclosed (_,sp0) = any subspan ticks+ where subspan (_,sp) = sp /= sp0 &&+ realSrcSpanStart sp <= realSrcSpanStart sp0 &&+ realSrcSpanEnd sp0 <= realSrcSpanEnd sp++findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray+ -> Maybe (BreakIndex,RealSrcSpan)+findBreakByCoord mb_file (line, col) arr+ | not (inRange (bounds arr) line) = Nothing+ | otherwise =+ listToMaybe (sortBy (flip compare `on` snd) contains +++ sortBy (compare `on` snd) after_here)+ where+ ticks = arr ! line++ -- the ticks that span this coordinate+ contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan `spans` (line,col),+ is_correct_file pan ]++ is_correct_file pan+ | Just f <- mb_file = GHC.srcSpanFile pan == f+ | otherwise = True++ after_here = [ tick | tick@(_,pan) <- ticks,+ GHC.srcSpanStartLine pan == line,+ GHC.srcSpanStartCol pan >= col ]++-- For now, use ANSI bold on terminals that we know support it.+-- Otherwise, we add a line of carets under the active expression instead.+-- In particular, on Windows and when running the testsuite (which sets+-- TERM to vt100 for other reasons) we get carets.+-- We really ought to use a proper termcap/terminfo library.+do_bold :: Bool+do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]+ where mTerm = System.Environment.getEnv "TERM"+ `catchIO` \_ -> return "TERM not set"++start_bold :: String+start_bold = "\ESC[1m"+end_bold :: String+end_bold = "\ESC[0m"++-----------------------------------------------------------------------------+-- :where++whereCmd :: String -> GHCi ()+whereCmd = noArgs $ do+ mstrs <- getCallStackAtCurrentBreakpoint+ case mstrs of+ Nothing -> return ()+ Just strs -> liftIO $ putStrLn (renderStack strs)++-----------------------------------------------------------------------------+-- :list++listCmd :: String -> InputT GHCi ()+listCmd c = listCmd' c++listCmd' :: String -> InputT GHCi ()+listCmd' "" = do+ mb_span <- lift getCurrentBreakSpan+ case mb_span of+ Nothing ->+ printForUser $ text "Not stopped at a breakpoint; nothing to list"+ Just (RealSrcSpan pan) ->+ listAround pan True+ Just pan@(UnhelpfulSpan _) ->+ do resumes <- GHC.getResumeContext+ case resumes of+ [] -> panic "No resumes"+ (r:_) ->+ do let traceIt = case GHC.resumeHistory r of+ [] -> text "rerunning with :trace,"+ _ -> empty+ doWhat = traceIt <+> text ":back then :list"+ printForUser (text "Unable to list source for" <+>+ ppr pan+ $$ text "Try" <+> doWhat)+listCmd' str = list2 (words str)++list2 :: [String] -> InputT GHCi ()+list2 [arg] | all isDigit arg = do+ imports <- GHC.getContext+ case iiModules imports of+ [] -> liftIO $ putStrLn "No module to list"+ (mn : _) -> do+ md <- lift $ lookupModuleName mn+ listModuleLine md (read arg)+list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do+ md <- wantInterpretedModule arg1+ listModuleLine md (read arg2)+list2 [arg] = do+ wantNameFromInterpretedModule noCanDo arg $ \name -> do+ let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)+ case loc of+ RealSrcLoc l ->+ do tickArray <- ASSERT( isExternalName name )+ lift $ getTickArray (GHC.nameModule name)+ let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))+ (GHC.srcLocLine l, GHC.srcLocCol l)+ tickArray+ case mb_span of+ Nothing -> listAround (realSrcLocSpan l) False+ Just (_, pan) -> listAround pan False+ UnhelpfulLoc _ ->+ noCanDo name $ text "can't find its location: " <>+ ppr loc+ where+ noCanDo n why = printForUser $+ text "cannot list source code for " <> ppr n <> text ": " <> why+list2 _other =+ liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"++listModuleLine :: Module -> Int -> InputT GHCi ()+listModuleLine modl line = do+ graph <- GHC.getModuleGraph+ let this = GHC.mgLookupModule graph modl+ case this of+ Nothing -> panic "listModuleLine"+ Just summ -> do+ let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))+ loc = mkRealSrcLoc (mkFastString (filename)) line 0+ listAround (realSrcLocSpan loc) False++-- | list a section of a source file around a particular SrcSpan.+-- If the highlight flag is True, also highlight the span using+-- start_bold\/end_bold.++-- GHC files are UTF-8, so we can implement this by:+-- 1) read the file in as a BS and syntax highlight it as before+-- 2) convert the BS to String using utf-string, and write it out.+-- It would be better if we could convert directly between UTF-8 and the+-- console encoding, of course.+listAround :: MonadIO m => RealSrcSpan -> Bool -> InputT m ()+listAround pan do_highlight = do+ contents <- liftIO $ BS.readFile (unpackFS file)+ -- Drop carriage returns to avoid duplicates, see #9367.+ let ls = BS.split '\n' $ BS.filter (/= '\r') contents+ ls' = take (line2 - line1 + 1 + pad_before + pad_after) $+ drop (line1 - 1 - pad_before) $ ls+ fst_line = max 1 (line1 - pad_before)+ line_nos = [ fst_line .. ]++ highlighted | do_highlight = zipWith highlight line_nos ls'+ | otherwise = [\p -> BS.concat[p,l] | l <- ls']++ bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]+ prefixed = zipWith ($) highlighted bs_line_nos+ output = BS.intercalate (BS.pack "\n") prefixed++ let utf8Decoded = utf8DecodeByteString output+ liftIO $ putStrLn utf8Decoded+ where+ file = GHC.srcSpanFile pan+ line1 = GHC.srcSpanStartLine pan+ col1 = GHC.srcSpanStartCol pan - 1+ line2 = GHC.srcSpanEndLine pan+ col2 = GHC.srcSpanEndCol pan - 1++ pad_before | line1 == 1 = 0+ | otherwise = 1+ pad_after = 1++ highlight | do_bold = highlight_bold+ | otherwise = highlight_carets++ highlight_bold no line prefix+ | no == line1 && no == line2+ = let (a,r) = BS.splitAt col1 line+ (b,c) = BS.splitAt (col2-col1) r+ in+ BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]+ | no == line1+ = let (a,b) = BS.splitAt col1 line in+ BS.concat [prefix, a, BS.pack start_bold, b]+ | no == line2+ = let (a,b) = BS.splitAt col2 line in+ BS.concat [prefix, a, BS.pack end_bold, b]+ | otherwise = BS.concat [prefix, line]++ highlight_carets no line prefix+ | no == line1 && no == line2+ = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',+ BS.replicate (col2-col1) '^']+ | no == line1+ = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,+ prefix, line]+ | no == line2+ = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',+ BS.pack "^^"]+ | otherwise = BS.concat [prefix, line]+ where+ indent = BS.pack (" " ++ replicate (length (show no)) ' ')+ nl = BS.singleton '\n'+++-- --------------------------------------------------------------------------+-- Tick arrays++getTickArray :: Module -> GHCi TickArray+getTickArray modl = do+ st <- getGHCiState+ let arrmap = tickarrays st+ case lookupModuleEnv arrmap modl of+ Just arr -> return arr+ Nothing -> do+ (_breakArray, ticks) <- getModBreak modl+ let arr = mkTickArray (assocs ticks)+ setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}+ return arr++discardTickArrays :: GHCi ()+discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})++mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray+mkTickArray ticks+ = accumArray (flip (:)) [] (1, max_line)+ [ (line, (nm,pan)) | (nm,RealSrcSpan pan) <- ticks, line <- srcSpanLines pan ]+ where+ max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp) <- ticks ]+ srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]++-- don't reset the counter back to zero?+discardActiveBreakPoints :: GHCi ()+discardActiveBreakPoints = do+ st <- getGHCiState+ mapM_ (turnOffBreak.snd) (breaks st)+ setGHCiState $ st { breaks = [] }++deleteBreak :: Int -> GHCi ()+deleteBreak identity = do+ st <- getGHCiState+ let oldLocations = breaks st+ (this,rest) = partition (\loc -> fst loc == identity) oldLocations+ if null this+ then printForUser (text "Breakpoint" <+> ppr identity <+>+ text "does not exist")+ else do+ mapM_ (turnOffBreak.snd) this+ setGHCiState $ st { breaks = rest }++turnOffBreak :: BreakLocation -> GHCi ()+turnOffBreak loc = do+ (arr, _) <- getModBreak (breakModule loc)+ hsc_env <- GHC.getSession+ liftIO $ enableBreakpoint hsc_env arr (breakTick loc) False++getModBreak :: Module -> GHCi (ForeignRef BreakArray, Array Int SrcSpan)+getModBreak m = do+ mod_info <- fromMaybe (panic "getModBreak") <$> GHC.getModuleInfo m+ let modBreaks = GHC.modInfoModBreaks mod_info+ let arr = GHC.modBreaks_flags modBreaks+ let ticks = GHC.modBreaks_locs modBreaks+ return (arr, ticks)++setBreakFlag :: Bool -> ForeignRef BreakArray -> Int -> GHCi ()+setBreakFlag toggle arr i = do+ hsc_env <- GHC.getSession+ liftIO $ enableBreakpoint hsc_env arr i toggle++-- ---------------------------------------------------------------------------+-- User code exception handling++-- This is the exception handler for exceptions generated by the+-- user's code and exceptions coming from children sessions;+-- it normally just prints out the exception. The+-- handler must be recursive, in case showing the exception causes+-- more exceptions to be raised.+--+-- Bugfix: if the user closed stdout or stderr, the flushing will fail,+-- raising another exception. We therefore don't put the recursive+-- handler arond the flushing operation, so if stderr is closed+-- GHCi will just die gracefully rather than going into an infinite loop.+handler :: SomeException -> GHCi Bool++handler exception = do+ flushInterpBuffers+ withSignalHandlers $+ ghciHandle handler (showException exception >> return False)++showException :: SomeException -> GHCi ()+showException se =+ liftIO $ case fromException se of+ -- omit the location for CmdLineError:+ Just (CmdLineError s) -> putException s+ -- ditto:+ Just other_ghc_ex -> putException (show other_ghc_ex)+ Nothing ->+ case fromException se of+ Just UserInterrupt -> putException "Interrupted."+ _ -> putException ("*** Exception: " ++ show se)+ where+ putException = hPutStrLn stderr+++-----------------------------------------------------------------------------+-- recursive exception handlers++-- Don't forget to unblock async exceptions in the handler, or if we're+-- in an exception loop (eg. let a = error a in a) the ^C exception+-- may never be delivered. Thanks to Marcin for pointing out the bug.++ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a+ghciHandle h m = gmask $ \restore -> do+ -- Force dflags to avoid leaking the associated HscEnv+ !dflags <- getDynFlags+ gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)++ghciTry :: GHCi a -> GHCi (Either SomeException a)+ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)++tryBool :: GHCi a -> GHCi Bool+tryBool m = do+ r <- ghciTry m+ case r of+ Left _ -> return False+ Right _ -> return True++-- ----------------------------------------------------------------------------+-- Utils++lookupModule :: GHC.GhcMonad m => String -> m Module+lookupModule mName = lookupModuleName (GHC.mkModuleName mName)++lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module+lookupModuleName mName = GHC.lookupModule mName Nothing++isHomeModule :: Module -> Bool+isHomeModule m = GHC.moduleUnitId m == mainUnitId++-- TODO: won't work if home dir is encoded.+-- (changeDirectory may not work either in that case.)+expandPath :: MonadIO m => String -> InputT m String+expandPath = liftIO . expandPathIO++expandPathIO :: String -> IO String+expandPathIO p =+ case dropWhile isSpace p of+ ('~':d) -> do+ tilde <- getHomeDirectory -- will fail if HOME not defined+ return (tilde ++ '/':d)+ other ->+ return other++wantInterpretedModule :: GHC.GhcMonad m => String -> m Module+wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)++wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module+wantInterpretedModuleName modname = do+ modl <- lookupModuleName modname+ let str = moduleNameString modname+ dflags <- getDynFlags+ when (GHC.moduleUnitId modl /= thisPackage dflags) $+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))+ is_interpreted <- GHC.moduleIsInterpreted modl+ when (not is_interpreted) $+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))+ return modl++wantNameFromInterpretedModule :: GHC.GhcMonad m+ => (Name -> SDoc -> m ())+ -> String+ -> (Name -> m ())+ -> m ()+wantNameFromInterpretedModule noCanDo str and_then =+ handleSourceError GHC.printException $ do+ names <- GHC.parseName str+ case names of+ [] -> return ()+ (n:_) -> do+ let modl = ASSERT( isExternalName n ) GHC.nameModule n+ if not (GHC.isExternalName n)+ then noCanDo n $ ppr n <>+ text " is not defined in an interpreted module"+ else do+ is_interpreted <- GHC.moduleIsInterpreted modl+ if not is_interpreted+ then noCanDo n $ text "module " <> ppr modl <>+ text " is not interpreted"+ else and_then n
+ src-bin-881/Clash/GHCi/UI/Info.hs view
@@ -0,0 +1,379 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++-- | Get information on modules, expressions, and identifiers+module Clash.GHCi.UI.Info+ ( ModInfo(..)+ , SpanInfo(..)+ , spanInfoFromRealSrcSpan+ , collectInfo+ , findLoc+ , findNameUses+ , findType+ , getModInfo+ ) where++import Control.Exception+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+import Control.Monad.Trans.Maybe+import Data.Data+import Data.Function+import Data.List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Time+import Prelude hiding (mod,(<>))+import System.Directory++import qualified CoreUtils+import Desugar+import DynFlags (HasDynFlags(..))+import FastString+import GHC+import GhcMonad+import Name+import NameSet+import Outputable+import SrcLoc+import TcHsSyn+import Var++-- | Info about a module. This information is generated every time a+-- module is loaded.+data ModInfo = ModInfo+ { modinfoSummary :: !ModSummary+ -- ^ Summary generated by GHC. Can be used to access more+ -- information about the module.+ , modinfoSpans :: [SpanInfo]+ -- ^ Generated set of information about all spans in the+ -- module that correspond to some kind of identifier for+ -- which there will be type info and/or location info.+ , modinfoInfo :: !ModuleInfo+ -- ^ Again, useful from GHC for accessing information+ -- (exports, instances, scope) from a module.+ , modinfoLastUpdate :: !UTCTime+ -- ^ The timestamp of the file used to generate this record.+ }++-- | Type of some span of source code. Most of these fields are+-- unboxed but Haddock doesn't show that.+data SpanInfo = SpanInfo+ { spaninfoSrcSpan :: {-# UNPACK #-} !RealSrcSpan+ -- ^ The span we associate information with+ , spaninfoType :: !(Maybe Type)+ -- ^ The 'Type' associated with the span+ , spaninfoVar :: !(Maybe Id)+ -- ^ The actual 'Var' associated with the span, if+ -- any. This can be useful for accessing a variety of+ -- information about the identifier such as module,+ -- locality, definition location, etc.+ }++-- | Test whether second span is contained in (or equal to) first span.+-- This is basically 'containsSpan' for 'SpanInfo'+containsSpanInfo :: SpanInfo -> SpanInfo -> Bool+containsSpanInfo = containsSpan `on` spaninfoSrcSpan++-- | Filter all 'SpanInfo' which are contained in 'SpanInfo'+spaninfosWithin :: [SpanInfo] -> SpanInfo -> [SpanInfo]+spaninfosWithin spans' si = filter (si `containsSpanInfo`) spans'++-- | Construct a 'SpanInfo' from a 'RealSrcSpan' and optionally a+-- 'Type' and an 'Id' (for 'spaninfoType' and 'spaninfoVar'+-- respectively)+spanInfoFromRealSrcSpan :: RealSrcSpan -> Maybe Type -> Maybe Id -> SpanInfo+spanInfoFromRealSrcSpan spn mty mvar =+ SpanInfo spn mty mvar++-- | Convenience wrapper around 'spanInfoFromRealSrcSpan' which needs+-- only a 'RealSrcSpan'+spanInfoFromRealSrcSpan' :: RealSrcSpan -> SpanInfo+spanInfoFromRealSrcSpan' s = spanInfoFromRealSrcSpan s Nothing Nothing++-- | Convenience wrapper around 'srcSpanFile' which results in a 'FilePath'+srcSpanFilePath :: RealSrcSpan -> FilePath+srcSpanFilePath = unpackFS . srcSpanFile++-- | Try to find the location of the given identifier at the given+-- position in the module.+findLoc :: GhcMonad m+ => Map ModuleName ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT SDoc m (ModInfo,Name,SrcSpan)+findLoc infos span0 string = do+ name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $+ guessModule infos (srcSpanFilePath span0)++ info <- maybeToExceptT "No module info for current file! Try loading it?" $+ MaybeT $ pure $ M.lookup name infos++ name' <- findName infos span0 info string++ case getSrcSpan name' of+ UnhelpfulSpan{} -> do+ throwE ("Found a name, but no location information." <+>+ "The module is:" <+>+ maybe "<unknown>" (ppr . moduleName)+ (nameModule_maybe name'))++ span' -> return (info,name',span')++-- | Find any uses of the given identifier in the codebase.+findNameUses :: (GhcMonad m)+ => Map ModuleName ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT SDoc m [SrcSpan]+findNameUses infos span0 string =+ locToSpans <$> findLoc infos span0 string+ where+ locToSpans (modinfo,name',span') =+ stripSurrounding (span' : map toSrcSpan spans)+ where+ toSrcSpan = RealSrcSpan . spaninfoSrcSpan+ spans = filter ((== Just name') . fmap getName . spaninfoVar)+ (modinfoSpans modinfo)++-- | Filter out redundant spans which surround/contain other spans.+stripSurrounding :: [SrcSpan] -> [SrcSpan]+stripSurrounding xs = filter (not . isRedundant) xs+ where+ isRedundant x = any (x `strictlyContains`) xs++ (RealSrcSpan s1) `strictlyContains` (RealSrcSpan s2)+ = s1 /= s2 && s1 `containsSpan` s2+ _ `strictlyContains` _ = False++-- | Try to resolve the name located at the given position, or+-- otherwise resolve based on the current module's scope.+findName :: GhcMonad m+ => Map ModuleName ModInfo+ -> RealSrcSpan+ -> ModInfo+ -> String+ -> ExceptT SDoc m Name+findName infos span0 mi string =+ case resolveName (modinfoSpans mi) (spanInfoFromRealSrcSpan' span0) of+ Nothing -> tryExternalModuleResolution+ Just name ->+ case getSrcSpan name of+ UnhelpfulSpan {} -> tryExternalModuleResolution+ RealSrcSpan {} -> return (getName name)+ where+ tryExternalModuleResolution =+ case find (matchName $ mkFastString string)+ (fromMaybe [] (modInfoTopLevelScope (modinfoInfo mi))) of+ Nothing -> throwE "Couldn't resolve to any modules."+ Just imported -> resolveNameFromModule infos imported++ matchName :: FastString -> Name -> Bool+ matchName str name =+ str ==+ occNameFS (getOccName name)++-- | Try to resolve the name from another (loaded) module's exports.+resolveNameFromModule :: GhcMonad m+ => Map ModuleName ModInfo+ -> Name+ -> ExceptT SDoc m Name+resolveNameFromModule infos name = do+ modL <- maybe (throwE $ "No module for" <+> ppr name) return $+ nameModule_maybe name++ info <- maybe (throwE (ppr (moduleUnitId modL) <> ":" <>+ ppr modL)) return $+ M.lookup (moduleName modL) infos++ maybe (throwE "No matching export in any local modules.") return $+ find (matchName name) (modInfoExports (modinfoInfo info))+ where+ matchName :: Name -> Name -> Bool+ matchName x y = occNameFS (getOccName x) ==+ occNameFS (getOccName y)++-- | Try to resolve the type display from the given span.+resolveName :: [SpanInfo] -> SpanInfo -> Maybe Var+resolveName spans' si = listToMaybe $ mapMaybe spaninfoVar $+ reverse spans' `spaninfosWithin` si++-- | Try to find the type of the given span.+findType :: GhcMonad m+ => Map ModuleName ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT SDoc m (ModInfo, Type)+findType infos span0 string = do+ name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $+ guessModule infos (srcSpanFilePath span0)++ info <- maybeToExceptT "No module info for current file! Try loading it?" $+ MaybeT $ pure $ M.lookup name infos++ case resolveType (modinfoSpans info) (spanInfoFromRealSrcSpan' span0) of+ Nothing -> (,) info <$> lift (exprType TM_Inst string)+ Just ty -> return (info, ty)+ where+ -- | Try to resolve the type display from the given span.+ resolveType :: [SpanInfo] -> SpanInfo -> Maybe Type+ resolveType spans' si = listToMaybe $ mapMaybe spaninfoType $+ reverse spans' `spaninfosWithin` si++-- | Guess a module name from a file path.+guessModule :: GhcMonad m+ => Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName+guessModule infos fp = do+ target <- lift $ guessTarget fp Nothing+ case targetId target of+ TargetModule mn -> return mn+ TargetFile fp' _ -> guessModule' fp'+ where+ guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName+ guessModule' fp' = case findModByFp fp' of+ Just mn -> return mn+ Nothing -> do+ fp'' <- liftIO (makeRelativeToCurrentDirectory fp')++ target' <- lift $ guessTarget fp'' Nothing+ case targetId target' of+ TargetModule mn -> return mn+ _ -> MaybeT . pure $ findModByFp fp''++ findModByFp :: FilePath -> Maybe ModuleName+ findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos)+ where+ mifp :: (ModuleName, ModInfo) -> Maybe FilePath+ mifp = ml_hs_file . ms_location . modinfoSummary . snd+++-- | Collect type info data for the loaded modules.+collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]+ -> m (Map ModuleName ModInfo)+collectInfo ms loaded = do+ df <- getDynFlags+ liftIO (filterM cacheInvalid loaded) >>= \case+ [] -> return ms+ invalidated -> do+ liftIO (putStrLn ("Collecting type info for " +++ show (length invalidated) +++ " module(s) ... "))++ foldM (go df) ms invalidated+ where+ go df m name = do { info <- getModInfo name; return (M.insert name info m) }+ `gcatch`+ (\(e :: SomeException) -> do+ liftIO $ putStrLn+ $ showSDocForUser df alwaysQualify+ $ "Error while getting type info from" <+>+ ppr name <> ":" <+> text (show e)+ return m)++ cacheInvalid name = case M.lookup name ms of+ Nothing -> return True+ Just mi -> do+ let fp = srcFilePath (modinfoSummary mi)+ last' = modinfoLastUpdate mi+ current <- getModificationTime fp+ exists <- doesFileExist fp+ if exists+ then return $ current /= last'+ else return True++-- | Get the source file path from a ModSummary.+-- If the .hs file is missing, and the .o file exists,+-- we return the .o file path.+srcFilePath :: ModSummary -> FilePath+srcFilePath modSum = fromMaybe obj_fp src_fp+ where+ src_fp = ml_hs_file ms_loc+ obj_fp = ml_obj_file ms_loc+ ms_loc = ms_location modSum++-- | Get info about the module: summary, types, etc.+getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo+getModInfo name = do+ m <- getModSummary name+ p <- parseModule m+ typechecked <- typecheckModule p+ allTypes <- processAllTypeCheckedModule typechecked+ let i = tm_checked_module_info typechecked+ ts <- liftIO $ getModificationTime $ srcFilePath m+ return (ModInfo m allTypes i ts)++-- | Get ALL source spans in the module.+processAllTypeCheckedModule :: forall m . GhcMonad m => TypecheckedModule+ -> m [SpanInfo]+processAllTypeCheckedModule tcm = do+ bts <- mapM getTypeLHsBind $ listifyAllSpans tcs+ ets <- mapM getTypeLHsExpr $ listifyAllSpans tcs+ pts <- mapM getTypeLPat $ listifyAllSpans tcs+ return $ mapMaybe toSpanInfo+ $ sortBy cmpSpan+ $ catMaybes (bts ++ ets ++ pts)+ where+ tcs = tm_typechecked_source tcm++ -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's+ getTypeLHsBind :: LHsBind GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))+ getTypeLHsBind (dL->L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _})+ = pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid))+ getTypeLHsBind _ = pure Nothing++ -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's+ getTypeLHsExpr :: LHsExpr GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))+ getTypeLHsExpr e = do+ hs_env <- getSession+ (_,mbe) <- liftIO $ deSugarExpr hs_env e+ return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe+ where+ mid :: Maybe Id+ mid | HsVar _ (dL->L _ i) <- unwrapVar (unLoc e) = Just i+ | otherwise = Nothing++ unwrapVar (HsWrap _ _ var) = var+ unwrapVar e' = e'++ -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's+ getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))+ getTypeLPat (dL->L spn pat) =+ pure (Just (getMaybeId pat,spn,hsPatType pat))+ where+ getMaybeId (VarPat _ (dL->L _ vid)) = Just vid+ getMaybeId _ = Nothing++ -- | Get ALL source spans in the source.+ listifyAllSpans :: (HasSrcSpan a , Typeable a) => TypecheckedSource -> [a]+ listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x]))+ where+ p (dL->L spn _) = isGoodSrcSpan spn++ -- | Variant of @syb@'s @everything@ (which summarises all nodes+ -- in top-down, left-to-right order) with a stop-condition on 'NameSet's+ everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r+ everythingAllSpans k z f x+ | (False `mkQ` (const True :: NameSet -> Bool)) x = z+ | otherwise = foldl k (f x) (gmapQ (everythingAllSpans k z f) x)++ cmpSpan (_,a,_) (_,b,_)+ | a `isSubspanOf` b = LT+ | b `isSubspanOf` a = GT+ | otherwise = EQ++ -- | Pretty print the types into a 'SpanInfo'.+ toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo+ toSpanInfo (n,RealSrcSpan spn,typ)+ = Just $ spanInfoFromRealSrcSpan spn (Just typ) n+ toSpanInfo _ = Nothing++-- helper stolen from @syb@ package+type GenericQ r = forall a. Data a => a -> r++mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r+(r `mkQ` br) a = maybe r br (cast a)
+ src-bin-881/Clash/GHCi/UI/Monad.hs view
@@ -0,0 +1,533 @@+{-# LANGUAGE CPP, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}+-- -fno-cse is needed for GLOBAL_VAR's to behave properly++-----------------------------------------------------------------------------+--+-- Monadery code used in InteractiveUI+--+-- (c) The GHC Team 2005-2006+--+-----------------------------------------------------------------------------++module Clash.GHCi.UI.Monad (+ GHCi(..), startGHCi,+ GHCiState(..), setGHCiState, getGHCiState, modifyGHCiState,+ GHCiOption(..), isOptionSet, setOption, unsetOption,+ Command(..), CommandResult(..), cmdSuccess,+ PromptFunction,+ BreakLocation(..),+ TickArray,+ getDynFlags,++ runStmt, runDecls, runDecls', resume, recordBreak, revertCAFs,+ ActionStats(..), runAndPrintStats, runWithStats, printStats,++ printForUserNeverQualify, printForUserModInfo,+ printForUser, printForUserPartWay, prettyLocations,++ compileGHCiExpr,+ initInterpBuffering,+ turnOffBuffering, turnOffBuffering_,+ flushInterpBuffers,+ mkEvalWrapper+ ) where++#include "HsVersions.h"++import Clash.GHCi.UI.Info (ModInfo)+import qualified GHC+import GhcMonad hiding (liftIO)+import Outputable hiding (printForUser, printForUserPartWay)+import qualified Outputable+import OccName+import DynFlags+import FastString+import HscTypes+import SrcLoc+import Module+import RdrName (mkOrig)+import PrelNames (gHC_GHCI_HELPERS)+import GHCi+import GHCi.RemoteTypes+import HsSyn (ImportDecl, GhcPs, GhciLStmt, LHsDecl)+import HsUtils+import Util++import Exception+import Numeric+import Data.Array+import Data.IORef+import Data.Time+import System.Environment+import System.IO+import Control.Monad+import Prelude hiding ((<>))++import System.Console.Haskeline (CompletionFunc, InputT)+import qualified System.Console.Haskeline as Haskeline+import Control.Monad.Trans.Class+import Control.Monad.IO.Class+import Data.Map.Strict (Map)+import qualified GHC.LanguageExtensions as LangExt++-----------------------------------------------------------------------------+-- GHCi monad++data GHCiState = GHCiState+ {+ progname :: String,+ args :: [String],+ evalWrapper :: ForeignHValue, -- ^ of type @IO a -> IO a@+ prompt :: PromptFunction,+ prompt_cont :: PromptFunction,+ editor :: String,+ stop :: String,+ options :: [GHCiOption],+ line_number :: !Int, -- ^ input line+ break_ctr :: !Int,+ breaks :: ![(Int, BreakLocation)],+ tickarrays :: ModuleEnv TickArray,+ -- ^ 'tickarrays' caches the 'TickArray' for loaded modules,+ -- so that we don't rebuild it each time the user sets+ -- a breakpoint.+ ghci_commands :: [Command],+ -- ^ available ghci commands+ ghci_macros :: [Command],+ -- ^ user-defined macros+ last_command :: Maybe Command,+ -- ^ @:@ at the GHCi prompt repeats the last command, so we+ -- remember it here+ cmd_wrapper :: InputT GHCi CommandResult -> InputT GHCi (Maybe Bool),+ -- ^ The command wrapper is run for each command or statement.+ -- The 'Bool' value denotes whether the command is successful and+ -- 'Nothing' means to exit GHCi.+ cmdqueue :: [String],++ remembered_ctx :: [InteractiveImport],+ -- ^ The imports that the user has asked for, via import+ -- declarations and :module commands. This list is+ -- persistent over :reloads (but any imports for modules+ -- that are not loaded are temporarily ignored). After a+ -- :load, all the home-package imports are stripped from+ -- this list.+ --+ -- See bugs #2049, #1873, #1360++ transient_ctx :: [InteractiveImport],+ -- ^ An import added automatically after a :load, usually of+ -- the most recently compiled module. May be empty if+ -- there are no modules loaded. This list is replaced by+ -- :load, :reload, and :add. In between it may be modified+ -- by :module.++ extra_imports :: [ImportDecl GhcPs],+ -- ^ These are "always-on" imports, added to the+ -- context regardless of what other imports we have.+ -- This is useful for adding imports that are required+ -- by setGHCiMonad. Be careful adding things here:+ -- you can create ambiguities if these imports overlap+ -- with other things in scope.+ --+ -- NB. although this is not currently used by GHCi itself,+ -- it was added to support other front-ends that are based+ -- on the GHCi code. Potentially we could also expose+ -- this functionality via GHCi commands.++ prelude_imports :: [ImportDecl GhcPs],+ -- ^ These imports are added to the context when+ -- -XImplicitPrelude is on and we don't have a *-module+ -- in the context. They can also be overridden by another+ -- import for the same module, e.g.+ -- "import Prelude hiding (map)"++ ghc_e :: Bool, -- ^ True if this is 'ghc -e' (or runghc)++ short_help :: String,+ -- ^ help text to display to a user+ long_help :: String,+ lastErrorLocations :: IORef [(FastString, Int)],++ mod_infos :: !(Map ModuleName ModInfo),++ flushStdHandles :: ForeignHValue,+ -- ^ @hFlush stdout; hFlush stderr@ in the interpreter+ noBuffering :: ForeignHValue+ -- ^ @hSetBuffering NoBuffering@ for stdin/stdout/stderr+ }++type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]++-- | A GHCi command+data Command+ = Command+ { cmdName :: String+ -- ^ Name of GHCi command (e.g. "exit")+ , cmdAction :: String -> InputT GHCi Bool+ -- ^ The 'Bool' value denotes whether to exit GHCi+ , cmdHidden :: Bool+ -- ^ Commands which are excluded from default completion+ -- and @:help@ summary. This is usually set for commands not+ -- useful for interactive use but rather for IDEs.+ , cmdCompletionFunc :: CompletionFunc GHCi+ -- ^ 'CompletionFunc' for arguments+ }++data CommandResult+ = CommandComplete+ { cmdInput :: String+ , cmdResult :: Either SomeException (Maybe Bool)+ , cmdStats :: ActionStats+ }+ | CommandIncomplete+ -- ^ Unterminated multiline command+ deriving Show++cmdSuccess :: Haskeline.MonadException m => CommandResult -> m (Maybe Bool)+cmdSuccess CommandComplete{ cmdResult = Left e } = liftIO $ throwIO e+cmdSuccess CommandComplete{ cmdResult = Right r } = return r+cmdSuccess CommandIncomplete = return $ Just True++type PromptFunction = [String]+ -> Int+ -> GHCi SDoc++data GHCiOption+ = ShowTiming -- show time/allocs after evaluation+ | ShowType -- show the type of expressions+ | RevertCAFs -- revert CAFs after every evaluation+ | Multiline -- use multiline commands+ | CollectInfo -- collect and cache information about+ -- modules after load+ deriving Eq++data BreakLocation+ = BreakLocation+ { breakModule :: !GHC.Module+ , breakLoc :: !SrcSpan+ , breakTick :: {-# UNPACK #-} !Int+ , onBreakCmd :: String+ }++instance Eq BreakLocation where+ loc1 == loc2 = breakModule loc1 == breakModule loc2 &&+ breakTick loc1 == breakTick loc2++prettyLocations :: [(Int, BreakLocation)] -> SDoc+prettyLocations [] = text "No active breakpoints."+prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs++instance Outputable BreakLocation where+ ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>+ if null (onBreakCmd loc)+ then Outputable.empty+ else doubleQuotes (text (onBreakCmd loc))++recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)+recordBreak brkLoc = do+ st <- getGHCiState+ let oldActiveBreaks = breaks st+ -- don't store the same break point twice+ case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of+ (nm:_) -> return (True, nm)+ [] -> do+ let oldCounter = break_ctr st+ newCounter = oldCounter + 1+ setGHCiState $ st { break_ctr = newCounter,+ breaks = (oldCounter, brkLoc) : oldActiveBreaks+ }+ return (False, oldCounter)++newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }++reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a+reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s++reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a+reifyGHCi f = GHCi f'+ where+ -- f' :: IORef GHCiState -> Ghc a+ f' gs = reifyGhc (f'' gs)+ -- f'' :: IORef GHCiState -> Session -> IO a+ f'' gs s = f (s, gs)++startGHCi :: GHCi a -> GHCiState -> Ghc a+startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref++instance Functor GHCi where+ fmap = liftM++instance Applicative GHCi where+ pure a = GHCi $ \_ -> pure a+ (<*>) = ap++instance Monad GHCi where+ (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s++class HasGhciState m where+ getGHCiState :: m GHCiState+ setGHCiState :: GHCiState -> m ()+ modifyGHCiState :: (GHCiState -> GHCiState) -> m ()++instance HasGhciState GHCi where+ getGHCiState = GHCi $ \r -> liftIO $ readIORef r+ setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s+ modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f++instance (MonadTrans t, Monad m, HasGhciState m) => HasGhciState (t m) where+ getGHCiState = lift getGHCiState+ setGHCiState = lift . setGHCiState+ modifyGHCiState = lift . modifyGHCiState++liftGhc :: Ghc a -> GHCi a+liftGhc m = GHCi $ \_ -> m++instance MonadIO GHCi where+ liftIO = liftGhc . liftIO++instance HasDynFlags GHCi where+ getDynFlags = getSessionDynFlags++instance GhcMonad GHCi where+ setSession s' = liftGhc $ setSession s'+ getSession = liftGhc $ getSession++instance HasDynFlags (InputT GHCi) where+ getDynFlags = lift getDynFlags++instance GhcMonad (InputT GHCi) where+ setSession = lift . setSession+ getSession = lift getSession++instance ExceptionMonad GHCi where+ gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)+ gmask f =+ GHCi $ \s -> gmask $ \io_restore ->+ let+ g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')+ in+ unGHCi (f g_restore) s++instance Haskeline.MonadException Ghc where+ controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let+ run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)+ in fmap (flip unGhc s) $ f run'++instance Haskeline.MonadException GHCi where+ controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let+ run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)+ in fmap (flip unGHCi s) $ f run'++instance ExceptionMonad (InputT GHCi) where+ gcatch = Haskeline.catch+ gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)++isOptionSet :: GHCiOption -> GHCi Bool+isOptionSet opt+ = do st <- getGHCiState+ return (opt `elem` options st)++setOption :: GHCiOption -> GHCi ()+setOption opt+ = do st <- getGHCiState+ setGHCiState (st{ options = opt : filter (/= opt) (options st) })++unsetOption :: GHCiOption -> GHCi ()+unsetOption opt+ = do st <- getGHCiState+ setGHCiState (st{ options = filter (/= opt) (options st) })++printForUserNeverQualify :: GhcMonad m => SDoc -> m ()+printForUserNeverQualify doc = do+ dflags <- getDynFlags+ liftIO $ Outputable.printForUser dflags stdout neverQualify doc++printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()+printForUserModInfo info doc = do+ dflags <- getDynFlags+ mUnqual <- GHC.mkPrintUnqualifiedForModule info+ unqual <- maybe GHC.getPrintUnqual return mUnqual+ liftIO $ Outputable.printForUser dflags stdout unqual doc++printForUser :: GhcMonad m => SDoc -> m ()+printForUser doc = do+ unqual <- GHC.getPrintUnqual+ dflags <- getDynFlags+ liftIO $ Outputable.printForUser dflags stdout unqual doc++printForUserPartWay :: SDoc -> GHCi ()+printForUserPartWay doc = do+ unqual <- GHC.getPrintUnqual+ dflags <- getDynFlags+ liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc++-- | Run a single Haskell expression+runStmt :: GhciLStmt GhcPs -> String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult)+runStmt stmt stmt_text step = do+ st <- getGHCiState+ GHC.handleSourceError (\e -> do GHC.printException e; return Nothing) $ do+ let opts = GHC.execOptions+ { GHC.execSourceFile = progname st+ , GHC.execLineNumber = line_number st+ , GHC.execSingleStep = step+ , GHC.execWrap = \fhv -> EvalApp (EvalThis (evalWrapper st))+ (EvalThis fhv) }+ Just <$> GHC.execStmt' stmt stmt_text opts++runDecls :: String -> GHCi (Maybe [GHC.Name])+runDecls decls = do+ st <- getGHCiState+ reifyGHCi $ \x ->+ withProgName (progname st) $+ withArgs (args st) $+ reflectGHCi x $ do+ GHC.handleSourceError (\e -> do GHC.printException e;+ return Nothing) $ do+ r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls+ return (Just r)++runDecls' :: [LHsDecl GhcPs] -> GHCi (Maybe [GHC.Name])+runDecls' decls = do+ st <- getGHCiState+ reifyGHCi $ \x ->+ withProgName (progname st) $+ withArgs (args st) $+ reflectGHCi x $+ GHC.handleSourceError+ (\e -> do GHC.printException e;+ return Nothing)+ (Just <$> GHC.runParsedDecls decls)++resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.ExecResult+resume canLogSpan step = do+ st <- getGHCiState+ reifyGHCi $ \x ->+ withProgName (progname st) $+ withArgs (args st) $+ reflectGHCi x $ do+ GHC.resumeExec canLogSpan step++-- --------------------------------------------------------------------------+-- timing & statistics++data ActionStats = ActionStats+ { actionAllocs :: Maybe Integer+ , actionElapsedTime :: Double+ } deriving Show++runAndPrintStats+ :: (a -> Maybe Integer)+ -> InputT GHCi a+ -> InputT GHCi (ActionStats, Either SomeException a)+runAndPrintStats getAllocs action = do+ result <- runWithStats getAllocs action+ case result of+ (stats, Right{}) -> do+ showTiming <- lift $ isOptionSet ShowTiming+ when showTiming $ do+ dflags <- getDynFlags+ liftIO $ printStats dflags stats+ _ -> return ()+ return result++runWithStats+ :: ExceptionMonad m+ => (a -> Maybe Integer) -> m a -> m (ActionStats, Either SomeException a)+runWithStats getAllocs action = do+ t0 <- liftIO getCurrentTime+ result <- gtry action+ let allocs = either (const Nothing) getAllocs result+ t1 <- liftIO getCurrentTime+ let elapsedTime = realToFrac $ t1 `diffUTCTime` t0+ return (ActionStats allocs elapsedTime, result)++printStats :: DynFlags -> ActionStats -> IO ()+printStats dflags ActionStats{actionAllocs = mallocs, actionElapsedTime = secs}+ = do let secs_str = showFFloat (Just 2) secs+ putStrLn (showSDoc dflags (+ parens (text (secs_str "") <+> text "secs" <> comma <+>+ case mallocs of+ Nothing -> empty+ Just allocs ->+ text (separateThousands allocs) <+> text "bytes")))+ where+ separateThousands n = reverse . sep . reverse . show $ n+ where sep n'+ | n' `lengthAtMost` 3 = n'+ | otherwise = take 3 n' ++ "," ++ sep (drop 3 n')++-----------------------------------------------------------------------------+-- reverting CAFs++revertCAFs :: GHCi ()+revertCAFs = do+ liftIO rts_revertCAFs+ s <- getGHCiState+ when (not (ghc_e s)) turnOffBuffering+ -- Have to turn off buffering again, because we just+ -- reverted stdout, stderr & stdin to their defaults.++foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()+ -- Make it "safe", just in case++-----------------------------------------------------------------------------+-- To flush buffers for the *interpreted* computation we need+-- to refer to *its* stdout/stderr handles++-- | Compile "hFlush stdout; hFlush stderr" once, so we can use it repeatedly+initInterpBuffering :: Ghc (ForeignHValue, ForeignHValue)+initInterpBuffering = do+ let mkHelperExpr :: OccName -> Ghc ForeignHValue+ mkHelperExpr occ =+ GHC.compileParsedExprRemote+ $ GHC.nlHsVar $ RdrName.mkOrig gHC_GHCI_HELPERS occ+ nobuf <- mkHelperExpr $ mkVarOcc "disableBuffering"+ flush <- mkHelperExpr $ mkVarOcc "flushAll"+ return (nobuf, flush)++-- | Invoke "hFlush stdout; hFlush stderr" in the interpreter+flushInterpBuffers :: GHCi ()+flushInterpBuffers = do+ st <- getGHCiState+ hsc_env <- GHC.getSession+ liftIO $ evalIO hsc_env (flushStdHandles st)++-- | Turn off buffering for stdin, stdout, and stderr in the interpreter+turnOffBuffering :: GHCi ()+turnOffBuffering = do+ st <- getGHCiState+ turnOffBuffering_ (noBuffering st)++turnOffBuffering_ :: GhcMonad m => ForeignHValue -> m ()+turnOffBuffering_ fhv = do+ hsc_env <- getSession+ liftIO $ evalIO hsc_env fhv++mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue+mkEvalWrapper progname args =+ runInternal $ GHC.compileParsedExprRemote+ $ evalWrapper `GHC.mkHsApp` nlHsString progname+ `GHC.mkHsApp` nlList (map nlHsString args)+ where+ nlHsString = nlHsLit . mkHsString+ evalWrapper =+ GHC.nlHsVar $ RdrName.mkOrig gHC_GHCI_HELPERS (mkVarOcc "evalWrapper")++-- | Run a 'GhcMonad' action to compile an expression for internal usage.+runInternal :: GhcMonad m => m a -> m a+runInternal =+ withTempSession mkTempSession+ where+ mkTempSession hsc_env = hsc_env+ { hsc_dflags = (hsc_dflags hsc_env)+ -- RebindableSyntax can wreak havoc with GHCi in several ways+ -- (see #13385 and #14342 for examples), so we take care to disable it+ -- for the duration of running expressions that are internal to GHCi.+ `xopt_unset` LangExt.RebindableSyntax+ -- We heavily depend on -fimplicit-import-qualified to compile expr+ -- with fully qualified names without imports.+ `gopt_set` Opt_ImplicitImportQualified+ }++compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue+compileGHCiExpr expr = runInternal $ GHC.compileExprRemote expr
+ src-bin-881/Clash/GHCi/UI/Tags.hs view
@@ -0,0 +1,216 @@+-----------------------------------------------------------------------------+--+-- GHCi's :ctags and :etags commands+--+-- (c) The GHC Team 2005-2007+--+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+module Clash.GHCi.UI.Tags (+ createCTagsWithLineNumbersCmd,+ createCTagsWithRegExesCmd,+ createETagsFileCmd+) where++import Exception+import GHC+import Clash.GHCi.UI.Monad+import Outputable++-- ToDo: figure out whether we need these, and put something appropriate+-- into the GHC API instead+import Name (nameOccName)+import OccName (pprOccName)+import ConLike+import MonadUtils++import Control.Monad+import Data.Function+import Data.List+import Data.Maybe+import Data.Ord+import DriverPhases+import Panic+import Prelude+import System.Directory+import System.IO+import System.IO.Error++-----------------------------------------------------------------------------+-- create tags file for currently loaded modules.++createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd,+ createETagsFileCmd :: String -> GHCi ()++createCTagsWithLineNumbersCmd "" =+ ghciCreateTagsFile CTagsWithLineNumbers "tags"+createCTagsWithLineNumbersCmd file =+ ghciCreateTagsFile CTagsWithLineNumbers file++createCTagsWithRegExesCmd "" =+ ghciCreateTagsFile CTagsWithRegExes "tags"+createCTagsWithRegExesCmd file =+ ghciCreateTagsFile CTagsWithRegExes file++createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"+createETagsFileCmd file = ghciCreateTagsFile ETags file++data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes++ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()+ghciCreateTagsFile kind file = do+ createTagsFile kind file++-- ToDo:+-- - remove restriction that all modules must be interpreted+-- (problem: we don't know source locations for entities unless+-- we compiled the module.+--+-- - extract createTagsFile so it can be used from the command-line+-- (probably need to fix first problem before this is useful).+--+createTagsFile :: TagsKind -> FilePath -> GHCi ()+createTagsFile tagskind tagsFile = do+ graph <- GHC.getModuleGraph+ mtags <- mapM listModuleTags (map GHC.ms_mod $ GHC.mgModSummaries graph)+ either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags+ case either_res of+ Left e -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e+ Right _ -> return ()+++listModuleTags :: GHC.Module -> GHCi [TagInfo]+listModuleTags m = do+ is_interpreted <- GHC.moduleIsInterpreted m+ -- should we just skip these?+ when (not is_interpreted) $+ let mName = GHC.moduleNameString (GHC.moduleName m) in+ throwGhcException (CmdLineError ("module '" ++ mName ++ "' is not interpreted"))+ mbModInfo <- GHC.getModuleInfo m+ case mbModInfo of+ Nothing -> return []+ Just mInfo -> do+ dflags <- getDynFlags+ mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo+ let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual+ let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo+ let localNames = filter ((m==) . nameModule) names+ mbTyThings <- mapM GHC.lookupName localNames+ return $! [ tagInfo dflags unqual exported kind name realLoc+ | tyThing <- catMaybes mbTyThings+ , let name = getName tyThing+ , let exported = GHC.modInfoIsExportedName mInfo name+ , let kind = tyThing2TagKind tyThing+ , let loc = srcSpanStart (nameSrcSpan name)+ , RealSrcLoc realLoc <- [loc]+ ]++ where+ tyThing2TagKind (AnId _) = 'v'+ tyThing2TagKind (AConLike RealDataCon{}) = 'd'+ tyThing2TagKind (AConLike PatSynCon{}) = 'p'+ tyThing2TagKind (ATyCon _) = 't'+ tyThing2TagKind (ACoAxiom _) = 'x'+++data TagInfo = TagInfo+ { tagExported :: Bool -- is tag exported+ , tagKind :: Char -- tag kind+ , tagName :: String -- tag name+ , tagFile :: String -- file name+ , tagLine :: Int -- line number+ , tagCol :: Int -- column number+ , tagSrcInfo :: Maybe (String,Integer) -- source code line and char offset+ }+++-- get tag info, for later translation into Vim or Emacs style+tagInfo :: DynFlags -> PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc+ -> TagInfo+tagInfo dflags unqual exported kind name loc+ = TagInfo exported kind+ (showSDocForUser dflags unqual $ pprOccName (nameOccName name))+ (showSDocForUser dflags unqual $ ftext (srcLocFile loc))+ (srcLocLine loc) (srcLocCol loc) Nothing++-- throw an exception when someone tries to overwrite existing source file (fix for #10989)+writeTagsSafely :: FilePath -> String -> IO ()+writeTagsSafely file str = do+ dfe <- doesFileExist file+ if dfe && isSourceFilename file+ then throwGhcException (CmdLineError (file ++ " is existing source file. " +++ "Please specify another file name to store tags data"))+ else writeFile file str++collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())+-- ctags style with the Ex expression being just the line number, Vim et al+collateAndWriteTags CTagsWithLineNumbers file tagInfos = do+ let tags = unlines $ sort $ map showCTag tagInfos+ tryIO (writeTagsSafely file tags)++-- ctags style with the Ex expression being a regex searching the line, Vim et al+collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al+ tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos+ let tags = unlines $ sort $ map showCTag $concat tagInfoGroups+ tryIO (writeTagsSafely file tags)++collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs+ tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos+ let tagGroups = map processGroup tagInfoGroups+ tryIO (writeTagsSafely file $ concat tagGroups)++ where+ processGroup [] = throwGhcException (CmdLineError "empty tag file group??")+ processGroup group@(tagInfo:_) =+ let tags = unlines $ map showETag group in+ "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags+++makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]]+makeTagGroupsWithSrcInfo tagInfos = do+ let groups = groupBy ((==) `on` tagFile) $ sortBy (comparing tagFile) tagInfos+ mapM addTagSrcInfo groups++ where+ addTagSrcInfo [] = throwGhcException (CmdLineError "empty tag file group??")+ addTagSrcInfo group@(tagInfo:_) = do+ file <- readFile $tagFile tagInfo+ let sortedGroup = sortBy (comparing tagLine) group+ return $ perFile sortedGroup 1 0 $ lines file++ perFile allTags@(tag:tags) cnt pos allLs@(l:ls)+ | tagLine tag > cnt =+ perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls+ | tagLine tag == cnt =+ tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs+ perFile _ _ _ _ = []+++-- ctags format, for Vim et al+showCTag :: TagInfo -> String+showCTag ti =+ tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" +++ tagKind ti : ( if tagExported ti then "" else "\tfile:" )++ where+ tagCmd =+ case tagSrcInfo ti of+ Nothing -> show $tagLine ti+ Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/"++ where+ escapeSlashes '/' r = '\\' : '/' : r+ escapeSlashes '\\' r = '\\' : '\\' : r+ escapeSlashes c r = c : r+++-- etags format, for Emacs/XEmacs+showETag :: TagInfo -> String+showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo,+ tagSrcInfo = Just (srcLine,charPos) }+ = take (colNo - 1) srcLine ++ tag+ ++ "\x7f" ++ tag+ ++ "\x01" ++ show lineNo+ ++ "," ++ show charPos+showETag _ = throwGhcException (CmdLineError "missing source file info in showETag")
+ src-bin-881/Clash/GHCi/Util.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE MagicHash, UnboxedTuples #-}++-- | Utilities for GHCi.+module Clash.GHCi.Util where++-- NOTE: Avoid importing GHC modules here, because the primary purpose+-- of this module is to not use UnboxedTuples in a module that imports+-- lots of other modules. See issue#13101 for more info.++import GHC.Exts+import GHC.Types++anyToPtr :: a -> IO (Ptr ())+anyToPtr x =+ IO (\s -> case anyToAddr# x s of+ (# s', addr #) -> (# s', Ptr addr #)) :: IO (Ptr ())
+ src-bin-881/Clash/Main.hs view
@@ -0,0 +1,1045 @@+{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables, TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}++-----------------------------------------------------------------------------+--+-- GHC Driver program+--+-- (c) The University of Glasgow 2005+--+-----------------------------------------------------------------------------++module Clash.Main (defaultMain) where++-- The official GHC API+import qualified GHC+import GHC ( -- DynFlags(..), HscTarget(..),+ -- GhcMode(..), GhcLink(..),+ Ghc, GhcMonad(..),+ LoadHowMuch(..) )+import CmdLineParser++-- Implementations of the various modes (--show-iface, mkdependHS. etc.)+import LoadIface ( showIface )+import HscMain ( newHscEnv )+import DriverPipeline ( oneShot, compileFile )+import DriverMkDepend ( doMkDependHS )+import DriverBkp ( doBackpack )+#if defined(GHCI)+import Clash.GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )+#endif++-- Frontend plugins+#if defined(GHCI)+import DynamicLoading ( loadFrontendPlugin )+import Plugins+#else+import DynamicLoading ( pluginError )+#endif+import Module ( ModuleName )+++-- Various other random stuff that we need+import GHC.HandleEncoding+import Config+import Constants+import HscTypes+import Packages ( pprPackages, pprPackagesSimple )+import DriverPhases+import BasicTypes ( failed )+import DynFlags hiding (WarnReason(..))+import ErrUtils+import FastString+import Outputable+import SrcLoc+import Util+import Panic+import UniqSupply+import MonadUtils ( liftIO )+import DynamicLoading ( initializePlugins )++-- Imports for --abi-hash+import LoadIface ( loadUserInterface )+import Module ( mkModuleName )+import Finder ( findImportedModule, cannotFindModule )+import TcRnMonad ( initIfaceCheck )+import Binary ( openBinMem, put_ )+import BinFingerprint ( fingerprintBinMem )++-- Standard Haskell libraries+import System.IO+import System.Environment+import System.Exit+import System.FilePath+import Control.Monad+import Data.Char+import Data.List+import Data.Maybe++-- clash additions+import Paths_clash_ghc+import Clash.GHCi.UI (makeHDL)+import Exception (gcatch)+import Data.IORef (IORef, newIORef, readIORef)+import qualified Data.Version (showVersion)++import qualified Clash.Backend+import Clash.Backend.SystemVerilog (SystemVerilogState)+import Clash.Backend.VHDL (VHDLState)+import Clash.Backend.Verilog (VerilogState)+import Clash.Driver.Types+ (ClashOpts (..), defClashOpts)+import Clash.GHC.ClashFlags+import Clash.Netlist.BlackBox.Types (HdlSyn (..))+import Clash.Util (clashLibVersion)+import Clash.GHC.LoadModules (ghcLibDir, wantedLanguageExtensions)+import Clash.GHC.Util (handleClashException)++-----------------------------------------------------------------------------+-- ToDo:++-- time commands when run with -v+-- user ways+-- Win32 support: proper signal handling+-- reading the package configuration file is too slow+-- -K<size>++-----------------------------------------------------------------------------+-- GHC's command-line interface++defaultMain :: [String] -> IO ()+defaultMain = flip withArgs $ do+ initGCStatistics -- See Note [-Bsymbolic and hooks]+ hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering++ configureHandleEncoding+ GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do+ -- 1. extract the -B flag from the args+ argv0 <- getArgs++ -- let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0+ -- mbMinusB | null minusB_args = Nothing+ -- | otherwise = Just (drop 2 (last minusB_args))++ let argv1 = map (mkGeneralLocated "on the commandline") argv0+ libDir <- ghcLibDir++ r <- newIORef defClashOpts+ (argv2, clashFlagWarnings) <- parseClashFlags r argv1++ -- 2. Parse the "mode" flags (--make, --interactive etc.)+ (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2+ let flagWarnings = modeFlagWarnings ++ clashFlagWarnings++ -- If all we want to do is something like showing the version number+ -- then do it now, before we start a GHC session etc. This makes+ -- getting basic information much more resilient.++ -- In particular, if we wait until later before giving the version+ -- number then bootstrapping gets confused, as it tries to find out+ -- what version of GHC it's using before package.conf exists, so+ -- starting the session fails.+ case mode of+ Left preStartupMode ->+ do case preStartupMode of+ ShowSupportedExtensions -> showSupportedExtensions+ ShowVersion -> showVersion+ ShowNumVersion -> putStrLn cProjectVersion+ ShowOptions isInteractive -> showOptions isInteractive+ Right postStartupMode ->+ -- start our GHC session+ GHC.runGhc (Just libDir) $ do++ dflags <- GHC.getSessionDynFlags+ let dflagsExtra = wantedLanguageExtensions dflags++ ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise"+ ghcTyLitExtrPlugin = GHC.mkModuleName "GHC.TypeLits.Extra.Solver"+ ghcTyLitKNPlugin = GHC.mkModuleName "GHC.TypeLits.KnownNat.Solver"+ dflagsExtra1 = dflagsExtra+ { DynFlags.pluginModNames = nub $+ ghcTyLitNormPlugin : ghcTyLitExtrPlugin :+ ghcTyLitKNPlugin :+ DynFlags.pluginModNames dflagsExtra+ }++ case postStartupMode of+ Left preLoadMode ->+ liftIO $ do+ case preLoadMode of+ ShowInfo -> showInfo dflagsExtra1+ ShowGhcUsage -> showGhcUsage dflagsExtra1+ ShowGhciUsage -> showGhciUsage dflagsExtra1+ PrintWithDynFlags f -> putStrLn (f dflagsExtra1)+ Right postLoadMode ->+ main' postLoadMode dflagsExtra1 argv3 flagWarnings r++main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn]+ -> IORef ClashOpts+ -> Ghc ()+main' postLoadMode dflags0 args flagWarnings clashOpts = do+ -- set the default GhcMode, HscTarget and GhcLink. The HscTarget+ -- can be further adjusted on a module by module basis, using only+ -- the -fvia-C and -fasm flags. If the default HscTarget is not+ -- HscC or HscAsm, -fvia-C and -fasm have no effect.+ let dflt_target = hscTarget dflags0+ (mode, lang, link)+ = case postLoadMode of+ DoInteractive -> (CompManager, HscInterpreted, LinkInMemory)+ DoEval _ -> (CompManager, HscInterpreted, LinkInMemory)+ DoMake -> (CompManager, dflt_target, LinkBinary)+ DoBackpack -> (CompManager, dflt_target, LinkBinary)+ DoMkDependHS -> (MkDepend, dflt_target, LinkBinary)+ DoAbiHash -> (OneShot, dflt_target, LinkBinary)+ DoVHDL -> (CompManager, HscNothing, NoLink)+ DoVerilog -> (CompManager, HscNothing, NoLink)+ DoSystemVerilog -> (CompManager, HscNothing, NoLink)+ _ -> (OneShot, dflt_target, LinkBinary)++ let dflags1 = dflags0{ ghcMode = mode,+ hscTarget = lang,+ ghcLink = link,+ verbosity = case postLoadMode of+ DoEval _ -> 0+ _other -> 1+ }++ -- turn on -fimplicit-import-qualified for GHCi now, so that it+ -- can be overriden from the command-line+ -- XXX: this should really be in the interactive DynFlags, but+ -- we don't set that until later in interactiveUI+ -- We also set -fignore-optim-changes and -fignore-hpc-changes,+ -- which are program-level options. Again, this doesn't really+ -- feel like the right place to handle this, but we don't have+ -- a great story for the moment.+ dflags2 | DoInteractive <- postLoadMode = def_ghci_flags+ | DoEval _ <- postLoadMode = def_ghci_flags+ | otherwise = dflags1+ where def_ghci_flags = dflags1 `gopt_set` Opt_ImplicitImportQualified+ `gopt_set` Opt_IgnoreOptimChanges+ `gopt_set` Opt_IgnoreHpcChanges++ -- The rest of the arguments are "dynamic"+ -- Leftover ones are presumably files+ (dflags3, fileish_args, dynamicFlagWarnings) <-+ GHC.parseDynamicFlags dflags2 args++ let dflags4 = case lang of+ HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) ->+ let platform = targetPlatform dflags3+ dflags3a = updateWays $ dflags3 { ways = interpWays }+ dflags3b = foldl gopt_set dflags3a+ $ concatMap (wayGeneralFlags platform)+ interpWays+ dflags3c = foldl gopt_unset dflags3b+ $ concatMap (wayUnsetGeneralFlags platform)+ interpWays+ in dflags3c+ _ ->+ dflags3++ GHC.prettyPrintGhcErrors dflags4 $ do++ let flagWarnings' = flagWarnings ++ dynamicFlagWarnings++ handleSourceError (\e -> do+ GHC.printException e+ liftIO $ exitWith (ExitFailure 1)) $ do+ liftIO $ handleFlagWarnings dflags4 flagWarnings'++ liftIO $ showBanner postLoadMode dflags4++ let+ -- To simplify the handling of filepaths, we normalise all filepaths right+ -- away. Note the asymmetry of FilePath.normalise:+ -- Linux: p/q -> p/q; p\q -> p\q+ -- Windows: p/q -> p\q; p\q -> p\q+ -- #12674: Filenames starting with a hypen get normalised from ./-foo.hs+ -- to -foo.hs. We have to re-prepend the current directory.+ normalise_hyp fp+ | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp+ | otherwise = nfp+ where+#if defined(mingw32_HOST_OS)+ strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp+#else+ strt_dot_sl = "./" `isPrefixOf` fp+#endif+ cur_dir = '.' : [pathSeparator]+ nfp = normalise fp+ normal_fileish_paths = map (normalise_hyp . unLoc) fileish_args+ (srcs, objs) = partition_args normal_fileish_paths [] []++ dflags5 = dflags4 { ldInputs = map (FileOption "") objs+ ++ ldInputs dflags4 }++ -- we've finished manipulating the DynFlags, update the session+ _ <- GHC.setSessionDynFlags dflags5+ dflags6 <- GHC.getSessionDynFlags+ hsc_env <- GHC.getSession++ ---------------- Display configuration -----------+ case verbosity dflags6 of+ v | v == 4 -> liftIO $ dumpPackagesSimple dflags6+ | v >= 5 -> liftIO $ dumpPackages dflags6+ | otherwise -> return ()++ liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6)+ ---------------- Final sanity checking -----------+ liftIO $ checkOptions postLoadMode dflags6 srcs objs++ ---------------- Do the business -----------+ handleSourceError (\e -> do+ GHC.printException e+ liftIO $ exitWith (ExitFailure 1)) $ do+ clashOpts' <- liftIO (readIORef clashOpts)+ let clash fun = gcatch (fun clashOpts srcs) (handleClashException dflags6 clashOpts')+ case postLoadMode of+ ShowInterface f -> liftIO $ doShowIface dflags6 f+ DoMake -> doMake srcs+ DoMkDependHS -> doMkDependHS (map fst srcs)+ StopBefore p -> liftIO (oneShot hsc_env p srcs)+ DoInteractive -> ghciUI clashOpts hsc_env dflags6 srcs Nothing+ DoEval exprs -> ghciUI clashOpts hsc_env dflags6 srcs $ Just $+ reverse exprs+ DoAbiHash -> abiHash (map fst srcs)+ ShowPackages -> liftIO $ showPackages dflags6+ DoFrontend f -> doFrontend f srcs+ DoBackpack -> doBackpack (map fst srcs)+ DoVHDL -> clash makeVHDL+ DoVerilog -> clash makeVerilog+ DoSystemVerilog -> clash makeSystemVerilog++ liftIO $ dumpFinalStats dflags6++ghciUI :: IORef ClashOpts -> HscEnv -> DynFlags -> [(FilePath, Maybe Phase)] -> Maybe [String]+ -> Ghc ()+#if !defined(GHCI)+ghciUI _ _ _ _ _ = throwGhcException (CmdLineError "not built for interactive use")+#else+ghciUI clashOpts hsc_env dflags0 srcs maybe_expr = do+ dflags1 <- liftIO (initializePlugins hsc_env dflags0)+ _ <- GHC.setSessionDynFlags dflags1+ interactiveUI (defaultGhciSettings clashOpts) srcs maybe_expr+#endif++-- -----------------------------------------------------------------------------+-- Splitting arguments into source files and object files. This is where we+-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source+-- file indicating the phase specified by the -x option in force, if any.++partition_args :: [String] -> [(String, Maybe Phase)] -> [String]+ -> ([(String, Maybe Phase)], [String])+partition_args [] srcs objs = (reverse srcs, reverse objs)+partition_args ("-x":suff:args) srcs objs+ | "none" <- suff = partition_args args srcs objs+ | StopLn <- phase = partition_args args srcs (slurp ++ objs)+ | otherwise = partition_args rest (these_srcs ++ srcs) objs+ where phase = startPhase suff+ (slurp,rest) = break (== "-x") args+ these_srcs = zip slurp (repeat (Just phase))+partition_args (arg:args) srcs objs+ | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs+ | otherwise = partition_args args srcs (arg:objs)++ {-+ We split out the object files (.o, .dll) and add them+ to ldInputs for use by the linker.++ The following things should be considered compilation manager inputs:++ - haskell source files (strings ending in .hs, .lhs or other+ haskellish extension),++ - module names (not forgetting hierarchical module names),++ - things beginning with '-' are flags that were not recognised by+ the flag parser, and we want them to generate errors later in+ checkOptions, so we class them as source files (#5921)++ - and finally we consider everything without an extension to be+ a comp manager input, as shorthand for a .hs or .lhs filename.++ Everything else is considered to be a linker object, and passed+ straight through to the linker.+ -}+looks_like_an_input :: String -> Bool+looks_like_an_input m = isSourceFilename m+ || looksLikeModuleName m+ || "-" `isPrefixOf` m+ || not (hasExtension m)++-- -----------------------------------------------------------------------------+-- Option sanity checks++-- | Ensure sanity of options.+--+-- Throws 'UsageError' or 'CmdLineError' if not.+checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()+ -- Final sanity checking before kicking off a compilation (pipeline).+checkOptions mode dflags srcs objs = do+ -- Complain about any unknown flags+ let unknown_opts = [ f | (f@('-':_), _) <- srcs ]+ when (notNull unknown_opts) (unknownFlagsErr unknown_opts)++ when (notNull (filter wayRTSOnly (ways dflags))+ && isInterpretiveMode mode) $+ hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")++ -- -prof and --interactive are not a good combination+ when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays)+ && isInterpretiveMode mode+ && not (gopt Opt_ExternalInterpreter dflags)) $+ do throwGhcException (UsageError+ "-fexternal-interpreter is required when using --interactive with a non-standard way (-prof, -static, or -dynamic).")+ -- -ohi sanity check+ if (isJust (outputHi dflags) &&+ (isCompManagerMode mode || srcs `lengthExceeds` 1))+ then throwGhcException (UsageError "-ohi can only be used when compiling a single source file")+ else do++ -- -o sanity checking+ if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)+ && not (isLinkMode mode))+ then throwGhcException (UsageError "can't apply -o to multiple source files")+ else do++ let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)++ when (not_linking && not (null objs)) $+ hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)++ -- Check that there are some input files+ -- (except in the interactive case)+ if null srcs && (null objs || not_linking) && needsInputsMode mode+ then throwGhcException (UsageError "no input files")+ else do++ case mode of+ StopBefore HCc | hscTarget dflags /= HscC+ -> throwGhcException $ UsageError $+ "the option -C is only available with an unregisterised GHC"+ _ -> return ()++ -- Verify that output files point somewhere sensible.+ verifyOutputFiles dflags++-- Compiler output options++-- Called to verify that the output files point somewhere valid.+--+-- The assumption is that the directory portion of these output+-- options will have to exist by the time 'verifyOutputFiles'+-- is invoked.+--+-- We create the directories for -odir, -hidir, -outputdir etc. ourselves if+-- they don't exist, so don't check for those here (#2278).+verifyOutputFiles :: DynFlags -> IO ()+verifyOutputFiles dflags = do+ let ofile = outputFile dflags+ when (isJust ofile) $ do+ let fn = fromJust ofile+ flg <- doesDirNameExist fn+ when (not flg) (nonExistentDir "-o" fn)+ let ohi = outputHi dflags+ when (isJust ohi) $ do+ let hi = fromJust ohi+ flg <- doesDirNameExist hi+ when (not flg) (nonExistentDir "-ohi" hi)+ where+ nonExistentDir flg dir =+ throwGhcException (CmdLineError ("error: directory portion of " +++ show dir ++ " does not exist (used with " +++ show flg ++ " option.)"))++-----------------------------------------------------------------------------+-- GHC modes of operation++type Mode = Either PreStartupMode PostStartupMode+type PostStartupMode = Either PreLoadMode PostLoadMode++data PreStartupMode+ = ShowVersion -- ghc -V/--version+ | ShowNumVersion -- ghc --numeric-version+ | ShowSupportedExtensions -- ghc --supported-extensions+ | ShowOptions Bool {- isInteractive -} -- ghc --show-options++showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode+showVersionMode = mkPreStartupMode ShowVersion+showNumVersionMode = mkPreStartupMode ShowNumVersion+showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions+showOptionsMode = mkPreStartupMode (ShowOptions False)++mkPreStartupMode :: PreStartupMode -> Mode+mkPreStartupMode = Left++isShowVersionMode :: Mode -> Bool+isShowVersionMode (Left ShowVersion) = True+isShowVersionMode _ = False++isShowNumVersionMode :: Mode -> Bool+isShowNumVersionMode (Left ShowNumVersion) = True+isShowNumVersionMode _ = False++data PreLoadMode+ = ShowGhcUsage -- ghc -?+ | ShowGhciUsage -- ghci -?+ | ShowInfo -- ghc --info+ | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo++showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode+showGhcUsageMode = mkPreLoadMode ShowGhcUsage+showGhciUsageMode = mkPreLoadMode ShowGhciUsage+showInfoMode = mkPreLoadMode ShowInfo++printSetting :: String -> Mode+printSetting k = mkPreLoadMode (PrintWithDynFlags f)+ where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))+ $ lookup k (compilerInfo dflags)++mkPreLoadMode :: PreLoadMode -> Mode+mkPreLoadMode = Right . Left++isShowGhcUsageMode :: Mode -> Bool+isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True+isShowGhcUsageMode _ = False++isShowGhciUsageMode :: Mode -> Bool+isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True+isShowGhciUsageMode _ = False++data PostLoadMode+ = ShowInterface FilePath -- ghc --show-iface+ | DoMkDependHS -- ghc -M+ | StopBefore Phase -- ghc -E | -C | -S+ -- StopBefore StopLn is the default+ | DoMake -- ghc --make+ | DoBackpack -- ghc --backpack foo.bkp+ | DoInteractive -- ghc --interactive+ | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]+ | DoAbiHash -- ghc --abi-hash+ | ShowPackages -- ghc --show-packages+ | DoFrontend ModuleName -- ghc --frontend Plugin.Module+ | DoVHDL -- ghc --vhdl+ | DoVerilog -- ghc --verilog+ | DoSystemVerilog -- ghc --systemverilog++doMkDependHSMode, doMakeMode, doInteractiveMode,+ doAbiHashMode, showPackagesMode, doVHDLMode, doVerilogMode,+ doSystemVerilogMode :: Mode+doMkDependHSMode = mkPostLoadMode DoMkDependHS+doMakeMode = mkPostLoadMode DoMake+doInteractiveMode = mkPostLoadMode DoInteractive+doAbiHashMode = mkPostLoadMode DoAbiHash+showPackagesMode = mkPostLoadMode ShowPackages+doVHDLMode = mkPostLoadMode DoVHDL+doVerilogMode = mkPostLoadMode DoVerilog+doSystemVerilogMode = mkPostLoadMode DoSystemVerilog++showInterfaceMode :: FilePath -> Mode+showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)++stopBeforeMode :: Phase -> Mode+stopBeforeMode phase = mkPostLoadMode (StopBefore phase)++doEvalMode :: String -> Mode+doEvalMode str = mkPostLoadMode (DoEval [str])++doFrontendMode :: String -> Mode+doFrontendMode str = mkPostLoadMode (DoFrontend (mkModuleName str))++doBackpackMode :: Mode+doBackpackMode = mkPostLoadMode DoBackpack++mkPostLoadMode :: PostLoadMode -> Mode+mkPostLoadMode = Right . Right++isDoInteractiveMode :: Mode -> Bool+isDoInteractiveMode (Right (Right DoInteractive)) = True+isDoInteractiveMode _ = False++isStopLnMode :: Mode -> Bool+isStopLnMode (Right (Right (StopBefore StopLn))) = True+isStopLnMode _ = False++isDoMakeMode :: Mode -> Bool+isDoMakeMode (Right (Right DoMake)) = True+isDoMakeMode _ = False++isDoEvalMode :: Mode -> Bool+isDoEvalMode (Right (Right (DoEval _))) = True+isDoEvalMode _ = False++#if defined(GHCI)+isInteractiveMode :: PostLoadMode -> Bool+isInteractiveMode DoInteractive = True+isInteractiveMode _ = False+#endif++-- isInterpretiveMode: byte-code compiler involved+isInterpretiveMode :: PostLoadMode -> Bool+isInterpretiveMode DoInteractive = True+isInterpretiveMode (DoEval _) = True+isInterpretiveMode _ = False++needsInputsMode :: PostLoadMode -> Bool+needsInputsMode DoMkDependHS = True+needsInputsMode (StopBefore _) = True+needsInputsMode DoMake = True+needsInputsMode DoVHDL = True+needsInputsMode DoVerilog = True+needsInputsMode DoSystemVerilog = True+needsInputsMode _ = False++-- True if we are going to attempt to link in this mode.+-- (we might not actually link, depending on the GhcLink flag)+isLinkMode :: PostLoadMode -> Bool+isLinkMode (StopBefore StopLn) = True+isLinkMode DoMake = True+isLinkMode DoInteractive = True+isLinkMode (DoEval _) = True+isLinkMode _ = False++isCompManagerMode :: PostLoadMode -> Bool+isCompManagerMode DoMake = True+isCompManagerMode DoInteractive = True+isCompManagerMode (DoEval _) = True+isCompManagerMode DoVHDL = True+isCompManagerMode DoVerilog = True+isCompManagerMode DoSystemVerilog = True+isCompManagerMode _ = False++-- -----------------------------------------------------------------------------+-- Parsing the mode flag++parseModeFlags :: [Located String]+ -> IO (Mode,+ [Located String],+ [Warn])+parseModeFlags args = do+ let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =+ runCmdLine (processArgs mode_flags args)+ (Nothing, [], [])+ mode = case mModeFlag of+ Nothing -> doMakeMode+ Just (m, _) -> m++ -- See Note [Handling errors when parsing commandline flags]+ unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $+ map (("on the commandline", )) $ map (unLoc . errMsg) errs1 ++ errs2++ return (mode, flags' ++ leftover, warns)++type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])+ -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)+ -- so we collect the new ones and return them.++mode_flags :: [Flag ModeM]+mode_flags =+ [ ------- help / version ----------------------------------------------+ defFlag "?" (PassFlag (setMode showGhcUsageMode))+ , defFlag "-help" (PassFlag (setMode showGhcUsageMode))+ , defFlag "V" (PassFlag (setMode showVersionMode))+ , defFlag "-version" (PassFlag (setMode showVersionMode))+ , defFlag "-numeric-version" (PassFlag (setMode showNumVersionMode))+ , defFlag "-info" (PassFlag (setMode showInfoMode))+ , defFlag "-show-options" (PassFlag (setMode showOptionsMode))+ , defFlag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))+ , defFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))+ , defFlag "-show-packages" (PassFlag (setMode showPackagesMode))+ ] +++ [ defFlag k' (PassFlag (setMode (printSetting k)))+ | k <- ["Project version",+ "Project Git commit id",+ "Booter version",+ "Stage",+ "Build platform",+ "Host platform",+ "Target platform",+ "Have interpreter",+ "Object splitting supported",+ "Have native code generator",+ "Support SMP",+ "Unregisterised",+ "Tables next to code",+ "RTS ways",+ "Leading underscore",+ "Debug on",+ "LibDir",+ "Global Package DB",+ "C compiler flags",+ "C compiler link flags",+ "ld flags"],+ let k' = "-print-" ++ map (replaceSpace . toLower) k+ replaceSpace ' ' = '-'+ replaceSpace c = c+ ] +++ ------- interfaces ----------------------------------------------------+ [ defFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)+ "--show-iface"))++ ------- primary modes ------------------------------------------------+ , defFlag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f+ addFlag "-no-link" f))+ , defFlag "M" (PassFlag (setMode doMkDependHSMode))+ , defFlag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))+ , defFlag "C" (PassFlag (setMode (stopBeforeMode HCc)))+ , defFlag "S" (PassFlag (setMode (stopBeforeMode (As False))))+ , defFlag "-make" (PassFlag (setMode doMakeMode))+ , defFlag "-backpack" (PassFlag (setMode doBackpackMode))+ , defFlag "-interactive" (PassFlag (setMode doInteractiveMode))+ , defFlag "-abi-hash" (PassFlag (setMode doAbiHashMode))+ , defFlag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))+ , defFlag "-frontend" (SepArg (\s -> setMode (doFrontendMode s) "-frontend"))+ , defFlag "-vhdl" (PassFlag (setMode doVHDLMode))+ , defFlag "-verilog" (PassFlag (setMode doVerilogMode))+ , defFlag "-systemverilog" (PassFlag (setMode doSystemVerilogMode))+ ]++setMode :: Mode -> String -> EwM ModeM ()+setMode newMode newFlag = liftEwM $ do+ (mModeFlag, errs, flags') <- getCmdLineState+ let (modeFlag', errs') =+ case mModeFlag of+ Nothing -> ((newMode, newFlag), errs)+ Just (oldMode, oldFlag) ->+ case (oldMode, newMode) of+ -- -c/--make are allowed together, and mean --make -no-link+ _ | isStopLnMode oldMode && isDoMakeMode newMode+ || isStopLnMode newMode && isDoMakeMode oldMode ->+ ((doMakeMode, "--make"), [])++ -- If we have both --help and --interactive then we+ -- want showGhciUsage+ _ | isShowGhcUsageMode oldMode &&+ isDoInteractiveMode newMode ->+ ((showGhciUsageMode, oldFlag), [])+ | isShowGhcUsageMode newMode &&+ isDoInteractiveMode oldMode ->+ ((showGhciUsageMode, newFlag), [])++ -- If we have both -e and --interactive then -e always wins+ _ | isDoEvalMode oldMode &&+ isDoInteractiveMode newMode ->+ ((oldMode, oldFlag), [])+ | isDoEvalMode newMode &&+ isDoInteractiveMode oldMode ->+ ((newMode, newFlag), [])++ -- Otherwise, --help/--version/--numeric-version always win+ | isDominantFlag oldMode -> ((oldMode, oldFlag), [])+ | isDominantFlag newMode -> ((newMode, newFlag), [])+ -- We need to accumulate eval flags like "-e foo -e bar"+ (Right (Right (DoEval esOld)),+ Right (Right (DoEval [eNew]))) ->+ ((Right (Right (DoEval (eNew : esOld))), oldFlag),+ errs)+ -- Saying e.g. --interactive --interactive is OK+ _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)++ -- --interactive and --show-options are used together+ (Right (Right DoInteractive), Left (ShowOptions _)) ->+ ((Left (ShowOptions True),+ "--interactive --show-options"), errs)+ (Left (ShowOptions _), (Right (Right DoInteractive))) ->+ ((Left (ShowOptions True),+ "--show-options --interactive"), errs)+ -- Otherwise, complain+ _ -> let err = flagMismatchErr oldFlag newFlag+ in ((oldMode, oldFlag), err : errs)+ putCmdLineState (Just modeFlag', errs', flags')+ where isDominantFlag f = isShowGhcUsageMode f ||+ isShowGhciUsageMode f ||+ isShowVersionMode f ||+ isShowNumVersionMode f++flagMismatchErr :: String -> String -> String+flagMismatchErr oldFlag newFlag+ = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'"++addFlag :: String -> String -> EwM ModeM ()+addFlag s flag = liftEwM $ do+ (m, e, flags') <- getCmdLineState+ putCmdLineState (m, e, mkGeneralLocated loc s : flags')+ where loc = "addFlag by " ++ flag ++ " on the commandline"++-- ----------------------------------------------------------------------------+-- Run --make mode++doMake :: [(String,Maybe Phase)] -> Ghc ()+doMake srcs = do+ let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs++ hsc_env <- GHC.getSession++ -- if we have no haskell sources from which to do a dependency+ -- analysis, then just do one-shot compilation and/or linking.+ -- This means that "ghc Foo.o Bar.o -o baz" links the program as+ -- we expect.+ if (null hs_srcs)+ then liftIO (oneShot hsc_env StopLn srcs)+ else do++ o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)+ non_hs_srcs+ dflags <- GHC.getSessionDynFlags+ let dflags' = dflags { ldInputs = map (FileOption "") o_files+ ++ ldInputs dflags }+ _ <- GHC.setSessionDynFlags dflags'++ targets <- mapM (uncurry GHC.guessTarget) hs_srcs+ GHC.setTargets targets+ ok_flag <- GHC.load LoadAllTargets++ when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))+ return ()+++-- ---------------------------------------------------------------------------+-- --show-iface mode++doShowIface :: DynFlags -> FilePath -> IO ()+doShowIface dflags file = do+ hsc_env <- newHscEnv dflags+ showIface hsc_env file++-- ---------------------------------------------------------------------------+-- Various banners and verbosity output.++showBanner :: PostLoadMode -> DynFlags -> IO ()+showBanner _postLoadMode dflags = do+ let verb = verbosity dflags++#if defined(GHCI)+ -- Show the GHCi banner+ when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg+#endif++ -- Display details of the configuration in verbose mode+ when (verb >= 2) $+ do hPutStr stderr "Glasgow Haskell Compiler, Version "+ hPutStr stderr cProjectVersion+ hPutStr stderr ", stage "+ hPutStr stderr cStage+ hPutStr stderr " booted by GHC version "+ hPutStrLn stderr cBooterVersion++-- We print out a Read-friendly string, but a prettier one than the+-- Show instance gives us+showInfo :: DynFlags -> IO ()+showInfo dflags = do+ let sq x = " [" ++ x ++ "\n ]"+ putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags++showSupportedExtensions :: IO ()+showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions++showVersion :: IO ()+showVersion = putStrLn $ concat [ "Clash, version "+ , Data.Version.showVersion Paths_clash_ghc.version+ , " (using clash-lib, version: "+ , Data.Version.showVersion clashLibVersion+ , ")"+ ]++showOptions :: Bool -> IO ()+showOptions isInteractive = putStr (unlines availableOptions)+ where+ availableOptions = concat [+ flagsForCompletion isInteractive,+ map ('-':) (getFlagNames mode_flags)+ ]+ getFlagNames opts = map flagName opts++showGhcUsage :: DynFlags -> IO ()+showGhcUsage = showUsage False++showGhciUsage :: DynFlags -> IO ()+showGhciUsage = showUsage True++showUsage :: Bool -> DynFlags -> IO ()+showUsage ghci dflags = do+ let usage_path = if ghci then ghciUsagePath dflags+ else ghcUsagePath dflags+ usage <- readFile usage_path+ dump usage+ where+ dump "" = return ()+ dump ('$':'$':s) = putStr progName >> dump s+ dump (c:s) = putChar c >> dump s++dumpFinalStats :: DynFlags -> IO ()+dumpFinalStats dflags =+ when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags++dumpFastStringStats :: DynFlags -> IO ()+dumpFastStringStats dflags = do+ segments <- getFastStringTable+ let buckets = concat segments+ bucketsPerSegment = map length segments+ entriesPerBucket = map length buckets+ entries = sum entriesPerBucket+ hasZ = sum $ map (length . filter hasZEncoding) buckets+ msg = text "FastString stats:" $$ nest 4 (vcat+ [ text "segments: " <+> int (length segments)+ , text "buckets: " <+> int (sum bucketsPerSegment)+ , text "entries: " <+> int entries+ , text "largest segment: " <+> int (maximum bucketsPerSegment)+ , text "smallest segment: " <+> int (minimum bucketsPerSegment)+ , text "longest bucket: " <+> int (maximum entriesPerBucket)+ , text "has z-encoding: " <+> (hasZ `pcntOf` entries)+ ])+ -- we usually get more "has z-encoding" than "z-encoded", because+ -- when we z-encode a string it might hash to the exact same string,+ -- which is not counted as "z-encoded". Only strings whose+ -- Z-encoding is different from the original string are counted in+ -- the "z-encoded" total.+ putMsg dflags msg+ where+ x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%'++showPackages, dumpPackages, dumpPackagesSimple :: DynFlags -> IO ()+showPackages dflags = putStrLn (showSDoc dflags (pprPackages dflags))+dumpPackages dflags = putMsg dflags (pprPackages dflags)+dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple dflags)++-- -----------------------------------------------------------------------------+-- Frontend plugin support++doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()+#if !defined(GHCI)+doFrontend modname _ = pluginError [modname]+#else+doFrontend modname srcs = do+ hsc_env <- getSession+ frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname+ frontend frontend_plugin+ (reverse $ frontendPluginOpts (hsc_dflags hsc_env)) srcs+#endif++-- -----------------------------------------------------------------------------+-- ABI hash support++{-+ ghc --abi-hash Data.Foo System.Bar++Generates a combined hash of the ABI for modules Data.Foo and+System.Bar. The modules must already be compiled, and appropriate -i+options may be necessary in order to find the .hi files.++This is used by Cabal for generating the ComponentId for a+package. The ComponentId must change when the visible ABI of+the package chagnes, so during registration Cabal calls ghc --abi-hash+to get a hash of the package's ABI.+-}++-- | Print ABI hash of input modules.+--+-- The resulting hash is the MD5 of the GHC version used (Trac #5328,+-- see 'hiVersion') and of the existing ABI hash from each module (see+-- 'mi_mod_hash').+abiHash :: [String] -- ^ List of module names+ -> Ghc ()+abiHash strs = do+ hsc_env <- getSession+ let dflags = hsc_dflags hsc_env++ liftIO $ do++ let find_it str = do+ let modname = mkModuleName str+ r <- findImportedModule hsc_env modname Nothing+ case r of+ Found _ m -> return m+ _error -> throwGhcException $ CmdLineError $ showSDoc dflags $+ cannotFindModule dflags modname r++ mods <- mapM find_it strs++ let get_iface modl = loadUserInterface False (text "abiHash") modl+ ifaces <- initIfaceCheck (text "abiHash") hsc_env $ mapM get_iface mods++ bh <- openBinMem (3*1024) -- just less than a block+ put_ bh hiVersion+ -- package hashes change when the compiler version changes (for now)+ -- see #5328+ mapM_ (put_ bh . mi_mod_hash) ifaces+ f <- fingerprintBinMem bh++ putStrLn (showPpr dflags f)++-----------------------------------------------------------------------------+-- HDL Generation++makeHDL' :: Clash.Backend.Backend backend => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)+ -> IORef ClashOpts -> [(String,Maybe Phase)] -> Ghc ()+makeHDL' _ _ [] = throwGhcException (CmdLineError "No input files")+makeHDL' backend r srcs = makeHDL backend r $ fmap fst srcs++makeVHDL :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeVHDL = makeHDL' (Clash.Backend.initBackend @VHDLState)++makeVerilog :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeVerilog = makeHDL' (Clash.Backend.initBackend @VerilogState)++makeSystemVerilog :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeSystemVerilog = makeHDL' (Clash.Backend.initBackend @SystemVerilogState)++-- -----------------------------------------------------------------------------+-- Util++unknownFlagsErr :: [String] -> a+unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs+ where+ oneError f =+ "unrecognised flag: " ++ f ++ "\n" +++ (case match f (nubSort allNonDeprecatedFlags) of+ [] -> ""+ suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs))+ -- fixes #11789+ -- If the flag contains '=',+ -- this uses both the whole and the left side of '=' for comparing.+ match f allFlags+ | elem '=' f =+ let (flagsWithEq, flagsWithoutEq) = partition (elem '=') allFlags+ fName = takeWhile (/= '=') f+ in (fuzzyMatch f flagsWithEq) ++ (fuzzyMatch fName flagsWithoutEq)+ | otherwise = fuzzyMatch f allFlags++{- Note [-Bsymbolic and hooks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-Bsymbolic is a flag that prevents the binding of references to global+symbols to symbols outside the shared library being compiled (see `man+ld`). When dynamically linking, we don't use -Bsymbolic on the RTS+package: that is because we want hooks to be overridden by the user,+we don't want to constrain them to the RTS package.++Unfortunately this seems to have broken somehow on OS X: as a result,+defaultHooks (in hschooks.c) is not called, which does not initialize+the GC stats. As a result, this breaks things like `:set +s` in GHCi+(#8754). As a hacky workaround, we instead call 'defaultHooks'+directly to initalize the flags in the RTS.++A byproduct of this, I believe, is that hooks are likely broken on OS+X when dynamically linking. But this probably doesn't affect most+people since we're linking GHC dynamically, but most things themselves+link statically.+-}++-- If GHC_LOADED_INTO_GHCI is not set when GHC is loaded into GHCi, then+-- running it causes an error like this:+--+-- Loading temp shared object failed:+-- /tmp/ghc13836_0/libghc_1872.so: undefined symbol: initGCStatistics+--+-- Skipping the foreign call fixes this problem, and the outer GHCi+-- should have already made this call anyway.+#if defined(GHC_LOADED_INTO_GHCI)+initGCStatistics :: IO ()+initGCStatistics = return ()+#else+foreign import ccall safe "initGCStatistics"+ initGCStatistics :: IO ()+#endif
+ src-bin-common/Clash/GHCi/Common.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}++module Clash.GHCi.Common+ ( checkImportDirs+ , checkMonoLocalBinds+ , checkMonoLocalBindsMod+ ) where++-- Clash+import Clash.Driver.Types (ClashOpts (..))++-- The GHC interface+#if MIN_VERSION_base(4,11,0)+import qualified EnumSet as GHC (member) -- ghc84, ghc86+#else+import qualified Data.IntSet as IntSet -- ghc82+#endif+import qualified GHC (DynFlags, ModSummary (..), Module (..),+ extensionFlags, moduleNameString)+import qualified GHC.LanguageExtensions as LangExt (Extension (..))+import Panic (GhcException (..), throwGhcException)++import Control.Monad (forM_, unless, when)+import System.Directory (doesDirectoryExist)+import System.IO (hPutStrLn, stderr)++-- | Checks whether MonoLocalBinds language extension is enabled or not in+-- modules.+checkMonoLocalBindsMod :: GHC.ModSummary -> IO ()+checkMonoLocalBindsMod x =+ unless (active . GHC.ms_hspp_opts $ x) (hPutStrLn stderr $ msg x)+ where+ msg = messageWith . GHC.moduleNameString . GHC.moduleName . GHC.ms_mod++-- | Checks whether MonoLocalBinds language extension is enabled when generating+-- the HDL directly e.g. in GHCi. modules.+checkMonoLocalBinds :: GHC.DynFlags -> IO ()+checkMonoLocalBinds dflags =+ unless (active dflags) (hPutStrLn stderr $ messageWith "")++messageWith :: String -> String+messageWith srcModule+ | srcModule == [] = msgStem ++ "."+ | otherwise = msgStem ++ " in module: " ++ srcModule+ where+ msgStem = "Warning: Extension MonoLocalBinds disabled. This might lead to unexpected logic duplication"++active :: GHC.DynFlags -> Bool+#if MIN_VERSION_base(4,11,0)+-- ghc84, ghc86+active = GHC.member LangExt.MonoLocalBinds . GHC.extensionFlags+#else+-- ghc82+active = member LangExt.MonoLocalBinds . GHC.extensionFlags++member :: Enum a => a -> IntSet.IntSet -> Bool+member = IntSet.member . fromEnum+#endif++checkImportDirs :: Foldable t => ClashOpts -> t FilePath -> IO ()+checkImportDirs opts idirs = when (opt_checkIDir opts) $+ forM_ idirs $ \dir -> do+ doesDirectoryExist dir >>= \case+ False -> throwGhcException (CmdLineError $ "Missing directory: " ++ dir)+ _ -> return ()
− src-bin/Clash/GHCi/HsVersions.h
@@ -1,68 +0,0 @@-#ifndef HSVERSIONS_H-#define HSVERSIONS_H--#if 0--IMPORTANT! If you put extra tabs/spaces in these macro definitions,-you will screw up the layout where they are used in case expressions!--(This is cpp-dependent, of course)--#endif--/* Useful in the headers that we share with the RTS */-#define COMPILING_GHC 1--/* Pull in all the platform defines for this build (foo_TARGET_ARCH etc.) */-/* #include "ghc_boot_platform.h" */--/* Pull in the autoconf defines (HAVE_FOO), but don't include- * ghcconfig.h, because that will include ghcplatform.h which has the- * wrong platform settings for the compiler (it has the platform- * settings for the target plat instead). */-/* #include "ghcautoconf.h" */--#define GLOBAL_VAR(name,value,ty) \-{-# NOINLINE name #-}; \-name :: IORef (ty); \-name = Util.global (value);--#define GLOBAL_VAR_M(name,value,ty) \-{-# NOINLINE name #-}; \-name :: IORef (ty); \-name = Util.globalM (value);---#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \-{-# NOINLINE name #-}; \-name :: IORef (ty); \-name = Util.sharedGlobal (value) (accessor); \-foreign import ccall unsafe saccessor \- accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));--#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty) \-{-# NOINLINE name #-}; \-name :: IORef (ty); \-name = Util.sharedGlobalM (value) (accessor); \-foreign import ccall unsafe saccessor \- accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));---#define ASSERT(e) if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else-#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else-#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $---- Examples: Assuming flagSet :: String -> m Bool------ do { c <- getChar; MASSERT( isUpper c ); ... }--- do { c <- getChar; MASSERT2( isUpper c, text "Bad" ); ... }--- do { str <- getStr; ASSERTM( flagSet str ); .. }--- do { str <- getStr; ASSERTM2( flagSet str, text "Bad" ); .. }--- do { str <- getStr; WARNM2( flagSet str, text "Flag is set" ); .. }-#define MASSERT(e) ASSERT(e) return ()-#define MASSERT2(e,msg) ASSERT2(e,msg) return ()-#define ASSERTM(e) do { bool <- e; MASSERT(bool) }-#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) }-#define WARNM2(e,msg) do { bool <- e; WARN(bool, msg) return () }--#endif /* HsVersions.h */
− src-bin/Clash/GHCi/UI.hs
@@ -1,3847 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS -fno-cse #-}--- -fno-cse is needed for GLOBAL_VAR's to behave properly------------------------------------------------------------------------------------- GHC Interactive User Interface------ (c) The GHC Team 2005-2006-----------------------------------------------------------------------------------module Clash.GHCi.UI (- interactiveUI,- GhciSettings(..),- defaultGhciSettings,- ghciCommands,- ghciWelcomeMsg,- makeHDL- ) where--#include "HsVersions.h"---- GHCi-import qualified Clash.GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls )-import Clash.GHCi.UI.Monad hiding ( args, runStmt, runDecls )-import Clash.GHCi.UI.Tags-import Clash.GHCi.UI.Info-import Debugger---- The GHC interface-import GHCi-import GHCi.RemoteTypes-import GHCi.BreakArray-import DynFlags-import ErrUtils-import GhcMonad ( modifySession )-import qualified GHC-import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..),- TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,- getModuleGraph, handleSourceError )-import HsImpExp-import HsSyn-import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,- setInteractivePrintName, hsc_dflags, msObjFilePath )-import Module-import Name-import Packages ( trusted, getPackageDetails, getInstalledPackageDetails,- listVisibleModuleNames, pprFlag )-import IfaceSyn ( showToHeader )-import PprTyThing-import PrelNames-import RdrName ( RdrName, getGRE_NameQualifier_maybes, getRdrName )-import SrcLoc-import qualified Lexer--import StringBuffer-import Outputable hiding ( printForUser, printForUserPartWay )---- Other random utilities-import BasicTypes hiding ( isTopLevel )-import Digraph-import Encoding-import FastString-import Linker-import Maybes ( orElse, expectJust )-import NameSet-import Panic hiding ( showException )-import Util-import qualified GHC.LanguageExtensions as LangExt---- Haskell Libraries-import System.Console.Haskeline as Haskeline--import Control.Applicative hiding (empty)-import Control.DeepSeq (deepseq)-import Control.Monad as Monad-import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Control.Monad.Trans.Except--import Data.Array-import qualified Data.ByteString.Char8 as BS-import Data.Char-import Data.Function-import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )-import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,- partition, sort, sortBy )-import qualified Data.Set as S-import Data.Maybe-import qualified Data.Map as M-import Data.Time.LocalTime ( getZonedTime )-import Data.Time.Format ( formatTime, defaultTimeLocale )-import Data.Version ( showVersion )--import Exception hiding (catch)-import Foreign hiding (void)-import GHC.Stack hiding (SrcLoc(..))--import System.Directory-import System.Environment-import System.Exit ( exitWith, ExitCode(..) )-import System.FilePath-import System.Info-import System.IO-import System.IO.Error-import System.IO.Unsafe ( unsafePerformIO )-import System.Process-import Text.Printf-import Text.Read ( readMaybe )-import Text.Read.Lex (isSymbolChar)--import Unsafe.Coerce--#if !defined(mingw32_HOST_OS)-import System.Posix hiding ( getEnv )-#else-import qualified System.Win32-#endif--import GHC.IO.Exception ( IOErrorType(InvalidArgument) )-import GHC.IO.Handle ( hFlushAll )-import GHC.TopHandler ( topHandler )---- clash additions-import qualified Clash.Backend-import Clash.Backend.SystemVerilog (SystemVerilogState)-import Clash.Backend.VHDL (VHDLState)-import Clash.Backend.Verilog (VerilogState)-import qualified Clash.Driver-import Clash.Driver.Types (ClashOpts(..))-import Clash.GHC.Evaluator-import Clash.GHC.GenerateBindings-import Clash.GHC.NetlistTypes-import Clash.Netlist.BlackBox.Types (HdlSyn)-import Clash.Util (clashLibVersion)-import qualified Data.Time.Clock as Clock-import qualified Paths_clash_ghc---------------------------------------------------------------------------------data GhciSettings = GhciSettings {- availableCommands :: [Command],- shortHelpText :: String,- fullHelpText :: String,- defPrompt :: PromptFunction,- defPromptCont :: PromptFunction- }--defaultGhciSettings :: IORef ClashOpts -> GhciSettings-defaultGhciSettings opts =- GhciSettings {- availableCommands = ghciCommands opts,- shortHelpText = defShortHelpText,- defPrompt = default_prompt,- defPromptCont = default_prompt_cont,- fullHelpText = defFullHelpText- }--ghciWelcomeMsg :: String-ghciWelcomeMsg = "CLaSHi, version " ++ Data.Version.showVersion Paths_clash_ghc.version ++- " (using clash-lib, version " ++ Data.Version.showVersion clashLibVersion ++- "):\nhttp://www.clash-lang.org/ :? for help"--ghciCommands :: IORef ClashOpts -> [Command]-ghciCommands opts = map mkCmd [- -- Hugs users are accustomed to :e, so make sure it doesn't overlap- ("?", keepGoing help, noCompletion),- ("add", keepGoingPaths addModule, completeFilename),- ("abandon", keepGoing abandonCmd, noCompletion),- ("break", keepGoing breakCmd, completeIdentifier),- ("back", keepGoing backCmd, noCompletion),- ("browse", keepGoing' (browseCmd False), completeModule),- ("browse!", keepGoing' (browseCmd True), completeModule),- ("cd", keepGoing' changeDirectory, completeFilename),- ("check", keepGoing' checkModule, completeHomeModule),- ("continue", keepGoing continueCmd, noCompletion),- ("cmd", keepGoing cmdCmd, completeExpression),- ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename),- ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename),- ("def", keepGoing (defineMacro False), completeExpression),- ("def!", keepGoing (defineMacro True), completeExpression),- ("delete", keepGoing deleteCmd, noCompletion),- ("edit", keepGoing' editFile, completeFilename),- ("etags", keepGoing createETagsFileCmd, completeFilename),- ("force", keepGoing forceCmd, completeExpression),- ("forward", keepGoing forwardCmd, noCompletion),- ("help", keepGoing help, noCompletion),- ("history", keepGoing historyCmd, noCompletion),- ("info", keepGoing' (info False), completeIdentifier),- ("info!", keepGoing' (info True), completeIdentifier),- ("issafe", keepGoing' isSafeCmd, completeModule),- ("kind", keepGoing' (kindOfType False), completeIdentifier),- ("kind!", keepGoing' (kindOfType True), completeIdentifier),- ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),- ("load!", keepGoingPaths loadModuleDefer, completeHomeModuleOrFile),- ("list", keepGoing' listCmd, noCompletion),- ("module", keepGoing moduleCmd, completeSetModule),- ("main", keepGoing runMain, completeFilename),- ("print", keepGoing printCmd, completeExpression),- ("quit", quit, noCompletion),- ("reload", keepGoing' reloadModule, noCompletion),- ("reload!", keepGoing' reloadModuleDefer, noCompletion),- ("run", keepGoing runRun, completeFilename),- ("script", keepGoing' scriptCmd, completeFilename),- ("set", keepGoing setCmd, completeSetOptions),- ("seti", keepGoing setiCmd, completeSeti),- ("show", keepGoing showCmd, completeShowOptions),- ("showi", keepGoing showiCmd, completeShowiOptions),- ("sprint", keepGoing sprintCmd, completeExpression),- ("step", keepGoing stepCmd, completeIdentifier),- ("steplocal", keepGoing stepLocalCmd, completeIdentifier),- ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),- ("type", keepGoing' typeOfExpr, completeExpression),- ("trace", keepGoing traceCmd, completeExpression),- ("undef", keepGoing undefineMacro, completeMacro),- ("unset", keepGoing unsetOptions, completeSetOptions),- ("where", keepGoing whereCmd, noCompletion),- ("vhdl", keepGoingPaths (makeVHDL opts), completeHomeModuleOrFile),- ("verilog", keepGoingPaths (makeVerilog opts), completeHomeModuleOrFile),- ("systemverilog", keepGoingPaths (makeSystemVerilog opts), completeHomeModuleOrFile)- ] ++ map mkCmdHidden [ -- hidden commands- ("all-types", keepGoing' allTypesCmd),- ("complete", keepGoing completeCmd),- ("loc-at", keepGoing' locAtCmd),- ("type-at", keepGoing' typeAtCmd),- ("uses", keepGoing' usesCmd)- ]- where- mkCmd (n,a,c) = Command { cmdName = n- , cmdAction = a- , cmdHidden = False- , cmdCompletionFunc = c- }-- mkCmdHidden (n,a) = Command { cmdName = n- , cmdAction = a- , cmdHidden = True- , cmdCompletionFunc = noCompletion- }---- We initialize readline (in the interactiveUI function) to use--- word_break_chars as the default set of completion word break characters.--- This can be overridden for a particular command (for example, filename--- expansion shouldn't consider '/' to be a word break) by setting the third--- entry in the Command tuple above.------ NOTE: in order for us to override the default correctly, any custom entry--- must be a SUBSET of word_break_chars.-word_break_chars :: String-word_break_chars = spaces ++ specials ++ symbols--symbols, specials, spaces :: String-symbols = "!#$%&*+/<=>?@\\^|-~"-specials = "(),;[]`{}"-spaces = " \t\n"--flagWordBreakChars :: String-flagWordBreakChars = " \t\n"---keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)-keepGoing a str = keepGoing' (lift . a) str--keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool-keepGoing' a str = a str >> return False--keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)-keepGoingPaths a str- = do case toArgs str of- Left err -> liftIO $ hPutStrLn stderr err- Right args -> a args- return False--defShortHelpText :: String-defShortHelpText = "use :? for help.\n"--defFullHelpText :: String-defFullHelpText =- " Commands available from the prompt:\n" ++- "\n" ++- " <statement> evaluate/run <statement>\n" ++- " : repeat last command\n" ++- " :{\\n ..lines.. \\n:}\\n multiline command\n" ++- " :add [*]<module> ... add module(s) to the current target set\n" ++- " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++- " (!: more details; *: all top-level names)\n" ++- " :cd <dir> change directory to <dir>\n" ++- " :cmd <expr> run the commands returned by <expr>::IO String\n" ++- " :complete <dom> [<rng>] <s> list completions for partial input string\n" ++- " :ctags[!] [<file>] create tags file <file> for Vi (default: \"tags\")\n" ++- " (!: use regex instead of line number)\n" ++- " :def <cmd> <expr> define command :<cmd> (later defined command has\n" ++- " precedence, ::<cmd> is always a builtin command)\n" ++- " :edit <file> edit file\n" ++- " :edit edit last module\n" ++- " :etags [<file>] create tags file <file> for Emacs (default: \"TAGS\")\n" ++- " :help, :? display this list of commands\n" ++- " :info[!] [<name> ...] display information about the given names\n" ++- " (!: do not filter instances)\n" ++- " :issafe [<mod>] display safe haskell information of module <mod>\n" ++- " :kind[!] <type> show the kind of <type>\n" ++- " (!: also print the normalised type)\n" ++- " :load[!] [*]<module> ... load module(s) and their dependents\n" ++- " (!: defer type errors)\n" ++- " :main [<arguments> ...] run the main function with the given arguments\n" ++- " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++- " :quit exit GHCi\n" ++- " :reload[!] reload the current module set\n" ++- " (!: defer type errors)\n" ++- " :run function [<arguments> ...] run the function with the given arguments\n" ++- " :script <file> run the script <file>\n" ++- " :type <expr> show the type of <expr>\n" ++- " :type +d <expr> show the type of <expr>, defaulting type variables\n" ++- " :type +v <expr> show the type of <expr>, with its specified tyvars\n" ++- " :undef <cmd> undefine user-defined command :<cmd>\n" ++- " :!<command> run the shell command <command>\n" ++- " :vhdl synthesize currently loaded module to vhdl\n" ++- " :vhdl [<module>] synthesize specified modules/files to vhdl\n" ++- " :verilog synthesize currently loaded module to verilog\n" ++- " :verilog [<module>] synthesize specified modules/files to verilog\n" ++- " :systemverilog synthesize currently loaded module to systemverilog\n" ++- " :systemverilog [<module>] synthesize specified modules/files to systemverilog\n" ++- "\n" ++- " -- Commands for debugging:\n" ++- "\n" ++- " :abandon at a breakpoint, abandon current computation\n" ++- " :back [<n>] go back in the history N steps (after :trace)\n" ++- " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++- " :break <name> set a breakpoint on the specified function\n" ++- " :continue resume after a breakpoint\n" ++- " :delete <number> delete the specified breakpoint\n" ++- " :delete * delete all breakpoints\n" ++- " :force <expr> print <expr>, forcing unevaluated parts\n" ++- " :forward [<n>] go forward in the history N step s(after :back)\n" ++- " :history [<n>] after :trace, show the execution history\n" ++- " :list show the source code around current breakpoint\n" ++- " :list <identifier> show the source code for <identifier>\n" ++- " :list [<module>] <line> show the source code around line number <line>\n" ++- " :print [<name> ...] show a value without forcing its computation\n" ++- " :sprint [<name> ...] simplified version of :print\n" ++- " :step single-step after stopping at a breakpoint\n"++- " :step <expr> single-step into <expr>\n"++- " :steplocal single-step within the current top-level binding\n"++- " :stepmodule single-step restricted to the current module\n"++- " :trace trace after stopping at a breakpoint\n"++- " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++-- "\n" ++- " -- Commands for changing settings:\n" ++- "\n" ++- " :set <option> ... set options\n" ++- " :seti <option> ... set options for interactive evaluation only\n" ++- " :set args <arg> ... set the arguments returned by System.getArgs\n" ++- " :set prog <progname> set the value returned by System.getProgName\n" ++- " :set prompt <prompt> set the prompt used in GHCi\n" ++- " :set prompt-cont <prompt> set the continuation prompt used in GHCi\n" ++- " :set prompt-function <expr> set the function to handle the prompt\n" ++- " :set prompt-cont-function <expr>" ++- "set the function to handle the continuation prompt\n" ++- " :set editor <cmd> set the command used for :edit\n" ++- " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++- " :unset <option> ... unset options\n" ++- "\n" ++- " Options for ':set' and ':unset':\n" ++- "\n" ++- " +m allow multiline commands\n" ++- " +r revert top-level expressions after each evaluation\n" ++- " +s print timing/memory stats after each evaluation\n" ++- " +t print type after evaluation\n" ++- " +c collect type/location info after loading modules\n" ++- " -<flags> most GHC command line flags can also be set here\n" ++- " (eg. -v2, -XFlexibleInstances, etc.)\n" ++- " for GHCi-specific flags, see User's Guide,\n"++- " Flag reference, Interactive-mode options\n" ++- "\n" ++- " -- Commands for displaying information:\n" ++- "\n" ++- " :show bindings show the current bindings made at the prompt\n" ++- " :show breaks show the active breakpoints\n" ++- " :show context show the breakpoint context\n" ++- " :show imports show the current imports\n" ++- " :show linker show current linker state\n" ++- " :show modules show the currently loaded modules\n" ++- " :show packages show the currently active package flags\n" ++- " :show paths show the currently active search paths\n" ++- " :show language show the currently active language flags\n" ++- " :show <setting> show value of <setting>, which is one of\n" ++- " [args, prog, editor, stop]\n" ++- " :showi language show language flags for interactive evaluation\n" ++- "\n"--findEditor :: IO String-findEditor = do- getEnv "EDITOR"- `catchIO` \_ -> do-#if defined(mingw32_HOST_OS)- win <- System.Win32.getWindowsDirectory- return (win </> "notepad.exe")-#else- return ""-#endif--default_progname, default_stop :: String-default_progname = "<interactive>"-default_stop = ""--default_prompt, default_prompt_cont :: PromptFunction-default_prompt = generatePromptFunctionFromString "%s> "-default_prompt_cont = generatePromptFunctionFromString "%s| "--default_args :: [String]-default_args = []--interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]- -> Ghc ()-interactiveUI config srcs maybe_exprs = do- -- HACK! If we happen to get into an infinite loop (eg the user- -- types 'let x=x in x' at the prompt), then the thread will block- -- on a blackhole, and become unreachable during GC. The GC will- -- detect that it is unreachable and send it the NonTermination- -- exception. However, since the thread is unreachable, everything- -- it refers to might be finalized, including the standard Handles.- -- This sounds like a bug, but we don't have a good solution right- -- now.- _ <- liftIO $ newStablePtr stdin- _ <- liftIO $ newStablePtr stdout- _ <- liftIO $ newStablePtr stderr-- -- Initialise buffering for the *interpreted* I/O system- (nobuffering, flush) <- initInterpBuffering-- -- The initial set of DynFlags used for interactive evaluation is the same- -- as the global DynFlags, plus -XExtendedDefaultRules and- -- -XNoMonomorphismRestriction.- dflags <- getDynFlags- let dflags' = (`xopt_set` LangExt.ExtendedDefaultRules)- . (`xopt_unset` LangExt.MonomorphismRestriction)- $ dflags- GHC.setInteractiveDynFlags dflags'-- lastErrLocationsRef <- liftIO $ newIORef []- progDynFlags <- GHC.getProgramDynFlags- _ <- GHC.setProgramDynFlags $- progDynFlags { log_action = ghciLogAction lastErrLocationsRef }-- when (isNothing maybe_exprs) $ do- -- Only for GHCi (not runghc and ghc -e):-- -- Turn buffering off for the compiled program's stdout/stderr- turnOffBuffering_ nobuffering- -- Turn buffering off for GHCi's stdout- liftIO $ hFlush stdout- liftIO $ hSetBuffering stdout NoBuffering- -- We don't want the cmd line to buffer any input that might be- -- intended for the program, so unbuffer stdin.- liftIO $ hSetBuffering stdin NoBuffering- liftIO $ hSetBuffering stderr NoBuffering-#if defined(mingw32_HOST_OS)- -- On Unix, stdin will use the locale encoding. The IO library- -- doesn't do this on Windows (yet), so for now we use UTF-8,- -- for consistency with GHC 6.10 and to make the tests work.- liftIO $ hSetEncoding stdin utf8-#endif-- default_editor <- liftIO $ findEditor- eval_wrapper <- mkEvalWrapper default_progname default_args- let prelude_import = simpleImportDecl preludeModuleName- startGHCi (runGHCi srcs maybe_exprs)- GHCiState{ progname = default_progname,- args = default_args,- evalWrapper = eval_wrapper,- prompt = default_prompt,- prompt_cont = default_prompt_cont,- stop = default_stop,- editor = default_editor,- options = [],- -- We initialize line number as 0, not 1, because we use- -- current line number while reporting errors which is- -- incremented after reading a line.- line_number = 0,- break_ctr = 0,- breaks = [],- tickarrays = emptyModuleEnv,- ghci_commands = availableCommands config,- ghci_macros = [],- last_command = Nothing,- cmdqueue = [],- remembered_ctx = [],- transient_ctx = [],- extra_imports = [],- prelude_imports = [prelude_import],- ghc_e = isJust maybe_exprs,- short_help = shortHelpText config,- long_help = fullHelpText config,- lastErrorLocations = lastErrLocationsRef,- mod_infos = M.empty,- flushStdHandles = flush,- noBuffering = nobuffering- }-- return ()--resetLastErrorLocations :: GHCi ()-resetLastErrorLocations = do- st <- getGHCiState- liftIO $ writeIORef (lastErrorLocations st) []--ghciLogAction :: IORef [(FastString, Int)] -> LogAction-ghciLogAction lastErrLocations dflags flag severity srcSpan style msg = do- defaultLogAction dflags flag severity srcSpan style msg- case severity of- SevError -> case srcSpan of- RealSrcSpan rsp -> modifyIORef lastErrLocations- (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])- _ -> return ()- _ -> return ()--withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a-withGhcAppData right left = do- either_dir <- tryIO (getAppUserDataDirectory "clash")- case either_dir of- Right dir ->- do createDirectoryIfMissing False dir `catchIO` \_ -> return ()- right dir- _ -> left--runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()-runGHCi paths maybe_exprs = do- dflags <- getDynFlags- let- ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags-- current_dir = return (Just ".clashi")-- app_user_dir = liftIO $ withGhcAppData- (\dir -> return (Just (dir </> "clashi.conf")))- (return Nothing)-- home_dir = do- either_dir <- liftIO $ tryIO (getEnv "HOME")- case either_dir of- Right home -> return (Just (home </> ".clashi"))- _ -> return Nothing-- canonicalizePath' :: FilePath -> IO (Maybe FilePath)- canonicalizePath' fp = liftM Just (canonicalizePath fp)- `catchIO` \_ -> return Nothing-- sourceConfigFile :: FilePath -> GHCi ()- sourceConfigFile file = do- exists <- liftIO $ doesFileExist file- when exists $ do- either_hdl <- liftIO $ tryIO (openFile file ReadMode)- case either_hdl of- Left _e -> return ()- -- NOTE: this assumes that runInputT won't affect the terminal;- -- can we assume this will always be the case?- -- This would be a good place for runFileInputT.- Right hdl ->- do runInputTWithPrefs defaultPrefs defaultSettings $- runCommands $ fileLoop hdl- liftIO (hClose hdl `catchIO` \_ -> return ())- -- Don't print a message if this is really ghc -e (#11478).- -- Also, let the user silence the message with -v0- -- (the default verbosity in GHCi is 1).- when (isNothing maybe_exprs && verbosity dflags > 0) $- liftIO $ putStrLn ("Loaded Clashi configuration from " ++ file)-- ---- setGHCContextFromGHCiState-- dot_cfgs <- if ignore_dot_ghci then return [] else do- dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]- liftIO $ filterM checkFileAndDirPerms dot_files- mdot_cfgs <- liftIO $ mapM canonicalizePath' dot_cfgs-- let arg_cfgs = reverse $ ghciScripts dflags- -- -ghci-script are collected in reverse order- -- We don't require that a script explicitly added by -ghci-script- -- is owned by the current user. (#6017)- mapM_ sourceConfigFile $ nub $ (catMaybes mdot_cfgs) ++ arg_cfgs- -- nub, because we don't want to read .ghci twice if the CWD is $HOME.-- -- Perform a :load for files given on the GHCi command line- -- When in -e mode, if the load fails then we want to stop- -- immediately rather than going on to evaluate the expression.- when (not (null paths)) $ do- ok <- ghciHandle (\e -> do showException e; return Failed) $- -- TODO: this is a hack.- runInputTWithPrefs defaultPrefs defaultSettings $- loadModule paths- when (isJust maybe_exprs && failed ok) $- liftIO (exitWith (ExitFailure 1))-- installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)-- -- if verbosity is greater than 0, or we are connected to a- -- terminal, display the prompt in the interactive loop.- is_tty <- liftIO (hIsTerminalDevice stdin)- let show_prompt = verbosity dflags > 0 || is_tty-- -- reset line number- modifyGHCiState $ \st -> st{line_number=0}-- case maybe_exprs of- Nothing ->- do- -- enter the interactive loop- runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty- Just exprs -> do- -- just evaluate the expression we were given- enqueueCommands exprs- let hdle e = do st <- getGHCiState- -- flush the interpreter's stdout/stderr on exit (#3890)- flushInterpBuffers- -- Jump through some hoops to get the- -- current progname in the exception text:- -- <progname>: <exception>- liftIO $ withProgName (progname st)- $ topHandler e- -- this used to be topHandlerFastExit, see #2228- runInputTWithPrefs defaultPrefs defaultSettings $ do- -- make `ghc -e` exit nonzero on invalid input, see Trac #7962- _ <- runCommands' hdle- (Just $ hdle (toException $ ExitFailure 1) >> return ())- (return Nothing)- return ()-- -- and finally, exit- liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving Clashi."--runGHCiInput :: InputT GHCi a -> GHCi a-runGHCiInput f = do- dflags <- getDynFlags- let ghciHistory = gopt Opt_GhciHistory dflags- let localGhciHistory = gopt Opt_LocalGhciHistory dflags- currentDirectory <- liftIO $ getCurrentDirectory-- histFile <- case (ghciHistory, localGhciHistory) of- (True, True) -> return (Just (currentDirectory </> ".clashi_history"))- (True, _) -> liftIO $ withGhcAppData- (\dir -> return (Just (dir </> "clashi_history"))) (return Nothing)- _ -> return Nothing-- runInputT- (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})- f---- | How to get the next input line from the user-nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)-nextInputLine show_prompt is_tty- | is_tty = do- prmpt <- if show_prompt then lift mkPrompt else return ""- r <- getInputLine prmpt- incrementLineNo- return r- | otherwise = do- when show_prompt $ lift mkPrompt >>= liftIO . putStr- fileLoop stdin---- NOTE: We only read .ghci files if they are owned by the current user,--- and aren't world writable (files owned by root are ok, see #9324).--- Otherwise, we could be accidentally running code planted by--- a malicious third party.---- Furthermore, We only read ./.ghci if . is owned by the current user--- and isn't writable by anyone else. I think this is sufficient: we--- don't need to check .. and ../.. etc. because "." always refers to--- the same directory while a process is running.--checkFileAndDirPerms :: FilePath -> IO Bool-checkFileAndDirPerms file = do- file_ok <- checkPerms file- -- Do not check dir perms when .ghci doesn't exist, otherwise GHCi will- -- print some confusing and useless warnings in some cases (e.g. in- -- travis). Note that we can't add a test for this, as all ghci tests should- -- run with -ignore-dot-ghci, which means we never get here.- if file_ok then checkPerms (getDirectory file) else return False- where- getDirectory f = case takeDirectory f of- "" -> "."- d -> d--checkPerms :: FilePath -> IO Bool-#if defined(mingw32_HOST_OS)-checkPerms _ = return True-#else-checkPerms file =- handleIO (\_ -> return False) $ do- st <- getFileStatus file- me <- getRealUserID- let mode = System.Posix.fileMode st- ok = (fileOwner st == me || fileOwner st == 0) &&- groupWriteMode /= mode `intersectFileModes` groupWriteMode &&- otherWriteMode /= mode `intersectFileModes` otherWriteMode- unless ok $- -- #8248: Improving warning to include a possible fix.- putStrLn $ "*** WARNING: " ++ file ++- " is writable by someone else, IGNORING!" ++- "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"- return ok-#endif--incrementLineNo :: InputT GHCi ()-incrementLineNo = modifyGHCiState incLineNo- where- incLineNo st = st { line_number = line_number st + 1 }--fileLoop :: Handle -> InputT GHCi (Maybe String)-fileLoop hdl = do- l <- liftIO $ tryIO $ hGetLine hdl- case l of- Left e | isEOFError e -> return Nothing- | -- as we share stdin with the program, the program- -- might have already closed it, so we might get a- -- handle-closed exception. We therefore catch that- -- too.- isIllegalOperation e -> return Nothing- | InvalidArgument <- etype -> return Nothing- | otherwise -> liftIO $ ioError e- where etype = ioeGetErrorType e- -- treat InvalidArgument in the same way as EOF:- -- this can happen if the user closed stdin, or- -- perhaps did getContents which closes stdin at- -- EOF.- Right l' -> do- incrementLineNo- return (Just l')--formatCurrentTime :: String -> IO String-formatCurrentTime format =- getZonedTime >>= return . (formatTime defaultTimeLocale format)--getUserName :: IO String-getUserName = do-#if defined(mingw32_HOST_OS)- getEnv "USERNAME"- `catchIO` \e -> do- putStrLn $ show e- return ""-#else- getLoginName-#endif--getInfoForPrompt :: GHCi (SDoc, [String], Int)-getInfoForPrompt = do- st <- getGHCiState- imports <- GHC.getContext- resumes <- GHC.getResumeContext-- context_bit <-- case resumes of- [] -> return empty- r:_ -> do- let ix = GHC.resumeHistoryIx r- if ix == 0- then return (brackets (ppr (GHC.resumeSpan r)) <> space)- else do- let hist = GHC.resumeHistory r !! (ix-1)- pan <- GHC.getHistorySpan hist- return (brackets (ppr (negate ix) <> char ':'- <+> ppr pan) <> space)-- let- dots | _:rs <- resumes, not (null rs) = text "... "- | otherwise = empty-- rev_imports = reverse imports -- rightmost are the most recent-- myIdeclName d | Just m <- ideclAs d = unLoc m- | otherwise = unLoc (ideclName d)-- modules_names =- ['*':(moduleNameString m) | IIModule m <- rev_imports] ++- [moduleNameString (myIdeclName d) | IIDecl d <- rev_imports]- line = 1 + line_number st-- return (dots <> context_bit, modules_names, line)--parseCallEscape :: String -> (String, String)-parseCallEscape s- | not (all isSpace beforeOpen) = ("", "")- | null sinceOpen = ("", "")- | null sinceClosed = ("", "")- | null cmd = ("", "")- | otherwise = (cmd, tail sinceClosed)- where- (beforeOpen, sinceOpen) = span (/='(') s- (cmd, sinceClosed) = span (/=')') (tail sinceOpen)--checkPromptStringForErrors :: String -> Maybe String-checkPromptStringForErrors ('%':'c':'a':'l':'l':xs) =- case parseCallEscape xs of- ("", "") -> Just ("Incorrect %call syntax. " ++- "Should be %call(a command and arguments).")- (_, afterClosed) -> checkPromptStringForErrors afterClosed-checkPromptStringForErrors ('%':'%':xs) = checkPromptStringForErrors xs-checkPromptStringForErrors (_:xs) = checkPromptStringForErrors xs-checkPromptStringForErrors "" = Nothing--generatePromptFunctionFromString :: String -> PromptFunction-generatePromptFunctionFromString promptS = \_ _ -> do- (context, modules_names, line) <- getInfoForPrompt-- let- processString :: String -> GHCi SDoc- processString ('%':'s':xs) =- liftM2 (<>) (return modules_list) (processString xs)- where- modules_list = context <> modules_bit- modules_bit = hsep $ map text modules_names- processString ('%':'l':xs) =- liftM2 (<>) (return $ ppr line) (processString xs)- processString ('%':'d':xs) =- liftM2 (<>) (liftM text formatted_time) (processString xs)- where- formatted_time = liftIO $ formatCurrentTime "%a %b %d"- processString ('%':'t':xs) =- liftM2 (<>) (liftM text formatted_time) (processString xs)- where- formatted_time = liftIO $ formatCurrentTime "%H:%M:%S"- processString ('%':'T':xs) = do- liftM2 (<>) (liftM text formatted_time) (processString xs)- where- formatted_time = liftIO $ formatCurrentTime "%I:%M:%S"- processString ('%':'@':xs) = do- liftM2 (<>) (liftM text formatted_time) (processString xs)- where- formatted_time = liftIO $ formatCurrentTime "%I:%M %P"- processString ('%':'A':xs) = do- liftM2 (<>) (liftM text formatted_time) (processString xs)- where- formatted_time = liftIO $ formatCurrentTime "%H:%M"- processString ('%':'u':xs) =- liftM2 (<>) (liftM text user_name) (processString xs)- where- user_name = liftIO $ getUserName- processString ('%':'w':xs) =- liftM2 (<>) (liftM text current_directory) (processString xs)- where- current_directory = liftIO $ getCurrentDirectory- processString ('%':'o':xs) =- liftM ((text os) <>) (processString xs)- processString ('%':'a':xs) =- liftM ((text arch) <>) (processString xs)- processString ('%':'N':xs) =- liftM ((text compilerName) <>) (processString xs)- processString ('%':'V':xs) =- liftM ((text $ showVersion compilerVersion) <>) (processString xs)- processString ('%':'c':'a':'l':'l':xs) = do- respond <- liftIO $ do- (code, out, err) <-- readProcessWithExitCode- (head list_words) (tail list_words) ""- `catchIO` \e -> return (ExitFailure 1, "", show e)- case code of- ExitSuccess -> return out- _ -> do- hPutStrLn stderr err- return ""- liftM ((text respond) <>) (processString afterClosed)- where- (cmd, afterClosed) = parseCallEscape xs- list_words = words cmd- processString ('%':'%':xs) =- liftM ((char '%') <>) (processString xs)- processString (x:xs) =- liftM (char x <>) (processString xs)- processString "" =- return empty-- processString promptS--mkPrompt :: GHCi String-mkPrompt = do- st <- getGHCiState- dflags <- getDynFlags- (context, modules_names, line) <- getInfoForPrompt-- prompt_string <- (prompt st) modules_names line- let prompt_doc = context <> prompt_string-- return (showSDoc dflags prompt_doc)--queryQueue :: GHCi (Maybe String)-queryQueue = do- st <- getGHCiState- case cmdqueue st of- [] -> return Nothing- c:cs -> do setGHCiState st{ cmdqueue = cs }- return (Just c)---- Reconfigurable pretty-printing Ticket #5461-installInteractivePrint :: Maybe String -> Bool -> GHCi ()-installInteractivePrint Nothing _ = return ()-installInteractivePrint (Just ipFun) exprmode = do- ok <- trySuccess $ do- (name:_) <- GHC.parseName ipFun- modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name- in he{hsc_IC = new_ic})- return Succeeded-- when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))---- | The main read-eval-print loop-runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()-runCommands gCmd = runCommands' handler Nothing gCmd >> return ()--runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler- -> Maybe (GHCi ()) -- ^ Source error handler- -> InputT GHCi (Maybe String)- -> InputT GHCi (Maybe Bool)- -- We want to return () here, but have to return (Maybe Bool)- -- because gmask is not polymorphic enough: we want to use- -- unmask at two different types.-runCommands' eh sourceErrorHandler gCmd = gmask $ \unmask -> do- b <- ghandle (\e -> case fromException e of- Just UserInterrupt -> return $ Just False- _ -> case fromException e of- Just ghce ->- do liftIO (print (ghce :: GhcException))- return Nothing- _other ->- liftIO (Exception.throwIO e))- (unmask $ runOneCommand eh gCmd)- case b of- Nothing -> return Nothing- Just success -> do- unless success $ maybe (return ()) lift sourceErrorHandler- unmask $ runCommands' eh sourceErrorHandler gCmd---- | Evaluate a single line of user input (either :<command> or Haskell code).--- A result of Nothing means there was no more input to process.--- Otherwise the result is Just b where b is True if the command succeeded;--- this is relevant only to ghc -e, which will exit with status 1--- if the command was unsuccessful. GHCi will continue in either case.-runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)- -> InputT GHCi (Maybe Bool)-runOneCommand eh gCmd = do- -- run a previously queued command if there is one, otherwise get new- -- input from user- mb_cmd0 <- noSpace (lift queryQueue)- mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0- case mb_cmd1 of- Nothing -> return Nothing- Just c -> ghciHandle (\e -> lift $ eh e >>= return . Just) $- handleSourceError printErrorAndFail- (doCommand c)- -- source error's are handled by runStmt- -- is the handler necessary here?- where- printErrorAndFail err = do- GHC.printException err- return $ Just False -- Exit ghc -e, but not GHCi-- noSpace q = q >>= maybe (return Nothing)- (\c -> case removeSpaces c of- "" -> noSpace q- ":{" -> multiLineCmd q- _ -> return (Just c) )- multiLineCmd q = do- st <- getGHCiState- let p = prompt st- setGHCiState st{ prompt = prompt_cont st }- mb_cmd <- collectCommand q "" `GHC.gfinally`- modifyGHCiState (\st' -> st' { prompt = p })- return mb_cmd- -- we can't use removeSpaces for the sublines here, so- -- multiline commands are somewhat more brittle against- -- fileformat errors (such as \r in dos input on unix),- -- we get rid of any extra spaces for the ":}" test;- -- we also avoid silent failure if ":}" is not found;- -- and since there is no (?) valid occurrence of \r (as- -- opposed to its String representation, "\r") inside a- -- ghci command, we replace any such with ' ' (argh:-(- collectCommand q c = q >>=- maybe (liftIO (ioError collectError))- (\l->if removeSpaces l == ":}"- then return (Just c)- else collectCommand q (c ++ "\n" ++ map normSpace l))- where normSpace '\r' = ' '- normSpace x = x- -- SDM (2007-11-07): is userError the one to use here?- collectError = userError "unterminated multiline command :{ .. :}"-- -- | Handle a line of input- doCommand :: String -> InputT GHCi (Maybe Bool)-- -- command- doCommand stmt | (':' : cmd) <- removeSpaces stmt = do- result <- specialCommand cmd- case result of- True -> return Nothing- _ -> return $ Just True-- -- haskell- doCommand stmt = do- -- if 'stmt' was entered via ':{' it will contain '\n's- let stmt_nl_cnt = length [ () | '\n' <- stmt ]- ml <- lift $ isOptionSet Multiline- if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input- then do- fst_line_num <- line_number <$> getGHCiState- mb_stmt <- checkInputForLayout stmt gCmd- case mb_stmt of- Nothing -> return $ Just True- Just ml_stmt -> do- -- temporarily compensate line-number for multi-line input- result <- timeIt runAllocs $ lift $- runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion- return $ Just (runSuccess result)- else do -- single line input and :{ - multiline input- last_line_num <- line_number <$> getGHCiState- -- reconstruct first line num from last line num and stmt- let fst_line_num | stmt_nl_cnt > 0 = last_line_num - (stmt_nl_cnt2 + 1)- | otherwise = last_line_num -- single line input- stmt_nl_cnt2 = length [ () | '\n' <- stmt' ]- stmt' = dropLeadingWhiteLines stmt -- runStmt doesn't like leading empty lines- -- temporarily compensate line-number for multi-line input- result <- timeIt runAllocs $ lift $- runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion- return $ Just (runSuccess result)-- -- runStmt wrapper for temporarily overridden line-number- runStmtWithLineNum :: Int -> String -> SingleStep- -> GHCi (Maybe GHC.ExecResult)- runStmtWithLineNum lnum stmt step = do- st0 <- getGHCiState- setGHCiState st0 { line_number = lnum }- result <- runStmt stmt step- -- restore original line_number- getGHCiState >>= \st -> setGHCiState st { line_number = line_number st0 }- return result-- -- note: this is subtly different from 'unlines . dropWhile (all isSpace) . lines'- dropLeadingWhiteLines s | (l0,'\n':r) <- break (=='\n') s- , all isSpace l0 = dropLeadingWhiteLines r- | otherwise = s----- #4316--- lex the input. If there is an unclosed layout context, request input-checkInputForLayout :: String -> InputT GHCi (Maybe String)- -> InputT GHCi (Maybe String)-checkInputForLayout stmt getStmt = do- dflags' <- getDynFlags- let dflags = xopt_set dflags' LangExt.AlternativeLayoutRule- st0 <- getGHCiState- let buf' = stringToStringBuffer stmt- loc = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1- pstate = Lexer.mkPState dflags buf' loc- case Lexer.unP goToEnd pstate of- (Lexer.POk _ False) -> return $ Just stmt- _other -> do- st1 <- getGHCiState- let p = prompt st1- setGHCiState st1{ prompt = prompt_cont st1 }- mb_stmt <- ghciHandle (\ex -> case fromException ex of- Just UserInterrupt -> return Nothing- _ -> case fromException ex of- Just ghce ->- do liftIO (print (ghce :: GhcException))- return Nothing- _other -> liftIO (Exception.throwIO ex))- getStmt- modifyGHCiState (\st' -> st' { prompt = p })- -- the recursive call does not recycle parser state- -- as we use a new string buffer- case mb_stmt of- Nothing -> return Nothing- Just str -> if str == ""- then return $ Just stmt- else do- checkInputForLayout (stmt++"\n"++str) getStmt- where goToEnd = do- eof <- Lexer.nextIsEOF- if eof- then Lexer.activeContext- else Lexer.lexer False return >> goToEnd--enqueueCommands :: [String] -> GHCi ()-enqueueCommands cmds = do- -- make sure we force any exceptions in the commands while we're- -- still inside the exception handler, otherwise bad things will- -- happen (see #10501)- cmds `deepseq` return ()- modifyGHCiState $ \st -> st{ cmdqueue = cmds ++ cmdqueue st }---- | Entry point to execute some haskell code from user.--- The return value True indicates success, as in `runOneCommand`.-runStmt :: String -> SingleStep -> GHCi (Maybe GHC.ExecResult)-runStmt stmt step = do- dflags <- GHC.getInteractiveDynFlags- if | GHC.isStmt dflags stmt -> run_stmt- | GHC.isImport dflags stmt -> run_import- -- Every import declaration should be handled by `run_import`. As GHCi- -- in general only accepts one command at a time, we simply throw an- -- exception when the input contains multiple commands of which at least- -- one is an import command (see #10663).- | GHC.hasImport dflags stmt -> throwGhcException- (CmdLineError "error: expecting a single import declaration")- -- Note: `GHC.isDecl` returns False on input like- -- `data Infix a b = a :@: b; infixl 4 :@:`- -- and should therefore not be used here.- | otherwise -> run_decl-- where- run_import = do- addImportToContext stmt- return (Just (GHC.ExecComplete (Right []) 0))-- run_decl =- do _ <- liftIO $ tryIO $ hFlushAll stdin- m_result <- GhciMonad.runDecls stmt- case m_result of- Nothing -> return Nothing- Just result ->- Just <$> afterRunStmt (const True)- (GHC.ExecComplete (Right result) 0)-- run_stmt =- do -- In the new IO library, read handles buffer data even if the Handle- -- is set to NoBuffering. This causes problems for GHCi where there- -- are really two stdin Handles. So we flush any bufferred data in- -- GHCi's stdin Handle here (only relevant if stdin is attached to- -- a file, otherwise the read buffer can't be flushed).- _ <- liftIO $ tryIO $ hFlushAll stdin- m_result <- GhciMonad.runStmt stmt step- case m_result of- Nothing -> return Nothing- Just result -> Just <$> afterRunStmt (const True) result---- | Clean up the GHCi environment after a statement has run-afterRunStmt :: (SrcSpan -> Bool) -> GHC.ExecResult -> GHCi GHC.ExecResult-afterRunStmt step_here run_result = do- resumes <- GHC.getResumeContext- case run_result of- GHC.ExecComplete{..} ->- case execResult of- Left ex -> liftIO $ Exception.throwIO ex- Right names -> do- show_types <- isOptionSet ShowType- when show_types $ printTypeOfNames names- GHC.ExecBreak names mb_info- | isNothing mb_info ||- step_here (GHC.resumeSpan $ head resumes) -> do- mb_id_loc <- toBreakIdAndLocation mb_info- let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc- if (null bCmd)- then printStoppedAtBreakInfo (head resumes) names- else enqueueCommands [bCmd]- -- run the command set with ":set stop <cmd>"- st <- getGHCiState- enqueueCommands [stop st]- return ()- | otherwise -> resume step_here GHC.SingleStep >>=- afterRunStmt step_here >> return ()-- flushInterpBuffers- withSignalHandlers $ do- b <- isOptionSet RevertCAFs- when b revertCAFs-- return run_result--runSuccess :: Maybe GHC.ExecResult -> Bool-runSuccess run_result- | Just (GHC.ExecComplete { execResult = Right _ }) <- run_result = True- | otherwise = False--runAllocs :: Maybe GHC.ExecResult -> Maybe Integer-runAllocs m = do- res <- m- case res of- GHC.ExecComplete{..} -> Just (fromIntegral execAllocation)- _ -> Nothing--toBreakIdAndLocation ::- Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))-toBreakIdAndLocation Nothing = return Nothing-toBreakIdAndLocation (Just inf) = do- let md = GHC.breakInfo_module inf- nm = GHC.breakInfo_number inf- st <- getGHCiState- return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,- breakModule loc == md,- breakTick loc == nm ]--printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()-printStoppedAtBreakInfo res names = do- printForUser $ pprStopped res- -- printTypeOfNames session names- let namesSorted = sortBy compareNames names- tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted- docs <- mapM pprTypeAndContents [i | AnId i <- tythings]- printForUserPartWay $ vcat docs--printTypeOfNames :: [Name] -> GHCi ()-printTypeOfNames names- = mapM_ (printTypeOfName ) $ sortBy compareNames names--compareNames :: Name -> Name -> Ordering-n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2- where compareWith n = (getOccString n, getSrcSpan n)--printTypeOfName :: Name -> GHCi ()-printTypeOfName n- = do maybe_tything <- GHC.lookupName n- case maybe_tything of- Nothing -> return ()- Just thing -> printTyThing thing---data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand---- | Entry point for execution a ':<command>' input from user-specialCommand :: String -> InputT GHCi Bool-specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)-specialCommand str = do- let (cmd,rest) = break isSpace str- maybe_cmd <- lift $ lookupCommand cmd- htxt <- short_help <$> getGHCiState- case maybe_cmd of- GotCommand cmd -> (cmdAction cmd) (dropWhile isSpace rest)- BadCommand ->- do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"- ++ htxt)- return False- NoLastCommand ->- do liftIO $ hPutStr stdout ("there is no last command to perform\n"- ++ htxt)- return False--shellEscape :: String -> GHCi Bool-shellEscape str = liftIO (system str >> return False)--lookupCommand :: String -> GHCi (MaybeCommand)-lookupCommand "" = do- st <- getGHCiState- case last_command st of- Just c -> return $ GotCommand c- Nothing -> return NoLastCommand-lookupCommand str = do- mc <- lookupCommand' str- modifyGHCiState (\st -> st { last_command = mc })- return $ case mc of- Just c -> GotCommand c- Nothing -> BadCommand--lookupCommand' :: String -> GHCi (Maybe Command)-lookupCommand' ":" = return Nothing-lookupCommand' str' = do- macros <- ghci_macros <$> getGHCiState- ghci_cmds <- ghci_commands <$> getGHCiState-- let ghci_cmds_nohide = filter (not . cmdHidden) ghci_cmds-- let (str, xcmds) = case str' of- ':' : rest -> (rest, []) -- "::" selects a builtin command- _ -> (str', macros) -- otherwise include macros in lookup-- lookupExact s = find $ (s ==) . cmdName- lookupPrefix s = find $ (s `isPrefixOf`) . cmdName-- -- hidden commands can only be matched exact- builtinPfxMatch = lookupPrefix str ghci_cmds_nohide-- -- first, look for exact match (while preferring macros); then, look- -- for first prefix match (preferring builtins), *unless* a macro- -- overrides the builtin; see #8305 for motivation- return $ lookupExact str xcmds <|>- lookupExact str ghci_cmds <|>- (builtinPfxMatch >>= \c -> lookupExact (cmdName c) xcmds) <|>- builtinPfxMatch <|>- lookupPrefix str xcmds--getCurrentBreakSpan :: GHCi (Maybe SrcSpan)-getCurrentBreakSpan = do- resumes <- GHC.getResumeContext- case resumes of- [] -> return Nothing- (r:_) -> do- let ix = GHC.resumeHistoryIx r- if ix == 0- then return (Just (GHC.resumeSpan r))- else do- let hist = GHC.resumeHistory r !! (ix-1)- pan <- GHC.getHistorySpan hist- return (Just pan)--getCallStackAtCurrentBreakpoint :: GHCi (Maybe [String])-getCallStackAtCurrentBreakpoint = do- resumes <- GHC.getResumeContext- case resumes of- [] -> return Nothing- (r:_) -> do- hsc_env <- GHC.getSession- Just <$> liftIO (costCentreStackInfo hsc_env (GHC.resumeCCS r))--getCurrentBreakModule :: GHCi (Maybe Module)-getCurrentBreakModule = do- resumes <- GHC.getResumeContext- case resumes of- [] -> return Nothing- (r:_) -> do- let ix = GHC.resumeHistoryIx r- if ix == 0- then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)- else do- let hist = GHC.resumeHistory r !! (ix-1)- return $ Just $ GHC.getHistoryModule hist------------------------------------------------------------------------------------- Commands-----------------------------------------------------------------------------------noArgs :: GHCi () -> String -> GHCi ()-noArgs m "" = m-noArgs _ _ = liftIO $ putStrLn "This command takes no arguments"--withSandboxOnly :: String -> GHCi () -> GHCi ()-withSandboxOnly cmd this = do- dflags <- getDynFlags- if not (gopt Opt_GhciSandbox dflags)- then printForUser (text cmd <+>- ptext (sLit "is not supported with -fno-ghci-sandbox"))- else this---------------------------------------------------------------------------------- :help--help :: String -> GHCi ()-help _ = do- txt <- long_help `fmap` getGHCiState- liftIO $ putStr txt---------------------------------------------------------------------------------- :info--info :: Bool -> String -> InputT GHCi ()-info _ "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'")-info allInfo s = handleSourceError GHC.printException $ do- unqual <- GHC.getPrintUnqual- dflags <- getDynFlags- sdocs <- mapM (infoThing allInfo) (words s)- mapM_ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs--infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc-infoThing allInfo str = do- names <- GHC.parseName str- mb_stuffs <- mapM (GHC.getInfo allInfo) names- let filtered = filterOutChildren (\(t,_f,_ci,_fi) -> t) (catMaybes mb_stuffs)- return $ vcat (intersperse (text "") $ map pprInfo filtered)-- -- Filter out names whose parent is also there Good- -- example is '[]', which is both a type and data- -- constructor in the same type-filterOutChildren :: (a -> TyThing) -> [a] -> [a]-filterOutChildren get_thing xs- = filterOut has_parent xs- where- all_names = mkNameSet (map (getName . get_thing) xs)- has_parent x = case tyThingParent_maybe (get_thing x) of- Just p -> getName p `elemNameSet` all_names- Nothing -> False--pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc-pprInfo (thing, fixity, cls_insts, fam_insts)- = pprTyThingInContextLoc thing- $$ show_fixity- $$ vcat (map GHC.pprInstance cls_insts)- $$ vcat (map GHC.pprFamInst fam_insts)- where- show_fixity- | fixity == GHC.defaultFixity = empty- | otherwise = ppr fixity <+> pprInfixName (GHC.getName thing)---------------------------------------------------------------------------------- :main--runMain :: String -> GHCi ()-runMain s = case toArgs s of- Left err -> liftIO (hPutStrLn stderr err)- Right args ->- do dflags <- getDynFlags- let main = fromMaybe "main" (mainFunIs dflags)- -- Wrap the main function in 'void' to discard its value instead- -- of printing it (#9086). See Haskell 2010 report Chapter 5.- doWithArgs args $ "Control.Monad.void (" ++ main ++ ")"---------------------------------------------------------------------------------- :run--runRun :: String -> GHCi ()-runRun s = case toCmdArgs s of- Left err -> liftIO (hPutStrLn stderr err)- Right (cmd, args) -> doWithArgs args cmd--doWithArgs :: [String] -> String -> GHCi ()-doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++- show args ++ " (" ++ cmd ++ ")"]---------------------------------------------------------------------------------- :cd--changeDirectory :: String -> InputT GHCi ()-changeDirectory "" = do- -- :cd on its own changes to the user's home directory- either_dir <- liftIO $ tryIO getHomeDirectory- case either_dir of- Left _e -> return ()- Right dir -> changeDirectory dir-changeDirectory dir = do- graph <- GHC.getModuleGraph- when (not (null graph)) $- liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."- GHC.setTargets []- _ <- GHC.load LoadAllTargets- lift $ setContextAfterLoad False []- GHC.workingDirectoryChanged- dir' <- expandPath dir- liftIO $ setCurrentDirectory dir'- dflags <- getDynFlags- -- With -fexternal-interpreter, we have to change the directory of the subprocess too.- -- (this gives consistent behaviour with and without -fexternal-interpreter)- when (gopt Opt_ExternalInterpreter dflags) $- lift $ enqueueCommands ["System.Directory.setCurrentDirectory " ++ show dir']--trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag-trySuccess act =- handleSourceError (\e -> do GHC.printException e- return Failed) $ do- act---------------------------------------------------------------------------------- :edit--editFile :: String -> InputT GHCi ()-editFile str =- do file <- if null str then lift chooseEditFile else expandPath str- st <- getGHCiState- errs <- liftIO $ readIORef $ lastErrorLocations st- let cmd = editor st- when (null cmd)- $ throwGhcException (CmdLineError "editor not set, use :set editor")- lineOpt <- liftIO $ do- let sameFile p1 p2 = liftA2 (==) (canonicalizePath p1) (canonicalizePath p2)- `catchIO` (\_ -> return False)-- curFileErrs <- filterM (\(f, _) -> unpackFS f `sameFile` file) errs- return $ case curFileErrs of- (_, line):_ -> " +" ++ show line- _ -> ""- let cmdArgs = ' ':(file ++ lineOpt)- code <- liftIO $ system (cmd ++ cmdArgs)-- when (code == ExitSuccess)- $ reloadModule ""---- The user didn't specify a file so we pick one for them.--- Our strategy is to pick the first module that failed to load,--- or otherwise the first target.------ XXX: Can we figure out what happened if the depndecy analysis fails--- (e.g., because the porgrammeer mistyped the name of a module)?--- XXX: Can we figure out the location of an error to pass to the editor?--- XXX: if we could figure out the list of errors that occured during the--- last load/reaload, then we could start the editor focused on the first--- of those.-chooseEditFile :: GHCi String-chooseEditFile =- do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x-- graph <- GHC.getModuleGraph- failed_graph <- filterM hasFailed graph- let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing- pick xs = case xs of- x : _ -> GHC.ml_hs_file (GHC.ms_location x)- _ -> Nothing-- case pick (order failed_graph) of- Just file -> return file- Nothing ->- do targets <- GHC.getTargets- case msum (map fromTarget targets) of- Just file -> return file- Nothing -> throwGhcException (CmdLineError "No files to edit.")-- where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f- fromTarget _ = Nothing -- when would we get a module target?----------------------------------------------------------------------------------- :def--defineMacro :: Bool{-overwrite-} -> String -> GHCi ()-defineMacro _ (':':_) =- liftIO $ putStrLn "macro name cannot start with a colon"-defineMacro overwrite s = do- let (macro_name, definition) = break isSpace s- macros <- ghci_macros <$> getGHCiState- let defined = map cmdName macros- if null macro_name- then if null defined- then liftIO $ putStrLn "no macros defined"- else liftIO $ putStr ("the following macros are defined:\n" ++- unlines defined)- else do- if (not overwrite && macro_name `elem` defined)- then throwGhcException (CmdLineError- ("macro '" ++ macro_name ++ "' is already defined"))- else do-- -- compile the expression- handleSourceError GHC.printException $ do- step <- getGhciStepIO- expr <- GHC.parseExpr definition- -- > ghciStepIO . definition :: String -> IO String- let stringTy = nlHsTyVar stringTy_RDR- ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy- body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)- `mkHsApp` (nlHsPar expr)- tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM)- new_expr = L (getLoc expr) $ ExprWithTySig body tySig- hv <- GHC.compileParsedExprRemote new_expr-- let newCmd = Command { cmdName = macro_name- , cmdAction = lift . runMacro hv- , cmdHidden = False- , cmdCompletionFunc = noCompletion- }-- -- later defined macros have precedence- modifyGHCiState $ \s ->- let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]- in s { ghci_macros = newCmd : filtered }--runMacro :: GHC.ForeignHValue{-String -> IO String-} -> String -> GHCi Bool-runMacro fun s = do- hsc_env <- GHC.getSession- str <- liftIO $ evalStringToIOString hsc_env fun s- enqueueCommands (lines str)- return False----------------------------------------------------------------------------------- :undef--undefineMacro :: String -> GHCi ()-undefineMacro str = mapM_ undef (words str)- where undef macro_name = do- cmds <- ghci_macros <$> getGHCiState- if (macro_name `notElem` map cmdName cmds)- then throwGhcException (CmdLineError- ("macro '" ++ macro_name ++ "' is not defined"))- else do- -- This is a tad racy but really, it's a shell- modifyGHCiState $ \s ->- s { ghci_macros = filter ((/= macro_name) . cmdName)- (ghci_macros s) }----------------------------------------------------------------------------------- :cmd--cmdCmd :: String -> GHCi ()-cmdCmd str = handleSourceError GHC.printException $ do- step <- getGhciStepIO- expr <- GHC.parseExpr str- -- > ghciStepIO str :: IO String- let new_expr = step `mkHsApp` expr- hv <- GHC.compileParsedExprRemote new_expr-- hsc_env <- GHC.getSession- cmds <- liftIO $ evalString hsc_env hv- enqueueCommands (lines cmds)---- | Generate a typed ghciStepIO expression--- @ghciStepIO :: Ty String -> IO String@.-getGhciStepIO :: GHCi (LHsExpr RdrName)-getGhciStepIO = do- ghciTyConName <- GHC.getGHCiMonad- let stringTy = nlHsTyVar stringTy_RDR- ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy- ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy- body = nlHsVar (getRdrName ghciStepIoMName)- tySig = mkLHsSigWcType (ghciM `nlHsFunTy` ioM)- return $ noLoc $ ExprWithTySig body tySig---------------------------------------------------------------------------------- :check--checkModule :: String -> InputT GHCi ()-checkModule m = do- let modl = GHC.mkModuleName m- ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do- r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl- dflags <- getDynFlags- liftIO $ putStrLn $ showSDoc dflags $- case GHC.moduleInfo r of- cm | Just scope <- GHC.modInfoTopLevelScope cm ->- let- (loc, glob) = ASSERT( all isExternalName scope )- partition ((== modl) . GHC.moduleName . GHC.nameModule) scope- in- (text "global names: " <+> ppr glob) $$- (text "local names: " <+> ppr loc)- _ -> empty- return True- afterLoad (successIf ok) False----------------------------------------------------------------------------------- :load, :add, :reload---- | Sets '-fdefer-type-errors' if 'defer' is true, executes 'load' and unsets--- '-fdefer-type-errors' again if it has not been set before.-wrapDeferTypeErrors :: InputT GHCi a -> InputT GHCi a-wrapDeferTypeErrors load =- gbracket- (do- -- Force originalFlags to avoid leaking the associated HscEnv- !originalFlags <- getDynFlags- void $ GHC.setProgramDynFlags $- setGeneralFlag' Opt_DeferTypeErrors originalFlags- return originalFlags)- (\originalFlags -> void $ GHC.setProgramDynFlags originalFlags)- (\_ -> load)--loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag-loadModule fs = timeIt (const Nothing) (loadModule' fs)---- | @:load@ command-loadModule_ :: [FilePath] -> InputT GHCi ()-loadModule_ fs = void $ loadModule (zip fs (repeat Nothing))--loadModuleDefer :: [FilePath] -> InputT GHCi ()-loadModuleDefer = wrapDeferTypeErrors . loadModule_--loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag-loadModule' files = do- let (filenames, phases) = unzip files- exp_filenames <- mapM expandPath filenames- let files' = zip exp_filenames phases- targets <- mapM (uncurry GHC.guessTarget) files'-- -- NOTE: we used to do the dependency anal first, so that if it- -- fails we didn't throw away the current set of modules. This would- -- require some re-working of the GHC interface, so we'll leave it- -- as a ToDo for now.-- -- unload first- _ <- GHC.abandonAll- lift discardActiveBreakPoints- GHC.setTargets []- _ <- GHC.load LoadAllTargets-- GHC.setTargets targets- doLoadAndCollectInfo False LoadAllTargets---- | @:add@ command-addModule :: [FilePath] -> InputT GHCi ()-addModule files = do- lift revertCAFs -- always revert CAFs on load/add.- files' <- mapM expandPath files- targets <- mapM (\m -> GHC.guessTarget m Nothing) files'- -- remove old targets with the same id; e.g. for :add *M- mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]- mapM_ GHC.addTarget targets- _ <- doLoadAndCollectInfo False LoadAllTargets- return ()---- | @:reload@ command-reloadModule :: String -> InputT GHCi ()-reloadModule m = void $ doLoadAndCollectInfo True loadTargets- where- loadTargets | null m = LoadAllTargets- | otherwise = LoadUpTo (GHC.mkModuleName m)--reloadModuleDefer :: String -> InputT GHCi ()-reloadModuleDefer = wrapDeferTypeErrors . reloadModule---- | Load/compile targets and (optionally) collect module-info------ This collects the necessary SrcSpan annotated type information (via--- 'collectInfo') required by the @:all-types@, @:loc-at@, @:type-at@,--- and @:uses@ commands.------ Meta-info collection is not enabled by default and needs to be--- enabled explicitly via @:set +c@. The reason is that collecting--- the type-information for all sub-spans can be quite expensive, and--- since those commands are designed to be used by editors and--- tooling, it's useless to collect this data for normal GHCi--- sessions.-doLoadAndCollectInfo :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag-doLoadAndCollectInfo retain_context howmuch = do- doCollectInfo <- lift (isOptionSet CollectInfo)-- doLoad retain_context howmuch >>= \case- Succeeded | doCollectInfo -> do- loaded <- getModuleGraph >>= filterM GHC.isLoaded . map GHC.ms_mod_name- v <- mod_infos <$> getGHCiState- !newInfos <- collectInfo v loaded- modifyGHCiState (\st -> st { mod_infos = newInfos })- return Succeeded- flag -> return flag--doLoad :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag-doLoad retain_context howmuch = do- -- turn off breakpoints before we load: we can't turn them off later, because- -- the ModBreaks will have gone away.- lift discardActiveBreakPoints-- lift resetLastErrorLocations- -- Enable buffering stdout and stderr as we're compiling. Keeping these- -- handles unbuffered will just slow the compilation down, especially when- -- compiling in parallel.- gbracket (liftIO $ do hSetBuffering stdout LineBuffering- hSetBuffering stderr LineBuffering)- (\_ ->- liftIO $ do hSetBuffering stdout NoBuffering- hSetBuffering stderr NoBuffering) $ \_ -> do- ok <- trySuccess $ GHC.load howmuch- afterLoad ok retain_context- return ok---afterLoad :: SuccessFlag- -> Bool -- keep the remembered_ctx, as far as possible (:reload)- -> InputT GHCi ()-afterLoad ok retain_context = do- lift revertCAFs -- always revert CAFs on load.- lift discardTickArrays- loaded_mods <- getLoadedModules- modulesLoadedMsg ok loaded_mods- lift $ setContextAfterLoad retain_context loaded_mods--setContextAfterLoad :: Bool -> [GHC.ModSummary] -> GHCi ()-setContextAfterLoad keep_ctxt [] = do- setContextKeepingPackageModules keep_ctxt []-setContextAfterLoad keep_ctxt ms = do- -- load a target if one is available, otherwise load the topmost module.- targets <- GHC.getTargets- case [ m | Just m <- map (findTarget ms) targets ] of- [] ->- let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in- load_this (last graph')- (m:_) ->- load_this m- where- findTarget mds t- = case filter (`matches` t) mds of- [] -> Nothing- (m:_) -> Just m-- summary `matches` Target (TargetModule m) _ _- = GHC.ms_mod_name summary == m- summary `matches` Target (TargetFile f _) _ _- | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'- _ `matches` _- = False-- load_this summary | m <- GHC.ms_mod summary = do- is_interp <- GHC.moduleIsInterpreted m- dflags <- getDynFlags- let star_ok = is_interp && not (safeLanguageOn dflags)- -- We import the module with a * iff- -- - it is interpreted, and- -- - -XSafe is off (it doesn't allow *-imports)- let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)]- | otherwise = [mkIIDecl (GHC.moduleName m)]- setContextKeepingPackageModules keep_ctxt new_ctx----- | Keep any package modules (except Prelude) when changing the context.-setContextKeepingPackageModules- :: Bool -- True <=> keep all of remembered_ctx- -- False <=> just keep package imports- -> [InteractiveImport] -- new context- -> GHCi ()--setContextKeepingPackageModules keep_ctx trans_ctx = do-- st <- getGHCiState- let rem_ctx = remembered_ctx st- new_rem_ctx <- if keep_ctx then return rem_ctx- else keepPackageImports rem_ctx- setGHCiState st{ remembered_ctx = new_rem_ctx,- transient_ctx = filterSubsumed new_rem_ctx trans_ctx }- setGHCContextFromGHCiState---- | Filters a list of 'InteractiveImport', clearing out any home package--- imports so only imports from external packages are preserved. ('IIModule'--- counts as a home package import, because we are only able to bring a--- full top-level into scope when the source is available.)-keepPackageImports :: [InteractiveImport] -> GHCi [InteractiveImport]-keepPackageImports = filterM is_pkg_import- where- is_pkg_import :: InteractiveImport -> GHCi Bool- is_pkg_import (IIModule _) = return False- is_pkg_import (IIDecl d)- = do e <- gtry $ GHC.findModule mod_name (fmap sl_fs $ ideclPkgQual d)- case e :: Either SomeException Module of- Left _ -> return False- Right m -> return (not (isHomeModule m))- where- mod_name = unLoc (ideclName d)---modulesLoadedMsg :: SuccessFlag -> [GHC.ModSummary] -> InputT GHCi ()-modulesLoadedMsg ok mods = do- dflags <- getDynFlags- unqual <- GHC.getPrintUnqual- let mod_name mod = do- is_interpreted <- GHC.moduleIsBootOrNotObjectLinkable mod- return $ if is_interpreted- then ppr (GHC.ms_mod mod)- else ppr (GHC.ms_mod mod)- <> text " ("- <> text (normalise $ msObjFilePath mod)- <> text ")" -- fix #9887- mod_names <- mapM mod_name mods- let mod_commas- | null mods = text "none."- | otherwise = hsep (punctuate comma mod_names) <> text "."- status = case ok of- Failed -> text "Failed"- Succeeded -> text "Ok"-- msg = status <> text ", modules loaded:" <+> mod_commas-- when (verbosity dflags > 0) $- liftIO $ putStrLn $ showSDocForUser dflags unqual msg----- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors--- and printing 'throwE' strings to 'stderr'-runExceptGhcMonad :: GHC.GhcMonad m => ExceptT SDoc m () -> m ()-runExceptGhcMonad act = handleSourceError GHC.printException $- either handleErr pure =<<- runExceptT act- where- handleErr sdoc = do- dflags <- getDynFlags- liftIO . hPutStrLn stderr . showSDocForUser dflags alwaysQualify $ sdoc---- | Inverse of 'runExceptT' for \"pure\" computations--- (c.f. 'except' for 'Except')-exceptT :: Applicative m => Either e a -> ExceptT e m a-exceptT = ExceptT . pure--makeHDL' :: Clash.Backend.Backend backend- => (Int -> HdlSyn -> backend)- -> IORef ClashOpts- -> [FilePath]- -> InputT GHCi ()-makeHDL' backend opts lst = makeHDL backend opts =<< case lst of- srcs@(_:_) -> return srcs- [] -> do- modGraph <- GHC.getModuleGraph- let sortedGraph = GHC.topSortModuleGraph False modGraph Nothing- return $ case (reverse sortedGraph) of- ((AcyclicSCC top) : _) -> maybeToList $ (GHC.ml_hs_file . GHC.ms_location) top- _ -> []--makeHDL :: GHC.GhcMonad m- => Clash.Backend.Backend backend- => (Int -> HdlSyn -> backend)- -> IORef ClashOpts- -> [FilePath]- -> m ()-makeHDL backend optsRef srcs = do- dflags <- GHC.getSessionDynFlags- liftIO $ do startTime <- Clock.getCurrentTime- opts <- readIORef optsRef- let iw = opt_intWidth opts- fp = opt_floatSupport opts- syn = opt_hdlSyn opts- -- determine whether `-outputdir` was used- outputDir = do odir <- objectDir dflags- hidir <- hiDir dflags- sdir <- stubDir dflags- ddir <- dumpDir dflags- if all (== odir) [hidir,sdir,ddir]- then Just odir- else Nothing- idirs = importPaths dflags- opts' = opts {opt_hdlDir = maybe outputDir Just (opt_hdlDir opts)- ,opt_importPaths = idirs}- backend' = backend iw syn- primDirs <- Clash.Backend.primDirs backend'- forM_ srcs $ \src -> do- (bindingsMap,tcm,tupTcm,topEntities,primMap) <-- generateBindings primDirs idirs (Clash.Backend.hdlKind backend') src (Just dflags)- prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime- let prepStartDiff = Clock.diffUTCTime prepTime startTime- putStrLn $ "Loading dependencies took " ++ show prepStartDiff- Clash.Driver.generateHDL bindingsMap (Just backend') primMap tcm- tupTcm (ghcTypeToHWType iw fp) reduceConstant topEntities opts' (startTime,prepTime)--makeVHDL :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> VHDLState)--makeVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> VerilogState)--makeSystemVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> SystemVerilogState)---------------------------------------------------------------------------------- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.--typeOfExpr :: String -> InputT GHCi ()-typeOfExpr str = handleSourceError GHC.printException $ do- let (mode, expr_str) = case break isSpace str of- ("+d", rest) -> (GHC.TM_Default, dropWhile isSpace rest)- ("+v", rest) -> (GHC.TM_NoInst, dropWhile isSpace rest)- _ -> (GHC.TM_Inst, str)- ty <- GHC.exprType mode expr_str- printForUser $ sep [text expr_str, nest 2 (dcolon <+> pprTypeForUser ty)]---------------------------------------------------------------------------------- | @:type-at@ command--typeAtCmd :: String -> InputT GHCi ()-typeAtCmd str = runExceptGhcMonad $ do- (span',sample) <- exceptT $ parseSpanArg str- infos <- mod_infos <$> getGHCiState- (info, ty) <- findType infos span' sample- lift $ printForUserModInfo (modinfoInfo info)- (sep [text sample,nest 2 (dcolon <+> ppr ty)])---------------------------------------------------------------------------------- | @:uses@ command--usesCmd :: String -> InputT GHCi ()-usesCmd str = runExceptGhcMonad $ do- (span',sample) <- exceptT $ parseSpanArg str- infos <- mod_infos <$> getGHCiState- uses <- findNameUses infos span' sample- forM_ uses (liftIO . putStrLn . showSrcSpan)---------------------------------------------------------------------------------- | @:loc-at@ command--locAtCmd :: String -> InputT GHCi ()-locAtCmd str = runExceptGhcMonad $ do- (span',sample) <- exceptT $ parseSpanArg str- infos <- mod_infos <$> getGHCiState- (_,_,sp) <- findLoc infos span' sample- liftIO . putStrLn . showSrcSpan $ sp---------------------------------------------------------------------------------- | @:all-types@ command--allTypesCmd :: String -> InputT GHCi ()-allTypesCmd _ = runExceptGhcMonad $ do- infos <- mod_infos <$> getGHCiState- forM_ (M.elems infos) $ \mi ->- forM_ (modinfoSpans mi) (lift . printSpan)- where- printSpan span'- | Just ty <- spaninfoType span' = do- df <- getDynFlags- let tyInfo = unwords . words $- showSDocForUser df alwaysQualify (pprTypeForUser ty)- liftIO . putStrLn $- showRealSrcSpan (spaninfoSrcSpan span') ++ ": " ++ tyInfo- | otherwise = return ()---------------------------------------------------------------------------------- Helpers for locAtCmd/typeAtCmd/usesCmd---- | Parse a span: <module-name/filepath> <sl> <sc> <el> <ec> <string>-parseSpanArg :: String -> Either SDoc (RealSrcSpan,String)-parseSpanArg s = do- (fp,s0) <- readAsString (skipWs s)- s0' <- skipWs1 s0- (sl,s1) <- readAsInt s0'- s1' <- skipWs1 s1- (sc,s2) <- readAsInt s1'- s2' <- skipWs1 s2- (el,s3) <- readAsInt s2'- s3' <- skipWs1 s3- (ec,s4) <- readAsInt s3'-- trailer <- case s4 of- [] -> Right ""- _ -> skipWs1 s4-- let fs = mkFastString fp- span' = mkRealSrcSpan (mkRealSrcLoc fs sl sc)- (mkRealSrcLoc fs el ec)-- return (span',trailer)- where- readAsInt :: String -> Either SDoc (Int,String)- readAsInt "" = Left "Premature end of string while expecting Int"- readAsInt s0 = case reads s0 of- [s_rest] -> Right s_rest- _ -> Left ("Couldn't read" <+> text (show s0) <+> "as Int")-- readAsString :: String -> Either SDoc (String,String)- readAsString s0- | '"':_ <- s0 = case reads s0 of- [s_rest] -> Right s_rest- _ -> leftRes- | s_rest@(_:_,_) <- breakWs s0 = Right s_rest- | otherwise = leftRes- where- leftRes = Left ("Couldn't read" <+> text (show s0) <+> "as String")-- skipWs1 :: String -> Either SDoc String- skipWs1 (c:cs) | isWs c = Right (skipWs cs)- skipWs1 s0 = Left ("Expected whitespace in" <+> text (show s0))-- isWs = (`elem` [' ','\t'])- skipWs = dropWhile isWs- breakWs = break isWs----- | Pretty-print \"real\" 'SrcSpan's as--- @<filename>:(<line>,<col>)-(<line-end>,<col-end>)@--- while simply unpacking 'UnhelpfulSpan's-showSrcSpan :: SrcSpan -> String-showSrcSpan (UnhelpfulSpan s) = unpackFS s-showSrcSpan (RealSrcSpan spn) = showRealSrcSpan spn---- | Variant of 'showSrcSpan' for 'RealSrcSpan's-showRealSrcSpan :: RealSrcSpan -> String-showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc- , ")-(", show el, ",", show ec, ")"- ]- where- fp = unpackFS (srcSpanFile spn)- sl = srcSpanStartLine spn- sc = srcSpanStartCol spn- el = srcSpanEndLine spn- ec = srcSpanEndCol spn---------------------------------------------------------------------------------- | @:kind@ command--kindOfType :: Bool -> String -> InputT GHCi ()-kindOfType norm str = handleSourceError GHC.printException $ do- (ty, kind) <- GHC.typeKind norm str- printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind- , ppWhen norm $ equals <+> pprTypeForUser ty ]---------------------------------------------------------------------------------- :quit--quit :: String -> InputT GHCi Bool-quit _ = return True----------------------------------------------------------------------------------- :script---- running a script file #1363--scriptCmd :: String -> InputT GHCi ()-scriptCmd ws = do- case words ws of- [s] -> runScript s- _ -> throwGhcException (CmdLineError "syntax: :script <filename>")--runScript :: String -- ^ filename- -> InputT GHCi ()-runScript filename = do- filename' <- expandPath filename- either_script <- liftIO $ tryIO (openFile filename' ReadMode)- case either_script of- Left _err -> throwGhcException (CmdLineError $ "IO error: \""++filename++"\" "- ++(ioeGetErrorString _err))- Right script -> do- st <- getGHCiState- let prog = progname st- line = line_number st- setGHCiState st{progname=filename',line_number=0}- scriptLoop script- liftIO $ hClose script- new_st <- getGHCiState- setGHCiState new_st{progname=prog,line_number=line}- where scriptLoop script = do- res <- runOneCommand handler $ fileLoop script- case res of- Nothing -> return ()- Just s -> if s- then scriptLoop script- else return ()---------------------------------------------------------------------------------- :issafe---- Displaying Safe Haskell properties of a module--isSafeCmd :: String -> InputT GHCi ()-isSafeCmd m =- case words m of- [s] | looksLikeModuleName s -> do- md <- lift $ lookupModule s- isSafeModule md- [] -> do md <- guessCurrentModule "issafe"- isSafeModule md- _ -> throwGhcException (CmdLineError "syntax: :issafe <module>")--isSafeModule :: Module -> InputT GHCi ()-isSafeModule m = do- mb_mod_info <- GHC.getModuleInfo m- when (isNothing mb_mod_info)- (throwGhcException $ CmdLineError $ "unknown module: " ++ mname)-- dflags <- getDynFlags- let iface = GHC.modInfoIface $ fromJust mb_mod_info- when (isNothing iface)- (throwGhcException $ CmdLineError $ "can't load interface file for module: " ++- (GHC.moduleNameString $ GHC.moduleName m))-- (msafe, pkgs) <- GHC.moduleTrustReqs m- let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface- pkg = if packageTrusted dflags m then "trusted" else "untrusted"- (good, bad) = tallyPkgs dflags pkgs-- -- print info to user...- liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"- liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")- when (not $ S.null good)- (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++- (intercalate ", " $ map (showPpr dflags) (S.toList good)))- case msafe && S.null bad of- True -> liftIO $ putStrLn $ mname ++ " is trusted!"- False -> do- when (not $ null bad)- (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "- ++ (intercalate ", " $ map (showPpr dflags) (S.toList bad)))- liftIO $ putStrLn $ mname ++ " is NOT trusted!"-- where- mname = GHC.moduleNameString $ GHC.moduleName m-- packageTrusted dflags md- | thisPackage dflags == moduleUnitId md = True- | otherwise = trusted $ getPackageDetails dflags (moduleUnitId md)-- tallyPkgs dflags deps | not (packageTrustOn dflags) = (S.empty, S.empty)- | otherwise = S.partition part deps- where part pkg = trusted $ getInstalledPackageDetails dflags pkg---------------------------------------------------------------------------------- :browse---- Browsing a module's contents--browseCmd :: Bool -> String -> InputT GHCi ()-browseCmd bang m =- case words m of- ['*':s] | looksLikeModuleName s -> do- md <- lift $ wantInterpretedModule s- browseModule bang md False- [s] | looksLikeModuleName s -> do- md <- lift $ lookupModule s- browseModule bang md True- [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")- browseModule bang md True- _ -> throwGhcException (CmdLineError "syntax: :browse <module>")--guessCurrentModule :: String -> InputT GHCi Module--- Guess which module the user wants to browse. Pick--- modules that are interpreted first. The most--- recently-added module occurs last, it seems.-guessCurrentModule cmd- = do imports <- GHC.getContext- when (null imports) $ throwGhcException $- CmdLineError (':' : cmd ++ ": no current module")- case (head imports) of- IIModule m -> GHC.findModule m Nothing- IIDecl d -> GHC.findModule (unLoc (ideclName d))- (fmap sl_fs $ ideclPkgQual d)---- without bang, show items in context of their parents and omit children--- with bang, show class methods and data constructors separately, and--- indicate import modules, to aid qualifying unqualified names--- with sorted, sort items alphabetically-browseModule :: Bool -> Module -> Bool -> InputT GHCi ()-browseModule bang modl exports_only = do- -- :browse reports qualifiers wrt current context- unqual <- GHC.getPrintUnqual-- mb_mod_info <- GHC.getModuleInfo modl- case mb_mod_info of- Nothing -> throwGhcException (CmdLineError ("unknown module: " ++- GHC.moduleNameString (GHC.moduleName modl)))- Just mod_info -> do- dflags <- getDynFlags- let names- | exports_only = GHC.modInfoExports mod_info- | otherwise = GHC.modInfoTopLevelScope mod_info- `orElse` []-- -- sort alphabetically name, but putting locally-defined- -- identifiers first. We would like to improve this; see #1799.- sorted_names = loc_sort local ++ occ_sort external- where- (local,external) = ASSERT( all isExternalName names )- partition ((==modl) . nameModule) names- occ_sort = sortBy (compare `on` nameOccName)- -- try to sort by src location. If the first name in our list- -- has a good source location, then they all should.- loc_sort ns- | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n)- = sortBy (compare `on` nameSrcSpan) ns- | otherwise- = occ_sort ns-- mb_things <- mapM GHC.lookupName sorted_names- let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)-- rdr_env <- GHC.getGRE-- let things | bang = catMaybes mb_things- | otherwise = filtered_things- pretty | bang = pprTyThing showToHeader- | otherwise = pprTyThingInContext showToHeader-- labels [] = text "-- not currently imported"- labels l = text $ intercalate "\n" $ map qualifier l-- qualifier :: Maybe [ModuleName] -> String- qualifier = maybe "-- defined locally"- (("-- imported via "++) . intercalate ", "- . map GHC.moduleNameString)- importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env-- modNames :: [[Maybe [ModuleName]]]- modNames = map (importInfo . GHC.getName) things-- -- annotate groups of imports with their import modules- -- the default ordering is somewhat arbitrary, so we group- -- by header and sort groups; the names themselves should- -- really come in order of source appearance.. (trac #1799)- annotate mts = concatMap (\(m,ts)->labels m:ts)- $ sortBy cmpQualifiers $ grp mts- where cmpQualifiers =- compare `on` (map (fmap (map moduleNameFS)) . fst)- grp [] = []- grp mts@((m,_):_) = (m,map snd g) : grp ng- where (g,ng) = partition ((==m).fst) mts-- let prettyThings, prettyThings' :: [SDoc]- prettyThings = map pretty things- prettyThings' | bang = annotate $ zip modNames prettyThings- | otherwise = prettyThings- liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings')- -- ToDo: modInfoInstances currently throws an exception for- -- package modules. When it works, we can do this:- -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))----------------------------------------------------------------------------------- :module---- Setting the module context. For details on context handling see--- "remembered_ctx" and "transient_ctx" in GhciMonad.--moduleCmd :: String -> GHCi ()-moduleCmd str- | all sensible strs = cmd- | otherwise = throwGhcException (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")- where- (cmd, strs) =- case str of- '+':stuff -> rest addModulesToContext stuff- '-':stuff -> rest remModulesFromContext stuff- stuff -> rest setContext stuff-- rest op stuff = (op as bs, stuffs)- where (as,bs) = partitionWith starred stuffs- stuffs = words stuff-- sensible ('*':m) = looksLikeModuleName m- sensible m = looksLikeModuleName m-- starred ('*':m) = Left (GHC.mkModuleName m)- starred m = Right (GHC.mkModuleName m)----- -------------------------------------------------------------------------------- Four ways to manipulate the context:--- (a) :module +<stuff>: addModulesToContext--- (b) :module -<stuff>: remModulesFromContext--- (c) :module <stuff>: setContext--- (d) import <module>...: addImportToContext--addModulesToContext :: [ModuleName] -> [ModuleName] -> GHCi ()-addModulesToContext starred unstarred = restoreContextOnFailure $ do- addModulesToContext_ starred unstarred--addModulesToContext_ :: [ModuleName] -> [ModuleName] -> GHCi ()-addModulesToContext_ starred unstarred = do- mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)- setGHCContextFromGHCiState--remModulesFromContext :: [ModuleName] -> [ModuleName] -> GHCi ()-remModulesFromContext starred unstarred = do- -- we do *not* call restoreContextOnFailure here. If the user- -- is trying to fix up a context that contains errors by removing- -- modules, we don't want GHC to silently put them back in again.- mapM_ rm (starred ++ unstarred)- setGHCContextFromGHCiState- where- rm :: ModuleName -> GHCi ()- rm str = do- m <- moduleName <$> lookupModuleName str- let filt = filter ((/=) m . iiModuleName)- modifyGHCiState $ \st ->- st { remembered_ctx = filt (remembered_ctx st)- , transient_ctx = filt (transient_ctx st) }--setContext :: [ModuleName] -> [ModuleName] -> GHCi ()-setContext starred unstarred = restoreContextOnFailure $ do- modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }- -- delete the transient context- addModulesToContext_ starred unstarred--addImportToContext :: String -> GHCi ()-addImportToContext str = restoreContextOnFailure $ do- idecl <- GHC.parseImportDecl str- addII (IIDecl idecl) -- #5836- setGHCContextFromGHCiState---- Util used by addImportToContext and addModulesToContext-addII :: InteractiveImport -> GHCi ()-addII iidecl = do- checkAdd iidecl- modifyGHCiState $ \st ->- st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st)- , transient_ctx = filter (not . (iidecl `iiSubsumes`))- (transient_ctx st)- }---- Sometimes we can't tell whether an import is valid or not until--- we finally call 'GHC.setContext'. e.g.------ import System.IO (foo)------ will fail because System.IO does not export foo. In this case we--- don't want to store the import in the context permanently, so we--- catch the failure from 'setGHCContextFromGHCiState' and set the--- context back to what it was.------ See #6007----restoreContextOnFailure :: GHCi a -> GHCi a-restoreContextOnFailure do_this = do- st <- getGHCiState- let rc = remembered_ctx st; tc = transient_ctx st- do_this `gonException` (modifyGHCiState $ \st' ->- st' { remembered_ctx = rc, transient_ctx = tc })---- -------------------------------------------------------------------------------- Validate a module that we want to add to the context--checkAdd :: InteractiveImport -> GHCi ()-checkAdd ii = do- dflags <- getDynFlags- let safe = safeLanguageOn dflags- case ii of- IIModule modname- | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"- | otherwise -> wantInterpretedModuleName modname >> return ()-- IIDecl d -> do- let modname = unLoc (ideclName d)- pkgqual = ideclPkgQual d- m <- GHC.lookupModule modname (fmap sl_fs pkgqual)- when safe $ do- t <- GHC.isModuleTrusted m- when (not t) $ throwGhcException $ ProgramError $ ""---- -------------------------------------------------------------------------------- Update the GHC API's view of the context---- | Sets the GHC context from the GHCi state. The GHC context is--- always set this way, we never modify it incrementally.------ We ignore any imports for which the ModuleName does not currently--- exist. This is so that the remembered_ctx can contain imports for--- modules that are not currently loaded, perhaps because we just did--- a :reload and encountered errors.------ Prelude is added if not already present in the list. Therefore to--- override the implicit Prelude import you can say 'import Prelude ()'--- at the prompt, just as in Haskell source.----setGHCContextFromGHCiState :: GHCi ()-setGHCContextFromGHCiState = do- st <- getGHCiState- -- re-use checkAdd to check whether the module is valid. If the- -- module does not exist, we do *not* want to print an error- -- here, we just want to silently keep the module in the context- -- until such time as the module reappears again. So we ignore- -- the actual exception thrown by checkAdd, using tryBool to- -- turn it into a Bool.- iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st)-- prel_iidecls <- getImplicitPreludeImports iidecls- valid_prel_iidecls <- filterM (tryBool . checkAdd) prel_iidecls-- extra_imports <- filterM (tryBool . checkAdd) (map IIDecl (extra_imports st))-- GHC.setContext $ iidecls ++ extra_imports ++ valid_prel_iidecls---getImplicitPreludeImports :: [InteractiveImport] -> GHCi [InteractiveImport]-getImplicitPreludeImports iidecls = do- -- allow :seti to override -XNoImplicitPrelude- st <- getGHCiState-- -- We add the prelude imports if there are no *-imports, and we also- -- allow each prelude import to be subsumed by another explicit import- -- of the same module. This means that you can override the prelude import- -- with "import Prelude hiding (map)", for example.- let prel_iidecls =- if not (any isIIModule iidecls)- then [ IIDecl imp- | imp <- prelude_imports st- , not (any (sameImpModule imp) iidecls) ]- else []-- return prel_iidecls---- -------------------------------------------------------------------------------- Utils on InteractiveImport--mkIIModule :: ModuleName -> InteractiveImport-mkIIModule = IIModule--mkIIDecl :: ModuleName -> InteractiveImport-mkIIDecl = IIDecl . simpleImportDecl--iiModules :: [InteractiveImport] -> [ModuleName]-iiModules is = [m | IIModule m <- is]--isIIModule :: InteractiveImport -> Bool-isIIModule (IIModule _) = True-isIIModule _ = False--iiModuleName :: InteractiveImport -> ModuleName-iiModuleName (IIModule m) = m-iiModuleName (IIDecl d) = unLoc (ideclName d)--preludeModuleName :: ModuleName-preludeModuleName = GHC.mkModuleName "Clash.Prelude"--sameImpModule :: ImportDecl RdrName -> InteractiveImport -> Bool-sameImpModule _ (IIModule _) = False -- we only care about imports here-sameImpModule imp (IIDecl d) = unLoc (ideclName d) == unLoc (ideclName imp)--addNotSubsumed :: InteractiveImport- -> [InteractiveImport] -> [InteractiveImport]-addNotSubsumed i is- | any (`iiSubsumes` i) is = is- | otherwise = i : filter (not . (i `iiSubsumes`)) is---- | @filterSubsumed is js@ returns the elements of @js@ not subsumed--- by any of @is@.-filterSubsumed :: [InteractiveImport] -> [InteractiveImport]- -> [InteractiveImport]-filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js---- | Returns True if the left import subsumes the right one. Doesn't--- need to be 100% accurate, conservatively returning False is fine.--- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in--- plusProv will ensue (#5904))------ Note that an IIModule does not necessarily subsume an IIDecl,--- because e.g. a module might export a name that is only available--- qualified within the module itself.------ Note that 'import M' does not necessarily subsume 'import M(foo)',--- because M might not export foo and we want an error to be produced--- in that case.----iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool-iiSubsumes (IIModule m1) (IIModule m2) = m1==m2-iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude- = unLoc (ideclName d1) == unLoc (ideclName d2)- && ideclAs d1 == ideclAs d2- && (not (ideclQualified d1) || ideclQualified d2)- && (ideclHiding d1 `hidingSubsumes` ideclHiding d2)- where- _ `hidingSubsumes` Just (False,L _ []) = True- Just (False, L _ xs) `hidingSubsumes` Just (False,L _ ys)- = all (`elem` xs) ys- h1 `hidingSubsumes` h2 = h1 == h2-iiSubsumes _ _ = False---------------------------------------------------------------------------------- :set---- set options in the interpreter. Syntax is exactly the same as the--- ghc command line, except that certain options aren't available (-C,--- -E etc.)------ This is pretty fragile: most options won't work as expected. ToDo:--- figure out which ones & disallow them.--setCmd :: String -> GHCi ()-setCmd "" = showOptions False-setCmd "-a" = showOptions True-setCmd str- = case getCmd str of- Right ("args", rest) ->- case toArgs rest of- Left err -> liftIO (hPutStrLn stderr err)- Right args -> setArgs args- Right ("prog", rest) ->- case toArgs rest of- Right [prog] -> setProg prog- _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")-- Right ("prompt", rest) ->- setPromptString setPrompt (dropWhile isSpace rest)- "syntax: set prompt <string>"- Right ("prompt-function", rest) ->- setPromptFunc setPrompt $ dropWhile isSpace rest- Right ("prompt-cont", rest) ->- setPromptString setPromptCont (dropWhile isSpace rest)- "syntax: :set prompt-cont <string>"- Right ("prompt-cont-function", rest) ->- setPromptFunc setPromptCont $ dropWhile isSpace rest-- Right ("editor", rest) -> setEditor $ dropWhile isSpace rest- Right ("stop", rest) -> setStop $ dropWhile isSpace rest- _ -> case toArgs str of- Left err -> liftIO (hPutStrLn stderr err)- Right wds -> setOptions wds--setiCmd :: String -> GHCi ()-setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False-setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True-setiCmd str =- case toArgs str of- Left err -> liftIO (hPutStrLn stderr err)- Right wds -> newDynFlags True wds--showOptions :: Bool -> GHCi ()-showOptions show_all- = do st <- getGHCiState- dflags <- getDynFlags- let opts = options st- liftIO $ putStrLn (showSDoc dflags (- text "options currently set: " <>- if null opts- then text "none."- else hsep (map (\o -> char '+' <> text (optToStr o)) opts)- ))- getDynFlags >>= liftIO . showDynFlags show_all---showDynFlags :: Bool -> DynFlags -> IO ()-showDynFlags show_all dflags = do- showLanguages' show_all dflags- putStrLn $ showSDoc dflags $- text "GHCi-specific dynamic flag settings:" $$- nest 2 (vcat (map (setting "-f" "-fno-" gopt) ghciFlags))- putStrLn $ showSDoc dflags $- text "other dynamic, non-language, flag settings:" $$- nest 2 (vcat (map (setting "-f" "-fno-" gopt) others))- putStrLn $ showSDoc dflags $- text "warning settings:" $$- nest 2 (vcat (map (setting "-W" "-Wno-" wopt) DynFlags.wWarningFlags))- where- setting prefix noPrefix test flag- | quiet = empty- | is_on = text prefix <> text name- | otherwise = text noPrefix <> text name- where name = flagSpecName flag- f = flagSpecFlag flag- is_on = test f dflags- quiet = not show_all && test f default_dflags == is_on-- default_dflags = defaultDynFlags (settings dflags)-- (ghciFlags,others) = partition (\f -> flagSpecFlag f `elem` flgs)- DynFlags.fFlags- flgs = [ Opt_PrintExplicitForalls- , Opt_PrintExplicitKinds- , Opt_PrintUnicodeSyntax- , Opt_PrintBindResult- , Opt_BreakOnException- , Opt_BreakOnError- , Opt_PrintEvldWithShow- ]--setArgs, setOptions :: [String] -> GHCi ()-setProg, setEditor, setStop :: String -> GHCi ()--setArgs args = do- st <- getGHCiState- wrapper <- mkEvalWrapper (progname st) args- setGHCiState st { GhciMonad.args = args, evalWrapper = wrapper }--setProg prog = do- st <- getGHCiState- wrapper <- mkEvalWrapper prog (GhciMonad.args st)- setGHCiState st { progname = prog, evalWrapper = wrapper }--setEditor cmd = modifyGHCiState (\st -> st { editor = cmd })--setStop str@(c:_) | isDigit c- = do let (nm_str,rest) = break (not.isDigit) str- nm = read nm_str- st <- getGHCiState- let old_breaks = breaks st- if all ((/= nm) . fst) old_breaks- then printForUser (text "Breakpoint" <+> ppr nm <+>- text "does not exist")- else do- let new_breaks = map fn old_breaks- fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })- | otherwise = (i,loc)- setGHCiState st{ breaks = new_breaks }-setStop cmd = modifyGHCiState (\st -> st { stop = cmd })--setPrompt :: PromptFunction -> GHCi ()-setPrompt v = modifyGHCiState (\st -> st {prompt = v})--setPromptCont :: PromptFunction -> GHCi ()-setPromptCont v = modifyGHCiState (\st -> st {prompt_cont = v})--setPromptFunc :: (PromptFunction -> GHCi ()) -> String -> GHCi ()-setPromptFunc fSetPrompt s = do- -- We explicitly annotate the type of the expression to ensure- -- that unsafeCoerce# is passed the exact type necessary rather- -- than a more general one- let exprStr = "(" ++ s ++ ") :: [String] -> Int -> IO String"- (HValue funValue) <- GHC.compileExpr exprStr- fSetPrompt (convertToPromptFunction $ unsafeCoerce funValue)- where- convertToPromptFunction :: ([String] -> Int -> IO String)- -> PromptFunction- convertToPromptFunction func = (\mods line -> liftIO $- liftM text (func mods line))--setPromptString :: (PromptFunction -> GHCi ()) -> String -> String -> GHCi ()-setPromptString fSetPrompt value err = do- if null value- then liftIO $ hPutStrLn stderr $ err- else case value of- ('\"':_) ->- case reads value of- [(value', xs)] | all isSpace xs ->- setParsedPromptString fSetPrompt value'- _ -> liftIO $ hPutStrLn stderr- "Can't parse prompt string. Use Haskell syntax."- _ ->- setParsedPromptString fSetPrompt value--setParsedPromptString :: (PromptFunction -> GHCi ()) -> String -> GHCi ()-setParsedPromptString fSetPrompt s = do- case (checkPromptStringForErrors s) of- Just err ->- liftIO $ hPutStrLn stderr err- Nothing ->- fSetPrompt $ generatePromptFunctionFromString s--setOptions wds =- do -- first, deal with the GHCi opts (+s, +t, etc.)- let (plus_opts, minus_opts) = partitionWith isPlus wds- mapM_ setOpt plus_opts- -- then, dynamic flags- when (not (null minus_opts)) $ newDynFlags False minus_opts--newDynFlags :: Bool -> [String] -> GHCi ()-newDynFlags interactive_only minus_opts = do- let lopts = map noLoc minus_opts-- idflags0 <- GHC.getInteractiveDynFlags- (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts-- liftIO $ handleFlagWarnings idflags1 warns- when (not $ null leftovers)- (throwGhcException . CmdLineError- $ "Some flags have not been recognized: "- ++ (concat . intersperse ", " $ map unLoc leftovers))-- when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do- liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"- GHC.setInteractiveDynFlags idflags1- installInteractivePrint (interactivePrint idflags1) False-- dflags0 <- getDynFlags- when (not interactive_only) $ do- (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts- new_pkgs <- GHC.setProgramDynFlags dflags1-- -- if the package flags changed, reset the context and link- -- the new packages.- hsc_env <- GHC.getSession- let dflags2 = hsc_dflags hsc_env- when (packageFlagsChanged dflags2 dflags0) $ do- when (verbosity dflags2 > 0) $- liftIO . putStrLn $- "package flags have changed, resetting and loading new packages..."- GHC.setTargets []- _ <- GHC.load LoadAllTargets- liftIO $ linkPackages hsc_env new_pkgs- -- package flags changed, we can't re-use any of the old context- setContextAfterLoad False []- -- and copy the package state to the interactive DynFlags- idflags <- GHC.getInteractiveDynFlags- GHC.setInteractiveDynFlags- idflags{ pkgState = pkgState dflags2- , pkgDatabase = pkgDatabase dflags2- , packageFlags = packageFlags dflags2 }-- let ld0length = length $ ldInputs dflags0- fmrk0length = length $ cmdlineFrameworks dflags0-- newLdInputs = drop ld0length (ldInputs dflags2)- newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)-- hsc_env' = hsc_env { hsc_dflags =- dflags2 { ldInputs = newLdInputs- , cmdlineFrameworks = newCLFrameworks } }-- when (not (null newLdInputs && null newCLFrameworks)) $- liftIO $ linkCmdLineLibs hsc_env'-- return ()---unsetOptions :: String -> GHCi ()-unsetOptions str- = -- first, deal with the GHCi opts (+s, +t, etc.)- let opts = words str- (minus_opts, rest1) = partition isMinus opts- (plus_opts, rest2) = partitionWith isPlus rest1- (other_opts, rest3) = partition (`elem` map fst defaulters) rest2-- defaulters =- [ ("args" , setArgs default_args)- , ("prog" , setProg default_progname)- , ("prompt" , setPrompt default_prompt)- , ("prompt-cont", setPromptCont default_prompt_cont)- , ("editor" , liftIO findEditor >>= setEditor)- , ("stop" , setStop default_stop)- ]-- no_flag ('-':'f':rest) = return ("-fno-" ++ rest)- no_flag ('-':'X':rest) = return ("-XNo" ++ rest)- no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f))-- in if (not (null rest3))- then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))- else do- mapM_ (fromJust.flip lookup defaulters) other_opts-- mapM_ unsetOpt plus_opts-- no_flags <- mapM no_flag minus_opts- when (not (null no_flags)) $ newDynFlags False no_flags--isMinus :: String -> Bool-isMinus ('-':_) = True-isMinus _ = False--isPlus :: String -> Either String String-isPlus ('+':opt) = Left opt-isPlus other = Right other--setOpt, unsetOpt :: String -> GHCi ()--setOpt str- = case strToGHCiOpt str of- Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))- Just o -> setOption o--unsetOpt str- = case strToGHCiOpt str of- Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))- Just o -> unsetOption o--strToGHCiOpt :: String -> (Maybe GHCiOption)-strToGHCiOpt "m" = Just Multiline-strToGHCiOpt "s" = Just ShowTiming-strToGHCiOpt "t" = Just ShowType-strToGHCiOpt "r" = Just RevertCAFs-strToGHCiOpt "c" = Just CollectInfo-strToGHCiOpt _ = Nothing--optToStr :: GHCiOption -> String-optToStr Multiline = "m"-optToStr ShowTiming = "s"-optToStr ShowType = "t"-optToStr RevertCAFs = "r"-optToStr CollectInfo = "c"----- ------------------------------------------------------------------------------ :show--showCmd :: String -> GHCi ()-showCmd "" = showOptions False-showCmd "-a" = showOptions True-showCmd str = do- st <- getGHCiState- dflags <- getDynFlags-- let lookupCmd :: String -> Maybe (GHCi ())- lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds-- -- (show in help?, command name, action)- action :: String -> GHCi () -> (Bool, String, GHCi ())- action name m = (True, name, m)-- hidden :: String -> GHCi () -> (Bool, String, GHCi ())- hidden name m = (False, name, m)-- cmds =- [ action "args" $ liftIO $ putStrLn (show (GhciMonad.args st))- , action "prog" $ liftIO $ putStrLn (show (progname st))- , action "editor" $ liftIO $ putStrLn (show (editor st))- , action "stop" $ liftIO $ putStrLn (show (stop st))- , action "imports" $ showImports- , action "modules" $ showModules- , action "bindings" $ showBindings- , action "linker" $ getDynFlags >>= liftIO . showLinkerState- , action "breaks" $ showBkptTable- , action "context" $ showContext- , action "packages" $ showPackages- , action "paths" $ showPaths- , action "language" $ showLanguages- , hidden "languages" $ showLanguages -- backwards compat- , hidden "lang" $ showLanguages -- useful abbreviation- ]-- case words str of- [w] | Just action <- lookupCmd w -> action-- _ -> let helpCmds = [ text name | (True, name, _) <- cmds ]- in throwGhcException $ CmdLineError $ showSDoc dflags- $ hang (text "syntax:") 4- $ hang (text ":show") 6- $ brackets (fsep $ punctuate (text " |") helpCmds)--showiCmd :: String -> GHCi ()-showiCmd str = do- case words str of- ["languages"] -> showiLanguages -- backwards compat- ["language"] -> showiLanguages- ["lang"] -> showiLanguages -- useful abbreviation- _ -> throwGhcException (CmdLineError ("syntax: :showi language"))--showImports :: GHCi ()-showImports = do- st <- getGHCiState- dflags <- getDynFlags- let rem_ctx = reverse (remembered_ctx st)- trans_ctx = transient_ctx st-- show_one (IIModule star_m)- = ":module +*" ++ moduleNameString star_m- show_one (IIDecl imp) = showPpr dflags imp-- prel_iidecls <- getImplicitPreludeImports (rem_ctx ++ trans_ctx)-- let show_prel p = show_one p ++ " -- implicit"- show_extra p = show_one (IIDecl p) ++ " -- fixed"-- trans_comment s = s ++ " -- added automatically" :: String- --- liftIO $ mapM_ putStrLn (map show_one rem_ctx ++- map (trans_comment . show_one) trans_ctx ++- map show_prel prel_iidecls ++- map show_extra (extra_imports st))--showModules :: GHCi ()-showModules = do- loaded_mods <- getLoadedModules- -- we want *loaded* modules only, see #1734- let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)- mapM_ show_one loaded_mods--getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]-getLoadedModules = do- graph <- GHC.getModuleGraph- filterM (GHC.isLoaded . GHC.ms_mod_name) graph--showBindings :: GHCi ()-showBindings = do- bindings <- GHC.getBindings- (insts, finsts) <- GHC.getInsts- docs <- mapM makeDoc (reverse bindings)- -- reverse so the new ones come last- let idocs = map GHC.pprInstanceHdr insts- fidocs = map GHC.pprFamInst finsts- mapM_ printForUserPartWay (docs ++ idocs ++ fidocs)- where- makeDoc (AnId i) = pprTypeAndContents i- makeDoc tt = do- mb_stuff <- GHC.getInfo False (getName tt)- return $ maybe (text "") pprTT mb_stuff-- pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc- pprTT (thing, fixity, _cls_insts, _fam_insts)- = pprTyThing showToHeader thing- $$ show_fixity- where- show_fixity- | fixity == GHC.defaultFixity = empty- | otherwise = ppr fixity <+> ppr (GHC.getName thing)---printTyThing :: TyThing -> GHCi ()-printTyThing tyth = printForUser (pprTyThing showToHeader tyth)--showBkptTable :: GHCi ()-showBkptTable = do- st <- getGHCiState- printForUser $ prettyLocations (breaks st)--showContext :: GHCi ()-showContext = do- resumes <- GHC.getResumeContext- printForUser $ vcat (map pp_resume (reverse resumes))- where- pp_resume res =- ptext (sLit "--> ") <> text (GHC.resumeStmt res)- $$ nest 2 (pprStopped res)--pprStopped :: GHC.Resume -> SDoc-pprStopped res =- ptext (sLit "Stopped in")- <+> ((case mb_mod_name of- Nothing -> empty- Just mod_name -> text (moduleNameString mod_name) <> char '.')- <> text (GHC.resumeDecl res))- <> char ',' <+> ppr (GHC.resumeSpan res)- where- mb_mod_name = moduleName <$> GHC.breakInfo_module <$> GHC.resumeBreakInfo res--showPackages :: GHCi ()-showPackages = do- dflags <- getDynFlags- let pkg_flags = packageFlags dflags- liftIO $ putStrLn $ showSDoc dflags $- text ("active package flags:"++if null pkg_flags then " none" else "") $$- nest 2 (vcat (map pprFlag pkg_flags))--showPaths :: GHCi ()-showPaths = do- dflags <- getDynFlags- liftIO $ do- cwd <- getCurrentDirectory- putStrLn $ showSDoc dflags $- text "current working directory: " $$- nest 2 (text cwd)- let ipaths = importPaths dflags- putStrLn $ showSDoc dflags $- text ("module import search paths:"++if null ipaths then " none" else "") $$- nest 2 (vcat (map text ipaths))--showLanguages :: GHCi ()-showLanguages = getDynFlags >>= liftIO . showLanguages' False--showiLanguages :: GHCi ()-showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False--showLanguages' :: Bool -> DynFlags -> IO ()-showLanguages' show_all dflags =- putStrLn $ showSDoc dflags $ vcat- [ text "base language is: " <>- case language dflags of- Nothing -> text "Haskell2010"- Just Haskell98 -> text "Haskell98"- Just Haskell2010 -> text "Haskell2010"- , (if show_all then text "all active language options:"- else text "with the following modifiers:") $$- nest 2 (vcat (map (setting xopt) DynFlags.xFlags))- ]- where- setting test flag- | quiet = empty- | is_on = text "-X" <> text name- | otherwise = text "-XNo" <> text name- where name = flagSpecName flag- f = flagSpecFlag flag- is_on = test f dflags- quiet = not show_all && test f default_dflags == is_on-- default_dflags =- defaultDynFlags (settings dflags) `lang_set`- case language dflags of- Nothing -> Just Haskell2010- other -> other---- -------------------------------------------------------------------------------- Completion--completeCmd :: String -> GHCi ()-completeCmd argLine0 = case parseLine argLine0 of- Just ("repl", resultRange, left) -> do- (unusedLine,compls) <- ghciCompleteWord (reverse left,"")- let compls' = takeRange resultRange compls- liftIO . putStrLn $ unwords [ show (length compls'), show (length compls), show (reverse unusedLine) ]- forM_ (takeRange resultRange compls) $ \(Completion r _ _) -> do- liftIO $ print r- _ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>")- where- parseLine argLine- | null argLine = Nothing- | null rest1 = Nothing- | otherwise = (,,) dom <$> resRange <*> s- where- (dom, rest1) = breakSpace argLine- (rng, rest2) = breakSpace rest1- resRange | head rest1 == '"' = parseRange ""- | otherwise = parseRange rng- s | head rest1 == '"' = readMaybe rest1 :: Maybe String- | otherwise = readMaybe rest2- breakSpace = fmap (dropWhile isSpace) . break isSpace-- takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub-- -- syntax: [n-][m] with semantics "drop (n-1) . take m"- parseRange :: String -> Maybe (Maybe Int,Maybe Int)- parseRange s = case span isDigit s of- (_, "") ->- -- upper limit only- Just (Nothing, bndRead s)- (s1, '-' : s2)- | all isDigit s2 ->- Just (bndRead s1, bndRead s2)- _ ->- Nothing- where- bndRead x = if null x then Nothing else Just (read x)----completeGhciCommand, completeMacro, completeIdentifier, completeModule,- completeSetModule, completeSeti, completeShowiOptions,- completeHomeModule, completeSetOptions, completeShowOptions,- completeHomeModuleOrFile, completeExpression- :: CompletionFunc GHCi---- | Provide completions for last word in a given string.------ Takes a tuple of two strings. First string is a reversed line to be--- completed. Second string is likely unused, 'completeCmd' always passes an--- empty string as second item in tuple.-ghciCompleteWord :: CompletionFunc GHCi-ghciCompleteWord line@(left,_) = case firstWord of- -- If given string starts with `:` colon, and there is only one following- -- word then provide REPL command completions. If there is more than one- -- word complete either filename or builtin ghci commands or macros.- ':':cmd | null rest -> completeGhciCommand line- | otherwise -> do- completion <- lookupCompletion cmd- completion line- -- If given string starts with `import` keyword provide module name- -- completions- "import" -> completeModule line- -- otherwise provide identifier completions- _ -> completeExpression line- where- (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left- lookupCompletion ('!':_) = return completeFilename- lookupCompletion c = do- maybe_cmd <- lookupCommand' c- case maybe_cmd of- Just cmd -> return (cmdCompletionFunc cmd)- Nothing -> return completeFilename--completeGhciCommand = wrapCompleter " " $ \w -> do- macros <- ghci_macros <$> getGHCiState- cmds <- ghci_commands `fmap` getGHCiState- let macro_names = map (':':) . map cmdName $ macros- let command_names = map (':':) . map cmdName $ filter (not . cmdHidden) cmds- let{ candidates = case w of- ':' : ':' : _ -> map (':':) command_names- _ -> nub $ macro_names ++ command_names }- return $ filter (w `isPrefixOf`) candidates--completeMacro = wrapIdentCompleter $ \w -> do- cmds <- ghci_macros <$> getGHCiState- return (filter (w `isPrefixOf`) (map cmdName cmds))--completeIdentifier line@(left, _) =- -- Note: `left` is a reversed input- case left of- (x:_) | isSymbolChar x -> wrapCompleter (specials ++ spaces) complete line- _ -> wrapIdentCompleter complete line- where- complete w = do- rdrs <- GHC.getRdrNamesInScope- dflags <- GHC.getSessionDynFlags- return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))--completeModule = wrapIdentCompleter $ \w -> do- dflags <- GHC.getSessionDynFlags- let pkg_mods = allVisibleModules dflags- loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules- return $ filter (w `isPrefixOf`)- $ map (showPpr dflags) $ loaded_mods ++ pkg_mods--completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do- dflags <- GHC.getSessionDynFlags- modules <- case m of- Just '-' -> do- imports <- GHC.getContext- return $ map iiModuleName imports- _ -> do- let pkg_mods = allVisibleModules dflags- loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules- return $ loaded_mods ++ pkg_mods- return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules--completeHomeModule = wrapIdentCompleter listHomeModules--listHomeModules :: String -> GHCi [String]-listHomeModules w = do- g <- GHC.getModuleGraph- let home_mods = map GHC.ms_mod_name g- dflags <- getDynFlags- return $ sort $ filter (w `isPrefixOf`)- $ map (showPpr dflags) home_mods--completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do- return (filter (w `isPrefixOf`) opts)- where opts = "args":"prog":"prompt":"prompt-cont":"prompt-function":- "prompt-cont-function":"editor":"stop":flagList- flagList = map head $ group $ sort allNonDeprecatedFlags--completeSeti = wrapCompleter flagWordBreakChars $ \w -> do- return (filter (w `isPrefixOf`) flagList)- where flagList = map head $ group $ sort allNonDeprecatedFlags--completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do- return (filter (w `isPrefixOf`) opts)- where opts = ["args", "prog", "editor", "stop",- "modules", "bindings", "linker", "breaks",- "context", "packages", "paths", "language", "imports"]--completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do- return (filter (w `isPrefixOf`) ["language"])--completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars- $ unionComplete (fmap (map simpleCompletion) . listHomeModules)- listFiles--unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]-unionComplete f1 f2 line = do- cs1 <- f1 line- cs2 <- f2 line- return (cs1 ++ cs2)--wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi-wrapCompleter breakChars fun = completeWord Nothing breakChars- $ fmap (map simpleCompletion . nubSort) . fun--wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi-wrapIdentCompleter = wrapCompleter word_break_chars--wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi-wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars- $ \rest -> fmap (map simpleCompletion . nubSort) . fun (getModifier rest)- where- getModifier = find (`elem` modifChars)---- | Return a list of visible module names for autocompletion.--- (NB: exposed != visible)-allVisibleModules :: DynFlags -> [ModuleName]-allVisibleModules dflags = listVisibleModuleNames dflags--completeExpression = completeQuotedWord (Just '\\') "\"" listFiles- completeIdentifier----- -------------------------------------------------------------------------------- commands for debugger--sprintCmd, printCmd, forceCmd :: String -> GHCi ()-sprintCmd = pprintCommand False False-printCmd = pprintCommand True False-forceCmd = pprintCommand False True--pprintCommand :: Bool -> Bool -> String -> GHCi ()-pprintCommand bind force str = do- pprintClosureCommand bind force str--stepCmd :: String -> GHCi ()-stepCmd arg = withSandboxOnly ":step" $ step arg- where- step [] = doContinue (const True) GHC.SingleStep- step expression = runStmt expression GHC.SingleStep >> return ()--stepLocalCmd :: String -> GHCi ()-stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg- where- step expr- | not (null expr) = stepCmd expr- | otherwise = do- mb_span <- getCurrentBreakSpan- case mb_span of- Nothing -> stepCmd []- Just loc -> do- Just md <- getCurrentBreakModule- current_toplevel_decl <- enclosingTickSpan md loc- doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep--stepModuleCmd :: String -> GHCi ()-stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg- where- step expr- | not (null expr) = stepCmd expr- | otherwise = do- mb_span <- getCurrentBreakSpan- case mb_span of- Nothing -> stepCmd []- Just pan -> do- let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span- doContinue f GHC.SingleStep---- | Returns the span of the largest tick containing the srcspan given-enclosingTickSpan :: Module -> SrcSpan -> GHCi RealSrcSpan-enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"-enclosingTickSpan md (RealSrcSpan src) = do- ticks <- getTickArray md- let line = srcSpanStartLine src- ASSERT(inRange (bounds ticks) line) do- let enclosing_spans = [ pan | (_,pan) <- ticks ! line- , realSrcSpanEnd pan >= realSrcSpanEnd src]- return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans- where--leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering-leftmostLargestRealSrcSpan a b =- (realSrcSpanStart a `compare` realSrcSpanStart b)- `thenCmp`- (realSrcSpanEnd b `compare` realSrcSpanEnd a)--traceCmd :: String -> GHCi ()-traceCmd arg- = withSandboxOnly ":trace" $ tr arg- where- tr [] = doContinue (const True) GHC.RunAndLogSteps- tr expression = runStmt expression GHC.RunAndLogSteps >> return ()--continueCmd :: String -> GHCi ()-continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion---- doContinue :: SingleStep -> GHCi ()-doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()-doContinue pre step = do- runResult <- resume pre step- _ <- afterRunStmt pre runResult- return ()--abandonCmd :: String -> GHCi ()-abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do- b <- GHC.abandon -- the prompt will change to indicate the new context- when (not b) $ liftIO $ putStrLn "There is no computation running."--deleteCmd :: String -> GHCi ()-deleteCmd argLine = withSandboxOnly ":delete" $ do- deleteSwitch $ words argLine- where- deleteSwitch :: [String] -> GHCi ()- deleteSwitch [] =- liftIO $ putStrLn "The delete command requires at least one argument."- -- delete all break points- deleteSwitch ("*":_rest) = discardActiveBreakPoints- deleteSwitch idents = do- mapM_ deleteOneBreak idents- where- deleteOneBreak :: String -> GHCi ()- deleteOneBreak str- | all isDigit str = deleteBreak (read str)- | otherwise = return ()--historyCmd :: String -> GHCi ()-historyCmd arg- | null arg = history 20- | all isDigit arg = history (read arg)- | otherwise = liftIO $ putStrLn "Syntax: :history [num]"- where- history num = do- resumes <- GHC.getResumeContext- case resumes of- [] -> liftIO $ putStrLn "Not stopped at a breakpoint"- (r:_) -> do- let hist = GHC.resumeHistory r- (took,rest) = splitAt num hist- case hist of- [] -> liftIO $ putStrLn $- "Empty history. Perhaps you forgot to use :trace?"- _ -> do- pans <- mapM GHC.getHistorySpan took- let nums = map (printf "-%-3d:") [(1::Int)..]- names = map GHC.historyEnclosingDecls took- printForUser (vcat(zipWith3- (\x y z -> x <+> y <+> z)- (map text nums)- (map (bold . hcat . punctuate colon . map text) names)- (map (parens . ppr) pans)))- liftIO $ putStrLn $ if null rest then "<end of history>" else "..."--bold :: SDoc -> SDoc-bold c | do_bold = text start_bold <> c <> text end_bold- | otherwise = c--backCmd :: String -> GHCi ()-backCmd arg- | null arg = back 1- | all isDigit arg = back (read arg)- | otherwise = liftIO $ putStrLn "Syntax: :back [num]"- where- back num = withSandboxOnly ":back" $ do- (names, _, pan, _) <- GHC.back num- printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan- printTypeOfNames names- -- run the command set with ":set stop <cmd>"- st <- getGHCiState- enqueueCommands [stop st]--forwardCmd :: String -> GHCi ()-forwardCmd arg- | null arg = forward 1- | all isDigit arg = forward (read arg)- | otherwise = liftIO $ putStrLn "Syntax: :back [num]"- where- forward num = withSandboxOnly ":forward" $ do- (names, ix, pan, _) <- GHC.forward num- printForUser $ (if (ix == 0)- then ptext (sLit "Stopped at")- else ptext (sLit "Logged breakpoint at")) <+> ppr pan- printTypeOfNames names- -- run the command set with ":set stop <cmd>"- st <- getGHCiState- enqueueCommands [stop st]---- handle the "break" command-breakCmd :: String -> GHCi ()-breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine--breakSwitch :: [String] -> GHCi ()-breakSwitch [] = do- liftIO $ putStrLn "The break command requires at least one argument."-breakSwitch (arg1:rest)- | looksLikeModuleName arg1 && not (null rest) = do- md <- wantInterpretedModule arg1- breakByModule md rest- | all isDigit arg1 = do- imports <- GHC.getContext- case iiModules imports of- (mn : _) -> do- md <- lookupModuleName mn- breakByModuleLine md (read arg1) rest- [] -> do- liftIO $ putStrLn "No modules are loaded with debugging support."- | otherwise = do -- try parsing it as an identifier- wantNameFromInterpretedModule noCanDo arg1 $ \name -> do- maybe_info <- GHC.getModuleInfo (GHC.nameModule name)- case maybe_info of- Nothing -> noCanDo name (ptext (sLit "cannot get module info"))- Just minf ->- ASSERT( isExternalName name )- findBreakAndSet (GHC.nameModule name) $- findBreakForBind name (GHC.modInfoModBreaks minf)- where- noCanDo n why = printForUser $- text "cannot set breakpoint on " <> ppr n <> text ": " <> why--breakByModule :: Module -> [String] -> GHCi ()-breakByModule md (arg1:rest)- | all isDigit arg1 = do -- looks like a line number- breakByModuleLine md (read arg1) rest-breakByModule _ _- = breakSyntax--breakByModuleLine :: Module -> Int -> [String] -> GHCi ()-breakByModuleLine md line args- | [] <- args = findBreakAndSet md $ maybeToList . findBreakByLine line- | [col] <- args, all isDigit col =- findBreakAndSet md $ maybeToList . findBreakByCoord Nothing (line, read col)- | otherwise = breakSyntax--breakSyntax :: a-breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")--findBreakAndSet :: Module -> (TickArray -> [(Int, RealSrcSpan)]) -> GHCi ()-findBreakAndSet md lookupTickTree = do- tickArray <- getTickArray md- (breakArray, _) <- getModBreak md- case lookupTickTree tickArray of- [] -> liftIO $ putStrLn $ "No breakpoints found at that location."- some -> mapM_ (breakAt breakArray) some- where- breakAt breakArray (tick, pan) = do- setBreakFlag True breakArray tick- (alreadySet, nm) <-- recordBreak $ BreakLocation- { breakModule = md- , breakLoc = RealSrcSpan pan- , breakTick = tick- , onBreakCmd = ""- }- printForUser $- text "Breakpoint " <> ppr nm <>- if alreadySet- then text " was already set at " <> ppr pan- else text " activated at " <> ppr pan---- When a line number is specified, the current policy for choosing--- the best breakpoint is this:--- - the leftmost complete subexpression on the specified line, or--- - the leftmost subexpression starting on the specified line, or--- - the rightmost subexpression enclosing the specified line----findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan)-findBreakByLine line arr- | not (inRange (bounds arr) line) = Nothing- | otherwise =- listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd) comp) `mplus`- listToMaybe (sortBy (compare `on` snd) incomp) `mplus`- listToMaybe (sortBy (flip compare `on` snd) ticks)- where- ticks = arr ! line-- starts_here = [ (ix,pan) | (ix, pan) <- ticks,- GHC.srcSpanStartLine pan == line ]-- (comp, incomp) = partition ends_here starts_here- where ends_here (_,pan) = GHC.srcSpanEndLine pan == line---- The aim is to find the breakpoints for all the RHSs of the--- equations corresponding to a binding. So we find all breakpoints--- for--- (a) this binder only (not a nested declaration)--- (b) that do not have an enclosing breakpoint-findBreakForBind :: Name -> GHC.ModBreaks -> TickArray- -> [(BreakIndex,RealSrcSpan)]-findBreakForBind name modbreaks _ = filter (not . enclosed) ticks- where- ticks = [ (index, span)- | (index, [n]) <- assocs (GHC.modBreaks_decls modbreaks),- n == occNameString (nameOccName name),- RealSrcSpan span <- [GHC.modBreaks_locs modbreaks ! index] ]- enclosed (_,sp0) = any subspan ticks- where subspan (_,sp) = sp /= sp0 &&- realSrcSpanStart sp <= realSrcSpanStart sp0 &&- realSrcSpanEnd sp0 <= realSrcSpanEnd sp--findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray- -> Maybe (BreakIndex,RealSrcSpan)-findBreakByCoord mb_file (line, col) arr- | not (inRange (bounds arr) line) = Nothing- | otherwise =- listToMaybe (sortBy (flip compare `on` snd) contains ++- sortBy (compare `on` snd) after_here)- where- ticks = arr ! line-- -- the ticks that span this coordinate- contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan `spans` (line,col),- is_correct_file pan ]-- is_correct_file pan- | Just f <- mb_file = GHC.srcSpanFile pan == f- | otherwise = True-- after_here = [ tick | tick@(_,pan) <- ticks,- GHC.srcSpanStartLine pan == line,- GHC.srcSpanStartCol pan >= col ]---- For now, use ANSI bold on terminals that we know support it.--- Otherwise, we add a line of carets under the active expression instead.--- In particular, on Windows and when running the testsuite (which sets--- TERM to vt100 for other reasons) we get carets.--- We really ought to use a proper termcap/terminfo library.-do_bold :: Bool-do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]- where mTerm = System.Environment.getEnv "TERM"- `catchIO` \_ -> return "TERM not set"--start_bold :: String-start_bold = "\ESC[1m"-end_bold :: String-end_bold = "\ESC[0m"---------------------------------------------------------------------------------- :where--whereCmd :: String -> GHCi ()-whereCmd = noArgs $ do- mstrs <- getCallStackAtCurrentBreakpoint- case mstrs of- Nothing -> return ()- Just strs -> liftIO $ putStrLn (renderStack strs)---------------------------------------------------------------------------------- :list--listCmd :: String -> InputT GHCi ()-listCmd c = listCmd' c--listCmd' :: String -> InputT GHCi ()-listCmd' "" = do- mb_span <- lift getCurrentBreakSpan- case mb_span of- Nothing ->- printForUser $ text "Not stopped at a breakpoint; nothing to list"- Just (RealSrcSpan pan) ->- listAround pan True- Just pan@(UnhelpfulSpan _) ->- do resumes <- GHC.getResumeContext- case resumes of- [] -> panic "No resumes"- (r:_) ->- do let traceIt = case GHC.resumeHistory r of- [] -> text "rerunning with :trace,"- _ -> empty- doWhat = traceIt <+> text ":back then :list"- printForUser (text "Unable to list source for" <+>- ppr pan- $$ text "Try" <+> doWhat)-listCmd' str = list2 (words str)--list2 :: [String] -> InputT GHCi ()-list2 [arg] | all isDigit arg = do- imports <- GHC.getContext- case iiModules imports of- [] -> liftIO $ putStrLn "No module to list"- (mn : _) -> do- md <- lift $ lookupModuleName mn- listModuleLine md (read arg)-list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do- md <- wantInterpretedModule arg1- listModuleLine md (read arg2)-list2 [arg] = do- wantNameFromInterpretedModule noCanDo arg $ \name -> do- let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)- case loc of- RealSrcLoc l ->- do tickArray <- ASSERT( isExternalName name )- lift $ getTickArray (GHC.nameModule name)- let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))- (GHC.srcLocLine l, GHC.srcLocCol l)- tickArray- case mb_span of- Nothing -> listAround (realSrcLocSpan l) False- Just (_, pan) -> listAround pan False- UnhelpfulLoc _ ->- noCanDo name $ text "can't find its location: " <>- ppr loc- where- noCanDo n why = printForUser $- text "cannot list source code for " <> ppr n <> text ": " <> why-list2 _other =- liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"--listModuleLine :: Module -> Int -> InputT GHCi ()-listModuleLine modl line = do- graph <- GHC.getModuleGraph- let this = filter ((== modl) . GHC.ms_mod) graph- case this of- [] -> panic "listModuleLine"- summ:_ -> do- let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))- loc = mkRealSrcLoc (mkFastString (filename)) line 0- listAround (realSrcLocSpan loc) False---- | list a section of a source file around a particular SrcSpan.--- If the highlight flag is True, also highlight the span using--- start_bold\/end_bold.---- GHC files are UTF-8, so we can implement this by:--- 1) read the file in as a BS and syntax highlight it as before--- 2) convert the BS to String using utf-string, and write it out.--- It would be better if we could convert directly between UTF-8 and the--- console encoding, of course.-listAround :: MonadIO m => RealSrcSpan -> Bool -> InputT m ()-listAround pan do_highlight = do- contents <- liftIO $ BS.readFile (unpackFS file)- -- Drop carriage returns to avoid duplicates, see #9367.- let ls = BS.split '\n' $ BS.filter (/= '\r') contents- ls' = take (line2 - line1 + 1 + pad_before + pad_after) $- drop (line1 - 1 - pad_before) $ ls- fst_line = max 1 (line1 - pad_before)- line_nos = [ fst_line .. ]-- highlighted | do_highlight = zipWith highlight line_nos ls'- | otherwise = [\p -> BS.concat[p,l] | l <- ls']-- bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]- prefixed = zipWith ($) highlighted bs_line_nos- output = BS.intercalate (BS.pack "\n") prefixed-- let utf8Decoded = utf8DecodeByteString output- liftIO $ putStrLn utf8Decoded- where- file = GHC.srcSpanFile pan- line1 = GHC.srcSpanStartLine pan- col1 = GHC.srcSpanStartCol pan - 1- line2 = GHC.srcSpanEndLine pan- col2 = GHC.srcSpanEndCol pan - 1-- pad_before | line1 == 1 = 0- | otherwise = 1- pad_after = 1-- highlight | do_bold = highlight_bold- | otherwise = highlight_carets-- highlight_bold no line prefix- | no == line1 && no == line2- = let (a,r) = BS.splitAt col1 line- (b,c) = BS.splitAt (col2-col1) r- in- BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]- | no == line1- = let (a,b) = BS.splitAt col1 line in- BS.concat [prefix, a, BS.pack start_bold, b]- | no == line2- = let (a,b) = BS.splitAt col2 line in- BS.concat [prefix, a, BS.pack end_bold, b]- | otherwise = BS.concat [prefix, line]-- highlight_carets no line prefix- | no == line1 && no == line2- = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',- BS.replicate (col2-col1) '^']- | no == line1- = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,- prefix, line]- | no == line2- = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',- BS.pack "^^"]- | otherwise = BS.concat [prefix, line]- where- indent = BS.pack (" " ++ replicate (length (show no)) ' ')- nl = BS.singleton '\n'----- ----------------------------------------------------------------------------- Tick arrays--getTickArray :: Module -> GHCi TickArray-getTickArray modl = do- st <- getGHCiState- let arrmap = tickarrays st- case lookupModuleEnv arrmap modl of- Just arr -> return arr- Nothing -> do- (_breakArray, ticks) <- getModBreak modl- let arr = mkTickArray (assocs ticks)- setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}- return arr--discardTickArrays :: GHCi ()-discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})--mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray-mkTickArray ticks- = accumArray (flip (:)) [] (1, max_line)- [ (line, (nm,pan)) | (nm,RealSrcSpan pan) <- ticks, line <- srcSpanLines pan ]- where- max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp) <- ticks ]- srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]---- don't reset the counter back to zero?-discardActiveBreakPoints :: GHCi ()-discardActiveBreakPoints = do- st <- getGHCiState- mapM_ (turnOffBreak.snd) (breaks st)- setGHCiState $ st { breaks = [] }--deleteBreak :: Int -> GHCi ()-deleteBreak identity = do- st <- getGHCiState- let oldLocations = breaks st- (this,rest) = partition (\loc -> fst loc == identity) oldLocations- if null this- then printForUser (text "Breakpoint" <+> ppr identity <+>- text "does not exist")- else do- mapM_ (turnOffBreak.snd) this- setGHCiState $ st { breaks = rest }--turnOffBreak :: BreakLocation -> GHCi ()-turnOffBreak loc = do- (arr, _) <- getModBreak (breakModule loc)- hsc_env <- GHC.getSession- liftIO $ enableBreakpoint hsc_env arr (breakTick loc) False--getModBreak :: Module -> GHCi (ForeignRef BreakArray, Array Int SrcSpan)-getModBreak m = do- Just mod_info <- GHC.getModuleInfo m- let modBreaks = GHC.modInfoModBreaks mod_info- let arr = GHC.modBreaks_flags modBreaks- let ticks = GHC.modBreaks_locs modBreaks- return (arr, ticks)--setBreakFlag :: Bool -> ForeignRef BreakArray -> Int -> GHCi ()-setBreakFlag toggle arr i = do- hsc_env <- GHC.getSession- liftIO $ enableBreakpoint hsc_env arr i toggle---- ------------------------------------------------------------------------------ User code exception handling---- This is the exception handler for exceptions generated by the--- user's code and exceptions coming from children sessions;--- it normally just prints out the exception. The--- handler must be recursive, in case showing the exception causes--- more exceptions to be raised.------ Bugfix: if the user closed stdout or stderr, the flushing will fail,--- raising another exception. We therefore don't put the recursive--- handler arond the flushing operation, so if stderr is closed--- GHCi will just die gracefully rather than going into an infinite loop.-handler :: SomeException -> GHCi Bool--handler exception = do- flushInterpBuffers- withSignalHandlers $- ghciHandle handler (showException exception >> return False)--showException :: SomeException -> GHCi ()-showException se =- liftIO $ case fromException se of- -- omit the location for CmdLineError:- Just (CmdLineError s) -> putException s- -- ditto:- Just other_ghc_ex -> putException (show other_ghc_ex)- Nothing ->- case fromException se of- Just UserInterrupt -> putException "Interrupted."- _ -> putException ("*** Exception: " ++ show se)- where- putException = hPutStrLn stderr----------------------------------------------------------------------------------- recursive exception handlers---- Don't forget to unblock async exceptions in the handler, or if we're--- in an exception loop (eg. let a = error a in a) the ^C exception--- may never be delivered. Thanks to Marcin for pointing out the bug.--ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a-ghciHandle h m = gmask $ \restore -> do- -- Force dflags to avoid leaking the associated HscEnv- !dflags <- getDynFlags- gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)--ghciTry :: GHCi a -> GHCi (Either SomeException a)-ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)--tryBool :: GHCi a -> GHCi Bool-tryBool m = do- r <- ghciTry m- case r of- Left _ -> return False- Right _ -> return True---- ------------------------------------------------------------------------------- Utils--lookupModule :: GHC.GhcMonad m => String -> m Module-lookupModule mName = lookupModuleName (GHC.mkModuleName mName)--lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module-lookupModuleName mName = GHC.lookupModule mName Nothing--isHomeModule :: Module -> Bool-isHomeModule m = GHC.moduleUnitId m == mainUnitId---- TODO: won't work if home dir is encoded.--- (changeDirectory may not work either in that case.)-expandPath :: MonadIO m => String -> InputT m String-expandPath = liftIO . expandPathIO--expandPathIO :: String -> IO String-expandPathIO p =- case dropWhile isSpace p of- ('~':d) -> do- tilde <- getHomeDirectory -- will fail if HOME not defined- return (tilde ++ '/':d)- other ->- return other--wantInterpretedModule :: GHC.GhcMonad m => String -> m Module-wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)--wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module-wantInterpretedModuleName modname = do- modl <- lookupModuleName modname- let str = moduleNameString modname- dflags <- getDynFlags- when (GHC.moduleUnitId modl /= thisPackage dflags) $- throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))- is_interpreted <- GHC.moduleIsInterpreted modl- when (not is_interpreted) $- throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))- return modl--wantNameFromInterpretedModule :: GHC.GhcMonad m- => (Name -> SDoc -> m ())- -> String- -> (Name -> m ())- -> m ()-wantNameFromInterpretedModule noCanDo str and_then =- handleSourceError GHC.printException $ do- names <- GHC.parseName str- case names of- [] -> return ()- (n:_) -> do- let modl = ASSERT( isExternalName n ) GHC.nameModule n- if not (GHC.isExternalName n)- then noCanDo n $ ppr n <>- text " is not defined in an interpreted module"- else do- is_interpreted <- GHC.moduleIsInterpreted modl- if not is_interpreted- then noCanDo n $ text "module " <> ppr modl <>- text " is not interpreted"- else and_then n
− src-bin/Clash/GHCi/UI/Info.hs
@@ -1,366 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | Get information on modules, expreesions, and identifiers-module Clash.GHCi.UI.Info- ( ModInfo(..)- , SpanInfo(..)- , spanInfoFromRealSrcSpan- , collectInfo- , findLoc- , findNameUses- , findType- , getModInfo- ) where--import Control.Exception-import Control.Monad-import Control.Monad.Trans.Class-import Control.Monad.Trans.Except-import Control.Monad.Trans.Maybe-import Data.Data-import Data.Function-import Data.List-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as M-import Data.Maybe-import Data.Time-import Prelude hiding (mod)-import System.Directory--import qualified CoreUtils-import Desugar-import DynFlags (HasDynFlags(..))-import FastString-import GHC-import GhcMonad-import Name-import NameSet-import Outputable-import SrcLoc-import TcHsSyn-import Var---- | Info about a module. This information is generated every time a--- module is loaded.-data ModInfo = ModInfo- { modinfoSummary :: !ModSummary- -- ^ Summary generated by GHC. Can be used to access more- -- information about the module.- , modinfoSpans :: [SpanInfo]- -- ^ Generated set of information about all spans in the- -- module that correspond to some kind of identifier for- -- which there will be type info and/or location info.- , modinfoInfo :: !ModuleInfo- -- ^ Again, useful from GHC for accessing information- -- (exports, instances, scope) from a module.- , modinfoLastUpdate :: !UTCTime- }---- | Type of some span of source code. Most of these fields are--- unboxed but Haddock doesn't show that.-data SpanInfo = SpanInfo- { spaninfoSrcSpan :: {-# UNPACK #-} !RealSrcSpan- -- ^ The span we associate information with- , spaninfoType :: !(Maybe Type)- -- ^ The 'Type' associated with the span- , spaninfoVar :: !(Maybe Id)- -- ^ The actual 'Var' associated with the span, if- -- any. This can be useful for accessing a variety of- -- information about the identifier such as module,- -- locality, definition location, etc.- }---- | Test whether second span is contained in (or equal to) first span.--- This is basically 'containsSpan' for 'SpanInfo'-containsSpanInfo :: SpanInfo -> SpanInfo -> Bool-containsSpanInfo = containsSpan `on` spaninfoSrcSpan---- | Filter all 'SpanInfo' which are contained in 'SpanInfo'-spaninfosWithin :: [SpanInfo] -> SpanInfo -> [SpanInfo]-spaninfosWithin spans' si = filter (si `containsSpanInfo`) spans'---- | Construct a 'SpanInfo' from a 'RealSrcSpan' and optionally a--- 'Type' and an 'Id' (for 'spaninfoType' and 'spaninfoVar'--- respectively)-spanInfoFromRealSrcSpan :: RealSrcSpan -> Maybe Type -> Maybe Id -> SpanInfo-spanInfoFromRealSrcSpan spn mty mvar =- SpanInfo spn mty mvar---- | Convenience wrapper around 'spanInfoFromRealSrcSpan' which needs--- only a 'RealSrcSpan'-spanInfoFromRealSrcSpan' :: RealSrcSpan -> SpanInfo-spanInfoFromRealSrcSpan' s = spanInfoFromRealSrcSpan s Nothing Nothing---- | Convenience wrapper around 'srcSpanFile' which results in a 'FilePath'-srcSpanFilePath :: RealSrcSpan -> FilePath-srcSpanFilePath = unpackFS . srcSpanFile---- | Try to find the location of the given identifier at the given--- position in the module.-findLoc :: GhcMonad m- => Map ModuleName ModInfo- -> RealSrcSpan- -> String- -> ExceptT SDoc m (ModInfo,Name,SrcSpan)-findLoc infos span0 string = do- name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $- guessModule infos (srcSpanFilePath span0)-- info <- maybeToExceptT "No module info for current file! Try loading it?" $- MaybeT $ pure $ M.lookup name infos-- name' <- findName infos span0 info string-- case getSrcSpan name' of- UnhelpfulSpan{} -> do- throwE ("Found a name, but no location information." <+>- "The module is:" <+>- maybe "<unknown>" (ppr . moduleName)- (nameModule_maybe name'))-- span' -> return (info,name',span')---- | Find any uses of the given identifier in the codebase.-findNameUses :: (GhcMonad m)- => Map ModuleName ModInfo- -> RealSrcSpan- -> String- -> ExceptT SDoc m [SrcSpan]-findNameUses infos span0 string =- locToSpans <$> findLoc infos span0 string- where- locToSpans (modinfo,name',span') =- stripSurrounding (span' : map toSrcSpan spans)- where- toSrcSpan = RealSrcSpan . spaninfoSrcSpan- spans = filter ((== Just name') . fmap getName . spaninfoVar)- (modinfoSpans modinfo)---- | Filter out redundant spans which surround/contain other spans.-stripSurrounding :: [SrcSpan] -> [SrcSpan]-stripSurrounding xs = filter (not . isRedundant) xs- where- isRedundant x = any (x `strictlyContains`) xs-- (RealSrcSpan s1) `strictlyContains` (RealSrcSpan s2)- = s1 /= s2 && s1 `containsSpan` s2- _ `strictlyContains` _ = False---- | Try to resolve the name located at the given position, or--- otherwise resolve based on the current module's scope.-findName :: GhcMonad m- => Map ModuleName ModInfo- -> RealSrcSpan- -> ModInfo- -> String- -> ExceptT SDoc m Name-findName infos span0 mi string =- case resolveName (modinfoSpans mi) (spanInfoFromRealSrcSpan' span0) of- Nothing -> tryExternalModuleResolution- Just name ->- case getSrcSpan name of- UnhelpfulSpan {} -> tryExternalModuleResolution- RealSrcSpan {} -> return (getName name)- where- tryExternalModuleResolution =- case find (matchName $ mkFastString string)- (fromMaybe [] (modInfoTopLevelScope (modinfoInfo mi))) of- Nothing -> throwE "Couldn't resolve to any modules."- Just imported -> resolveNameFromModule infos imported-- matchName :: FastString -> Name -> Bool- matchName str name =- str ==- occNameFS (getOccName name)---- | Try to resolve the name from another (loaded) module's exports.-resolveNameFromModule :: GhcMonad m- => Map ModuleName ModInfo- -> Name- -> ExceptT SDoc m Name-resolveNameFromModule infos name = do- modL <- maybe (throwE $ "No module for" <+> ppr name) return $- nameModule_maybe name-- info <- maybe (throwE (ppr (moduleUnitId modL) <> ":" <>- ppr modL)) return $- M.lookup (moduleName modL) infos-- maybe (throwE "No matching export in any local modules.") return $- find (matchName name) (modInfoExports (modinfoInfo info))- where- matchName :: Name -> Name -> Bool- matchName x y = occNameFS (getOccName x) ==- occNameFS (getOccName y)---- | Try to resolve the type display from the given span.-resolveName :: [SpanInfo] -> SpanInfo -> Maybe Var-resolveName spans' si = listToMaybe $ mapMaybe spaninfoVar $- reverse spans' `spaninfosWithin` si---- | Try to find the type of the given span.-findType :: GhcMonad m- => Map ModuleName ModInfo- -> RealSrcSpan- -> String- -> ExceptT SDoc m (ModInfo, Type)-findType infos span0 string = do- name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $- guessModule infos (srcSpanFilePath span0)-- info <- maybeToExceptT "No module info for current file! Try loading it?" $- MaybeT $ pure $ M.lookup name infos-- case resolveType (modinfoSpans info) (spanInfoFromRealSrcSpan' span0) of- Nothing -> (,) info <$> lift (exprType TM_Inst string)- Just ty -> return (info, ty)- where- -- | Try to resolve the type display from the given span.- resolveType :: [SpanInfo] -> SpanInfo -> Maybe Type- resolveType spans' si = listToMaybe $ mapMaybe spaninfoType $- reverse spans' `spaninfosWithin` si---- | Guess a module name from a file path.-guessModule :: GhcMonad m- => Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName-guessModule infos fp = do- target <- lift $ guessTarget fp Nothing- case targetId target of- TargetModule mn -> return mn- TargetFile fp' _ -> guessModule' fp'- where- guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName- guessModule' fp' = case findModByFp fp' of- Just mn -> return mn- Nothing -> do- fp'' <- liftIO (makeRelativeToCurrentDirectory fp')-- target' <- lift $ guessTarget fp'' Nothing- case targetId target' of- TargetModule mn -> return mn- _ -> MaybeT . pure $ findModByFp fp''-- findModByFp :: FilePath -> Maybe ModuleName- findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos)- where- mifp :: (ModuleName, ModInfo) -> Maybe FilePath- mifp = ml_hs_file . ms_location . modinfoSummary . snd----- | Collect type info data for the loaded modules.-collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]- -> m (Map ModuleName ModInfo)-collectInfo ms loaded = do- df <- getDynFlags- liftIO (filterM cacheInvalid loaded) >>= \case- [] -> return ms- invalidated -> do- liftIO (putStrLn ("Collecting type info for " ++- show (length invalidated) ++- " module(s) ... "))-- foldM (go df) ms invalidated- where- go df m name = do { info <- getModInfo name; return (M.insert name info m) }- `gcatch`- (\(e :: SomeException) -> do- liftIO $ putStrLn- $ showSDocForUser df alwaysQualify- $ "Error while getting type info from" <+>- ppr name <> ":" <+> text (show e)- return m)-- cacheInvalid name = case M.lookup name ms of- Nothing -> return True- Just mi -> do- let fp = ml_obj_file (ms_location (modinfoSummary mi))- last' = modinfoLastUpdate mi- exists <- doesFileExist fp- if exists- then (> last') <$> getModificationTime fp- else return True---- | Get info about the module: summary, types, etc.-getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo-getModInfo name = do- m <- getModSummary name- p <- parseModule m- typechecked <- typecheckModule p- allTypes <- processAllTypeCheckedModule typechecked- let i = tm_checked_module_info typechecked- now <- liftIO getCurrentTime- return (ModInfo m allTypes i now)---- | Get ALL source spans in the module.-processAllTypeCheckedModule :: forall m . GhcMonad m => TypecheckedModule- -> m [SpanInfo]-processAllTypeCheckedModule tcm = do- bts <- mapM getTypeLHsBind $ listifyAllSpans tcs- ets <- mapM getTypeLHsExpr $ listifyAllSpans tcs- pts <- mapM getTypeLPat $ listifyAllSpans tcs- return $ mapMaybe toSpanInfo- $ sortBy cmpSpan- $ catMaybes (bts ++ ets ++ pts)- where- tcs = tm_typechecked_source tcm-- -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's- getTypeLHsBind :: LHsBind Id -> m (Maybe (Maybe Id,SrcSpan,Type))- getTypeLHsBind (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _typ _})- = pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid))- getTypeLHsBind _ = pure Nothing-- -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's- getTypeLHsExpr :: LHsExpr Id -> m (Maybe (Maybe Id,SrcSpan,Type))- getTypeLHsExpr e = do- hs_env <- getSession- (_,mbe) <- liftIO $ deSugarExpr hs_env e- return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe- where- mid :: Maybe Id- mid | HsVar (L _ i) <- unwrapVar (unLoc e) = Just i- | otherwise = Nothing-- unwrapVar (HsWrap _ var) = var- unwrapVar e' = e'-- -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's- getTypeLPat :: LPat Id -> m (Maybe (Maybe Id,SrcSpan,Type))- getTypeLPat (L spn pat) =- pure (Just (getMaybeId pat,spn,hsPatType pat))- where- getMaybeId (VarPat (L _ vid)) = Just vid- getMaybeId _ = Nothing-- -- | Get ALL source spans in the source.- listifyAllSpans :: Typeable a => TypecheckedSource -> [Located a]- listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x]))- where- p (L spn _) = isGoodSrcSpan spn-- -- | Variant of @syb@'s @everything@ (which summarises all nodes- -- in top-down, left-to-right order) with a stop-condition on 'NameSet's- everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r- everythingAllSpans k z f x- | (False `mkQ` (const True :: NameSet -> Bool)) x = z- | otherwise = foldl k (f x) (gmapQ (everythingAllSpans k z f) x)-- cmpSpan (_,a,_) (_,b,_)- | a `isSubspanOf` b = LT- | b `isSubspanOf` a = GT- | otherwise = EQ-- -- | Pretty print the types into a 'SpanInfo'.- toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo- toSpanInfo (n,RealSrcSpan spn,typ)- = Just $ spanInfoFromRealSrcSpan spn (Just typ) n- toSpanInfo _ = Nothing---- helper stolen from @syb@ package-type GenericQ r = forall a. Data a => a -> r--mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r-(r `mkQ` br) a = maybe r br (cast a)
− src-bin/Clash/GHCi/UI/Monad.hs
@@ -1,454 +0,0 @@-{-# LANGUAGE CPP, FlexibleInstances, UnboxedTuples, MagicHash #-}-{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}--- -fno-cse is needed for GLOBAL_VAR's to behave properly------------------------------------------------------------------------------------- Monadery code used in InteractiveUI------ (c) The GHC Team 2005-2006-----------------------------------------------------------------------------------module Clash.GHCi.UI.Monad (- GHCi(..), startGHCi,- GHCiState(..), setGHCiState, getGHCiState, modifyGHCiState,- GHCiOption(..), isOptionSet, setOption, unsetOption,- Command(..),- PromptFunction,- BreakLocation(..),- TickArray,- getDynFlags,-- runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs,-- printForUserNeverQualify, printForUserModInfo,- printForUser, printForUserPartWay, prettyLocations,- initInterpBuffering,- turnOffBuffering, turnOffBuffering_,- flushInterpBuffers,- mkEvalWrapper- ) where--#include "../HsVersions.h"--import Clash.GHCi.UI.Info (ModInfo)-import qualified GHC-import GhcMonad hiding (liftIO)-import Outputable hiding (printForUser, printForUserPartWay)-import qualified Outputable-import DynFlags-import FastString-import HscTypes-import SrcLoc-import Module-import GHCi-import GHCi.RemoteTypes-import HsSyn (ImportDecl)-import RdrName (RdrName)--import Exception-import Numeric-import Data.Array-import Data.IORef-import Data.Time-import System.Environment-import System.IO-import Control.Monad--import System.Console.Haskeline (CompletionFunc, InputT)-import qualified System.Console.Haskeline as Haskeline-import Control.Monad.Trans.Class-import Control.Monad.IO.Class-import Data.Map.Strict (Map)---------------------------------------------------------------------------------- GHCi monad--data GHCiState = GHCiState- {- progname :: String,- args :: [String],- evalWrapper :: ForeignHValue, -- ^ of type @IO a -> IO a@- prompt :: PromptFunction,- prompt_cont :: PromptFunction,- editor :: String,- stop :: String,- options :: [GHCiOption],- line_number :: !Int, -- ^ input line- break_ctr :: !Int,- breaks :: ![(Int, BreakLocation)],- tickarrays :: ModuleEnv TickArray,- -- ^ 'tickarrays' caches the 'TickArray' for loaded modules,- -- so that we don't rebuild it each time the user sets- -- a breakpoint.- ghci_commands :: [Command],- -- ^ available ghci commands- ghci_macros :: [Command],- -- ^ user-defined macros- last_command :: Maybe Command,- -- ^ @:@ at the GHCi prompt repeats the last command, so we- -- remember it here- cmdqueue :: [String],-- remembered_ctx :: [InteractiveImport],- -- ^ The imports that the user has asked for, via import- -- declarations and :module commands. This list is- -- persistent over :reloads (but any imports for modules- -- that are not loaded are temporarily ignored). After a- -- :load, all the home-package imports are stripped from- -- this list.- --- -- See bugs #2049, #1873, #1360-- transient_ctx :: [InteractiveImport],- -- ^ An import added automatically after a :load, usually of- -- the most recently compiled module. May be empty if- -- there are no modules loaded. This list is replaced by- -- :load, :reload, and :add. In between it may be modified- -- by :module.-- extra_imports :: [ImportDecl RdrName],- -- ^ These are "always-on" imports, added to the- -- context regardless of what other imports we have.- -- This is useful for adding imports that are required- -- by setGHCiMonad. Be careful adding things here:- -- you can create ambiguities if these imports overlap- -- with other things in scope.- --- -- NB. although this is not currently used by GHCi itself,- -- it was added to support other front-ends that are based- -- on the GHCi code. Potentially we could also expose- -- this functionality via GHCi commands.-- prelude_imports :: [ImportDecl RdrName],- -- ^ These imports are added to the context when- -- -XImplicitPrelude is on and we don't have a *-module- -- in the context. They can also be overridden by another- -- import for the same module, e.g.- -- "import Prelude hiding (map)"-- ghc_e :: Bool, -- ^ True if this is 'ghc -e' (or runghc)-- short_help :: String,- -- ^ help text to display to a user- long_help :: String,- lastErrorLocations :: IORef [(FastString, Int)],-- mod_infos :: !(Map ModuleName ModInfo),-- flushStdHandles :: ForeignHValue,- -- ^ @hFlush stdout; hFlush stderr@ in the interpreter- noBuffering :: ForeignHValue- -- ^ @hSetBuffering NoBuffering@ for stdin/stdout/stderr- }--type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]---- | A GHCi command-data Command- = Command- { cmdName :: String- -- ^ Name of GHCi command (e.g. "exit")- , cmdAction :: String -> InputT GHCi Bool- -- ^ The 'Bool' value denotes whether to exit GHCi- , cmdHidden :: Bool- -- ^ Commands which are excluded from default completion- -- and @:help@ summary. This is usually set for commands not- -- useful for interactive use but rather for IDEs.- , cmdCompletionFunc :: CompletionFunc GHCi- -- ^ 'CompletionFunc' for arguments- }--type PromptFunction = [String]- -> Int- -> GHCi SDoc--data GHCiOption- = ShowTiming -- show time/allocs after evaluation- | ShowType -- show the type of expressions- | RevertCAFs -- revert CAFs after every evaluation- | Multiline -- use multiline commands- | CollectInfo -- collect and cache information about- -- modules after load- deriving Eq--data BreakLocation- = BreakLocation- { breakModule :: !GHC.Module- , breakLoc :: !SrcSpan- , breakTick :: {-# UNPACK #-} !Int- , onBreakCmd :: String- }--instance Eq BreakLocation where- loc1 == loc2 = breakModule loc1 == breakModule loc2 &&- breakTick loc1 == breakTick loc2--prettyLocations :: [(Int, BreakLocation)] -> SDoc-prettyLocations [] = text "No active breakpoints."-prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs--instance Outputable BreakLocation where- ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>- if null (onBreakCmd loc)- then Outputable.empty- else doubleQuotes (text (onBreakCmd loc))--recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)-recordBreak brkLoc = do- st <- getGHCiState- let oldActiveBreaks = breaks st- -- don't store the same break point twice- case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of- (nm:_) -> return (True, nm)- [] -> do- let oldCounter = break_ctr st- newCounter = oldCounter + 1- setGHCiState $ st { break_ctr = newCounter,- breaks = (oldCounter, brkLoc) : oldActiveBreaks- }- return (False, oldCounter)--newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }--reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a-reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s--reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a-reifyGHCi f = GHCi f'- where- -- f' :: IORef GHCiState -> Ghc a- f' gs = reifyGhc (f'' gs)- -- f'' :: IORef GHCiState -> Session -> IO a- f'' gs s = f (s, gs)--startGHCi :: GHCi a -> GHCiState -> Ghc a-startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref--instance Functor GHCi where- fmap = liftM--instance Applicative GHCi where- pure a = GHCi $ \_ -> pure a- (<*>) = ap--instance Monad GHCi where- (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s--class HasGhciState m where- getGHCiState :: m GHCiState- setGHCiState :: GHCiState -> m ()- modifyGHCiState :: (GHCiState -> GHCiState) -> m ()--instance HasGhciState GHCi where- getGHCiState = GHCi $ \r -> liftIO $ readIORef r- setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s- modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f--instance (MonadTrans t, Monad m, HasGhciState m) => HasGhciState (t m) where- getGHCiState = lift getGHCiState- setGHCiState = lift . setGHCiState- modifyGHCiState = lift . modifyGHCiState--liftGhc :: Ghc a -> GHCi a-liftGhc m = GHCi $ \_ -> m--instance MonadIO GHCi where- liftIO = liftGhc . liftIO--instance HasDynFlags GHCi where- getDynFlags = getSessionDynFlags--instance GhcMonad GHCi where- setSession s' = liftGhc $ setSession s'- getSession = liftGhc $ getSession--instance HasDynFlags (InputT GHCi) where- getDynFlags = lift getDynFlags--instance GhcMonad (InputT GHCi) where- setSession = lift . setSession- getSession = lift getSession--instance ExceptionMonad GHCi where- gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)- gmask f =- GHCi $ \s -> gmask $ \io_restore ->- let- g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')- in- unGHCi (f g_restore) s--instance Haskeline.MonadException Ghc where- controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let- run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)- in fmap (flip unGhc s) $ f run'--instance Haskeline.MonadException GHCi where- controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let- run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)- in fmap (flip unGHCi s) $ f run'--instance ExceptionMonad (InputT GHCi) where- gcatch = Haskeline.catch- gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)--isOptionSet :: GHCiOption -> GHCi Bool-isOptionSet opt- = do st <- getGHCiState- return (opt `elem` options st)--setOption :: GHCiOption -> GHCi ()-setOption opt- = do st <- getGHCiState- setGHCiState (st{ options = opt : filter (/= opt) (options st) })--unsetOption :: GHCiOption -> GHCi ()-unsetOption opt- = do st <- getGHCiState- setGHCiState (st{ options = filter (/= opt) (options st) })--printForUserNeverQualify :: GhcMonad m => SDoc -> m ()-printForUserNeverQualify doc = do- dflags <- getDynFlags- liftIO $ Outputable.printForUser dflags stdout neverQualify doc--printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()-printForUserModInfo info doc = do- dflags <- getDynFlags- mUnqual <- GHC.mkPrintUnqualifiedForModule info- unqual <- maybe GHC.getPrintUnqual return mUnqual- liftIO $ Outputable.printForUser dflags stdout unqual doc--printForUser :: GhcMonad m => SDoc -> m ()-printForUser doc = do- unqual <- GHC.getPrintUnqual- dflags <- getDynFlags- liftIO $ Outputable.printForUser dflags stdout unqual doc--printForUserPartWay :: SDoc -> GHCi ()-printForUserPartWay doc = do- unqual <- GHC.getPrintUnqual- dflags <- getDynFlags- liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc---- | Run a single Haskell expression-runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult)-runStmt expr step = do- st <- getGHCiState- GHC.handleSourceError (\e -> do GHC.printException e; return Nothing) $ do- let opts = GHC.execOptions- { GHC.execSourceFile = progname st- , GHC.execLineNumber = line_number st- , GHC.execSingleStep = step- , GHC.execWrap = \fhv -> EvalApp (EvalThis (evalWrapper st))- (EvalThis fhv) }- Just <$> GHC.execStmt expr opts--runDecls :: String -> GHCi (Maybe [GHC.Name])-runDecls decls = do- st <- getGHCiState- reifyGHCi $ \x ->- withProgName (progname st) $- withArgs (args st) $- reflectGHCi x $ do- GHC.handleSourceError (\e -> do GHC.printException e;- return Nothing) $ do- r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls- return (Just r)--resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.ExecResult-resume canLogSpan step = do- st <- getGHCiState- reifyGHCi $ \x ->- withProgName (progname st) $- withArgs (args st) $- reflectGHCi x $ do- GHC.resumeExec canLogSpan step---- ----------------------------------------------------------------------------- timing & statistics--timeIt :: (a -> Maybe Integer) -> InputT GHCi a -> InputT GHCi a-timeIt getAllocs action- = do b <- lift $ isOptionSet ShowTiming- if not b- then action- else do time1 <- liftIO $ getCurrentTime- a <- action- let allocs = getAllocs a- time2 <- liftIO $ getCurrentTime- dflags <- getDynFlags- let period = time2 `diffUTCTime` time1- liftIO $ printTimes dflags allocs (realToFrac period)- return a--printTimes :: DynFlags -> Maybe Integer -> Double -> IO ()-printTimes dflags mallocs secs- = do let secs_str = showFFloat (Just 2) secs- putStrLn (showSDoc dflags (- parens (text (secs_str "") <+> text "secs" <> comma <+>- case mallocs of- Nothing -> empty- Just allocs ->- text (separateThousands allocs) <+> text "bytes")))- where- separateThousands n = reverse . sep . reverse . show $ n- where sep n'- | length n' <= 3 = n'- | otherwise = take 3 n' ++ "," ++ sep (drop 3 n')---------------------------------------------------------------------------------- reverting CAFs--revertCAFs :: GHCi ()-revertCAFs = do- liftIO rts_revertCAFs- s <- getGHCiState- when (not (ghc_e s)) turnOffBuffering- -- Have to turn off buffering again, because we just- -- reverted stdout, stderr & stdin to their defaults.--foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()- -- Make it "safe", just in case---------------------------------------------------------------------------------- To flush buffers for the *interpreted* computation we need--- to refer to *its* stdout/stderr handles---- | Compile "hFlush stdout; hFlush stderr" once, so we can use it repeatedly-initInterpBuffering :: Ghc (ForeignHValue, ForeignHValue)-initInterpBuffering = do- nobuf <- GHC.compileExprRemote $- "do { System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering; " ++- " System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering; " ++- " System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering }"- flush <- GHC.compileExprRemote $- "do { System.IO.hFlush System.IO.stdout; " ++- " System.IO.hFlush System.IO.stderr }"- return (nobuf, flush)---- | Invoke "hFlush stdout; hFlush stderr" in the interpreter-flushInterpBuffers :: GHCi ()-flushInterpBuffers = do- st <- getGHCiState- hsc_env <- GHC.getSession- liftIO $ evalIO hsc_env (flushStdHandles st)---- | Turn off buffering for stdin, stdout, and stderr in the interpreter-turnOffBuffering :: GHCi ()-turnOffBuffering = do- st <- getGHCiState- turnOffBuffering_ (noBuffering st)--turnOffBuffering_ :: GhcMonad m => ForeignHValue -> m ()-turnOffBuffering_ fhv = do- hsc_env <- getSession- liftIO $ evalIO hsc_env fhv--mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue-mkEvalWrapper progname args =- GHC.compileExprRemote $- "\\m -> System.Environment.withProgName " ++ show progname ++- "(System.Environment.withArgs " ++ show args ++ " m)"
− src-bin/Clash/GHCi/UI/Tags.hs
@@ -1,215 +0,0 @@------------------------------------------------------------------------------------ GHCi's :ctags and :etags commands------ (c) The GHC Team 2005-2007-----------------------------------------------------------------------------------{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-module Clash.GHCi.UI.Tags (- createCTagsWithLineNumbersCmd,- createCTagsWithRegExesCmd,- createETagsFileCmd-) where--import Exception-import GHC-import Clash.GHCi.UI.Monad-import Outputable---- ToDo: figure out whether we need these, and put something appropriate--- into the GHC API instead-import Name (nameOccName)-import OccName (pprOccName)-import ConLike-import MonadUtils--import Data.Function-import Data.Maybe-import Data.Ord-import DriverPhases-import Panic-import Data.List-import Control.Monad-import System.Directory-import System.IO-import System.IO.Error---------------------------------------------------------------------------------- create tags file for currently loaded modules.--createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd,- createETagsFileCmd :: String -> GHCi ()--createCTagsWithLineNumbersCmd "" =- ghciCreateTagsFile CTagsWithLineNumbers "tags"-createCTagsWithLineNumbersCmd file =- ghciCreateTagsFile CTagsWithLineNumbers file--createCTagsWithRegExesCmd "" =- ghciCreateTagsFile CTagsWithRegExes "tags"-createCTagsWithRegExesCmd file =- ghciCreateTagsFile CTagsWithRegExes file--createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"-createETagsFileCmd file = ghciCreateTagsFile ETags file--data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes--ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()-ghciCreateTagsFile kind file = do- createTagsFile kind file---- ToDo:--- - remove restriction that all modules must be interpreted--- (problem: we don't know source locations for entities unless--- we compiled the module.------ - extract createTagsFile so it can be used from the command-line--- (probably need to fix first problem before this is useful).----createTagsFile :: TagsKind -> FilePath -> GHCi ()-createTagsFile tagskind tagsFile = do- graph <- GHC.getModuleGraph- mtags <- mapM listModuleTags (map GHC.ms_mod graph)- either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags- case either_res of- Left e -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e- Right _ -> return ()---listModuleTags :: GHC.Module -> GHCi [TagInfo]-listModuleTags m = do- is_interpreted <- GHC.moduleIsInterpreted m- -- should we just skip these?- when (not is_interpreted) $- let mName = GHC.moduleNameString (GHC.moduleName m) in- throwGhcException (CmdLineError ("module '" ++ mName ++ "' is not interpreted"))- mbModInfo <- GHC.getModuleInfo m- case mbModInfo of- Nothing -> return []- Just mInfo -> do- dflags <- getDynFlags- mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo- let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual- let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo- let localNames = filter ((m==) . nameModule) names- mbTyThings <- mapM GHC.lookupName localNames- return $! [ tagInfo dflags unqual exported kind name realLoc- | tyThing <- catMaybes mbTyThings- , let name = getName tyThing- , let exported = GHC.modInfoIsExportedName mInfo name- , let kind = tyThing2TagKind tyThing- , let loc = srcSpanStart (nameSrcSpan name)- , RealSrcLoc realLoc <- [loc]- ]-- where- tyThing2TagKind (AnId _) = 'v'- tyThing2TagKind (AConLike RealDataCon{}) = 'd'- tyThing2TagKind (AConLike PatSynCon{}) = 'p'- tyThing2TagKind (ATyCon _) = 't'- tyThing2TagKind (ACoAxiom _) = 'x'---data TagInfo = TagInfo- { tagExported :: Bool -- is tag exported- , tagKind :: Char -- tag kind- , tagName :: String -- tag name- , tagFile :: String -- file name- , tagLine :: Int -- line number- , tagCol :: Int -- column number- , tagSrcInfo :: Maybe (String,Integer) -- source code line and char offset- }----- get tag info, for later translation into Vim or Emacs style-tagInfo :: DynFlags -> PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc- -> TagInfo-tagInfo dflags unqual exported kind name loc- = TagInfo exported kind- (showSDocForUser dflags unqual $ pprOccName (nameOccName name))- (showSDocForUser dflags unqual $ ftext (srcLocFile loc))- (srcLocLine loc) (srcLocCol loc) Nothing---- throw an exception when someone tries to overwrite existing source file (fix for #10989)-writeTagsSafely :: FilePath -> String -> IO ()-writeTagsSafely file str = do- dfe <- doesFileExist file- if dfe && isSourceFilename file- then throwGhcException (CmdLineError (file ++ " is existing source file. " ++- "Please specify another file name to store tags data"))- else writeFile file str--collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())--- ctags style with the Ex exresion being just the line number, Vim et al-collateAndWriteTags CTagsWithLineNumbers file tagInfos = do- let tags = unlines $ sort $ map showCTag tagInfos- tryIO (writeTagsSafely file tags)---- ctags style with the Ex exresion being a regex searching the line, Vim et al-collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al- tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos- let tags = unlines $ sort $ map showCTag $concat tagInfoGroups- tryIO (writeTagsSafely file tags)--collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs- tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos- let tagGroups = map processGroup tagInfoGroups- tryIO (writeTagsSafely file $ concat tagGroups)-- where- processGroup [] = throwGhcException (CmdLineError "empty tag file group??")- processGroup group@(tagInfo:_) =- let tags = unlines $ map showETag group in- "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags---makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]]-makeTagGroupsWithSrcInfo tagInfos = do- let groups = groupBy ((==) `on` tagFile) $ sortBy (comparing tagFile) tagInfos- mapM addTagSrcInfo groups-- where- addTagSrcInfo [] = throwGhcException (CmdLineError "empty tag file group??")- addTagSrcInfo group@(tagInfo:_) = do- file <- readFile $tagFile tagInfo- let sortedGroup = sortBy (comparing tagLine) group- return $ perFile sortedGroup 1 0 $ lines file-- perFile allTags@(tag:tags) cnt pos allLs@(l:ls)- | tagLine tag > cnt =- perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls- | tagLine tag == cnt =- tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs- perFile _ _ _ _ = []----- ctags format, for Vim et al-showCTag :: TagInfo -> String-showCTag ti =- tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" ++- tagKind ti : ( if tagExported ti then "" else "\tfile:" )-- where- tagCmd =- case tagSrcInfo ti of- Nothing -> show $tagLine ti- Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/"-- where- escapeSlashes '/' r = '\\' : '/' : r- escapeSlashes '\\' r = '\\' : '\\' : r- escapeSlashes c r = c : r----- etags format, for Emacs/XEmacs-showETag :: TagInfo -> String-showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo,- tagSrcInfo = Just (srcLine,charPos) }- = take (colNo - 1) srcLine ++ tag- ++ "\x7f" ++ tag- ++ "\x01" ++ show lineNo- ++ "," ++ show charPos-showETag _ = throwGhcException (CmdLineError "missing source file info in showETag")
− src-bin/Clash/Main.hs
@@ -1,1088 +0,0 @@-{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables, TupleSections #-}-{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}------------------------------------------------------------------------------------- GHC Driver program------ (c) The University of Glasgow 2005-----------------------------------------------------------------------------------module Clash.Main (defaultMain) where---- For Int/Word size-#include "MachDeps.h"---- The official GHC API-import qualified GHC-import GHC ( -- DynFlags(..), HscTarget(..),- -- GhcMode(..), GhcLink(..),- Ghc, GhcMonad(..),- LoadHowMuch(..) )-import CmdLineParser---- Implementations of the various modes (--show-iface, mkdependHS. etc.)-import LoadIface ( showIface )-import HscMain ( newHscEnv )-import DriverPipeline ( oneShot, compileFile )-import DriverMkDepend ( doMkDependHS )-import DriverBkp ( doBackpack )-#if defined(GHCI)-import Clash.GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )-#endif---- Frontend plugins-#if defined(GHCI)-import DynamicLoading ( loadFrontendPlugin )-import Plugins-#else-import DynamicLoading ( pluginError )-#endif-import Module ( ModuleName )----- Various other random stuff that we need-import Config-import Constants-import HscTypes-import Packages ( pprPackages, pprPackagesSimple )-import DriverPhases-import BasicTypes ( failed )-import DynFlags-import ErrUtils-import FastString-import Outputable-import SrcLoc-import Util-import Panic-import UniqSupply-import MonadUtils ( liftIO )---- Imports for --abi-hash-import LoadIface ( loadUserInterface )-import Module ( mkModuleName )-import Finder ( findImportedModule, cannotFindModule )-import TcRnMonad ( initIfaceCheck )-import Binary ( openBinMem, put_ )-import BinFingerprint ( fingerprintBinMem )---- Standard Haskell libraries-import System.IO-import System.Environment-import System.Exit-import System.FilePath-import Control.Monad-import Data.Char-import Data.List-import Data.Maybe---- clash additions-import Paths_clash_ghc-import Clash.GHCi.UI (makeHDL)-import Exception (gcatch)-import Data.IORef (IORef, newIORef, readIORef)-import qualified Data.Version (showVersion)-import Control.Exception (Exception(..),ErrorCall (..))--import qualified GHC.LanguageExtensions as LangExt-import GHC.Exception ( SomeException )--import qualified Clash.Backend-import Clash.Backend.SystemVerilog (SystemVerilogState)-import Clash.Backend.VHDL (VHDLState)-import Clash.Backend.Verilog (VerilogState)-import Clash.Driver.Types- (ClashOpts (..), ClashException (..), DebugLevel (..))-import Clash.GHC.ClashFlags-import Clash.Netlist.BlackBox.Types (HdlSyn (..))-import Clash.Util (clashLibVersion)-import Clash.GHC.LoadModules (ghcLibDir)---------------------------------------------------------------------------------- ToDo:---- time commands when run with -v--- user ways--- Win32 support: proper signal handling--- reading the package configuration file is too slow--- -K<size>---------------------------------------------------------------------------------- GHC's command-line interface--defaultMain :: [String] -> IO ()-defaultMain = flip withArgs $ do- initGCStatistics -- See Note [-Bsymbolic and hooks]- hSetBuffering stdout LineBuffering- hSetBuffering stderr LineBuffering-- -- Handle GHC-specific character encoding flags, allowing us to control how- -- GHC produces output regardless of OS.- env <- getEnvironment- case lookup "GHC_CHARENC" env of- Just "UTF-8" -> do- hSetEncoding stdout utf8- hSetEncoding stderr utf8- _ -> do- -- Avoid GHC erroring out when trying to display unhandled characters- hSetTranslit stdout- hSetTranslit stderr-- GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do- argv0 <- getArgs- libDir <- ghcLibDir-- let argv1 = map (mkGeneralLocated "on the commandline") argv0- r <- newIORef (ClashOpts { opt_dbgLevel = DebugNone- , opt_inlineLimit = 20- , opt_specLimit = 20- , opt_inlineFunctionLimit = 15- , opt_inlineConstantLimit = 0- , opt_cachehdl = True- , opt_cleanhdl = True- , opt_intWidth = WORD_SIZE_IN_BITS- , opt_hdlDir = Nothing- , opt_hdlSyn = Other- , opt_errorExtra = False- , opt_floatSupport = False- , opt_allowZero = False- , opt_importPaths = []- })- (argv2, clashFlagWarnings) <- parseClashFlags r argv1-- -- 2. Parse the "mode" flags (--make, --interactive etc.)- (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2- let flagWarnings = modeFlagWarnings ++ clashFlagWarnings-- -- If all we want to do is something like showing the version number- -- then do it now, before we start a GHC session etc. This makes- -- getting basic information much more resilient.-- -- In particular, if we wait until later before giving the version- -- number then bootstrapping gets confused, as it tries to find out- -- what version of GHC it's using before package.conf exists, so- -- starting the session fails.- case mode of- Left preStartupMode ->- do case preStartupMode of- ShowSupportedExtensions -> showSupportedExtensions- ShowVersion -> showVersion- ShowNumVersion -> putStrLn cProjectVersion- ShowOptions isInteractive -> showOptions isInteractive- Right postStartupMode ->- -- start our GHC session- GHC.runGhc (Just libDir) $ do-- dflags <- GHC.getSessionDynFlags- let dflagsExtra = foldl DynFlags.xopt_set- dflags- [ LangExt.TemplateHaskell- , LangExt.TemplateHaskellQuotes- , LangExt.DataKinds- , LangExt.MonoLocalBinds- , LangExt.TypeOperators- , LangExt.FlexibleContexts- , LangExt.ConstraintKinds- , LangExt.TypeFamilies- , LangExt.BinaryLiterals- , LangExt.ExplicitNamespaces- , LangExt.KindSignatures- , LangExt.DeriveLift- , LangExt.TypeApplications- , LangExt.ScopedTypeVariables- , LangExt.MagicHash- , LangExt.ExplicitForAll- ]- dflagsExtra1 = foldl DynFlags.xopt_unset dflagsExtra- [ LangExt.ImplicitPrelude- , LangExt.MonomorphismRestriction- ]-- ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise"- ghcTyLitExtrPlugin = GHC.mkModuleName "GHC.TypeLits.Extra.Solver"- ghcTyLitKNPlugin = GHC.mkModuleName "GHC.TypeLits.KnownNat.Solver"- dflagsExtra2 = dflagsExtra1- { DynFlags.pluginModNames = nub $- ghcTyLitNormPlugin : ghcTyLitExtrPlugin :- ghcTyLitKNPlugin :- DynFlags.pluginModNames dflagsExtra1- }-- case postStartupMode of- Left preLoadMode ->- liftIO $ do- case preLoadMode of- ShowInfo -> showInfo dflagsExtra2- ShowGhcUsage -> showGhcUsage dflagsExtra2- ShowGhciUsage -> showGhciUsage dflagsExtra2- PrintWithDynFlags f -> putStrLn (f dflagsExtra2)- Right postLoadMode ->- main' postLoadMode dflagsExtra2 argv3 flagWarnings r--main' :: PostLoadMode -> DynFlags -> [Located String] -> [Located String]- -> IORef ClashOpts- -> Ghc ()-main' postLoadMode dflags0 args flagWarnings clashOpts = do- -- set the default GhcMode, HscTarget and GhcLink. The HscTarget- -- can be further adjusted on a module by module basis, using only- -- the -fvia-C and -fasm flags. If the default HscTarget is not- -- HscC or HscAsm, -fvia-C and -fasm have no effect.- let dflt_target = hscTarget dflags0- (mode, lang, link)- = case postLoadMode of- DoInteractive -> (CompManager, HscInterpreted, LinkInMemory)- DoEval _ -> (CompManager, HscInterpreted, LinkInMemory)- DoMake -> (CompManager, dflt_target, LinkBinary)- DoBackpack -> (CompManager, dflt_target, LinkBinary)- DoMkDependHS -> (MkDepend, dflt_target, LinkBinary)- DoAbiHash -> (OneShot, dflt_target, LinkBinary)- DoVHDL -> (CompManager, dflt_target, LinkInMemory)- DoVerilog -> (CompManager, dflt_target, LinkInMemory)- DoSystemVerilog -> (CompManager, dflt_target, LinkInMemory)- _ -> (OneShot, dflt_target, LinkBinary)-- let dflags1 = dflags0{ ghcMode = mode,- hscTarget = lang,- ghcLink = link,- verbosity = case postLoadMode of- DoEval _ -> 0- _other -> 1- }-- -- turn on -fimplicit-import-qualified for GHCi now, so that it- -- can be overriden from the command-line- -- XXX: this should really be in the interactive DynFlags, but- -- we don't set that until later in interactiveUI- dflags2 | DoInteractive <- postLoadMode = imp_qual_enabled- | DoEval _ <- postLoadMode = imp_qual_enabled- | otherwise = dflags1- where imp_qual_enabled = dflags1 `gopt_set` Opt_ImplicitImportQualified-- -- The rest of the arguments are "dynamic"- -- Leftover ones are presumably files- (dflags3, fileish_args, dynamicFlagWarnings) <-- GHC.parseDynamicFlags dflags2 args-- let dflags4 = case lang of- HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) ->- let platform = targetPlatform dflags3- dflags3a = updateWays $ dflags3 { ways = interpWays }- dflags3b = foldl gopt_set dflags3a- $ concatMap (wayGeneralFlags platform)- interpWays- dflags3c = foldl gopt_unset dflags3b- $ concatMap (wayUnsetGeneralFlags platform)- interpWays- in dflags3c- _ ->- dflags3-- GHC.prettyPrintGhcErrors dflags4 $ do-- let flagWarnings' = flagWarnings ++ dynamicFlagWarnings-- handleSourceError (\e -> do- GHC.printException e- liftIO $ exitWith (ExitFailure 1)) $ do- liftIO $ handleFlagWarnings dflags4 flagWarnings'-- liftIO $ showBanner postLoadMode dflags4-- let- -- To simplify the handling of filepaths, we normalise all filepaths right- -- away - e.g., for win32 platforms, backslashes are converted- -- into forward slashes.- normal_fileish_paths = map (normalise . unLoc) fileish_args- (srcs, objs) = partition_args normal_fileish_paths [] []-- dflags5 = dflags4 { ldInputs = map (FileOption "") objs- ++ ldInputs dflags4 }-- -- we've finished manipulating the DynFlags, update the session- _ <- GHC.setSessionDynFlags dflags5- dflags6 <- GHC.getSessionDynFlags- hsc_env <- GHC.getSession-- ---------------- Display configuration ------------ case verbosity dflags6 of- v | v == 4 -> liftIO $ dumpPackagesSimple dflags6- | v >= 5 -> liftIO $ dumpPackages dflags6- | otherwise -> return ()-- liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6)- ---------------- Final sanity checking ------------ liftIO $ checkOptions postLoadMode dflags6 srcs objs-- ---------------- Do the business ------------ handleSourceError (\e -> do- GHC.printException e- liftIO $ exitWith (ExitFailure 1)) $ do- clashOpts' <- liftIO (readIORef clashOpts)- let clash fun = gcatch (fun clashOpts srcs) (handleClashException dflags6 clashOpts')- case postLoadMode of- ShowInterface f -> liftIO $ doShowIface dflags6 f- DoMake -> doMake srcs- DoMkDependHS -> doMkDependHS (map fst srcs)- StopBefore p -> liftIO (oneShot hsc_env p srcs)- DoInteractive -> ghciUI clashOpts srcs Nothing- DoEval exprs -> ghciUI clashOpts srcs $ Just $ reverse exprs- DoAbiHash -> abiHash (map fst srcs)- ShowPackages -> liftIO $ showPackages dflags6- DoFrontend f -> doFrontend f srcs- DoVHDL -> clash makeVHDL- DoVerilog -> clash makeVerilog- DoSystemVerilog -> clash makeSystemVerilog- DoBackpack -> doBackpack (map fst srcs)-- liftIO $ dumpFinalStats dflags6--handleClashException- :: GhcMonad m- => DynFlags- -> ClashOpts- -> SomeException- -> m a-handleClashException df opts e = case fromException e of- Just (ClashException sp s eM) ->- throwOneError (mkPlainErrMsg df sp (text s $$ blankLine $$ srcInfo $$ showExtra (opt_errorExtra opts) eM))- _ -> case fromException e of- Just (ErrorCall msg) ->- throwOneError (mkPlainErrMsg df noSrcSpan (text "Clash error call:" $$ text msg))- _ -> case fromException e of- Just (e' :: SourceError) -> do- GHC.printException e'- liftIO $ exitWith (ExitFailure 1)- _ -> throwOneError (mkPlainErrMsg df noSrcSpan (text "Other error:" $$ text (displayException e)))- where- srcInfo = text "NB: The source location of the error is not exact, only indicative, as it is acquired after optimisations." $$- text "The actual location of the error can be in a function that is inlined." $$- text "To prevent inlining of those functions, annotate them with a NOINLINE pragma."-- showExtra False (Just _) =- blankLine $$- text "This error contains additional information, rerun with '-fclash-error-extra' to show this information."- showExtra True (Just msg) =- blankLine $$- text "Additional information:" $$ blankLine $$- text msg- showExtra _ _ = empty--ghciUI :: IORef ClashOpts -> [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()-#if !defined(GHCI)-ghciUI _ _ _ = throwGhcException (CmdLineError "not built for interactive use")-#else-ghciUI opts = interactiveUI (defaultGhciSettings opts)-#endif---- -------------------------------------------------------------------------------- Splitting arguments into source files and object files. This is where we--- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source--- file indicating the phase specified by the -x option in force, if any.--partition_args :: [String] -> [(String, Maybe Phase)] -> [String]- -> ([(String, Maybe Phase)], [String])-partition_args [] srcs objs = (reverse srcs, reverse objs)-partition_args ("-x":suff:args) srcs objs- | "none" <- suff = partition_args args srcs objs- | StopLn <- phase = partition_args args srcs (slurp ++ objs)- | otherwise = partition_args rest (these_srcs ++ srcs) objs- where phase = startPhase suff- (slurp,rest) = break (== "-x") args- these_srcs = zip slurp (repeat (Just phase))-partition_args (arg:args) srcs objs- | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs- | otherwise = partition_args args srcs (arg:objs)-- {-- We split out the object files (.o, .dll) and add them- to ldInputs for use by the linker.-- The following things should be considered compilation manager inputs:-- - haskell source files (strings ending in .hs, .lhs or other- haskellish extension),-- - module names (not forgetting hierarchical module names),-- - things beginning with '-' are flags that were not recognised by- the flag parser, and we want them to generate errors later in- checkOptions, so we class them as source files (#5921)-- - and finally we consider everything without an extension to be- a comp manager input, as shorthand for a .hs or .lhs filename.-- Everything else is considered to be a linker object, and passed- straight through to the linker.- -}-looks_like_an_input :: String -> Bool-looks_like_an_input m = isSourceFilename m- || looksLikeModuleName m- || "-" `isPrefixOf` m- || not (hasExtension m)---- -------------------------------------------------------------------------------- Option sanity checks---- | Ensure sanity of options.------ Throws 'UsageError' or 'CmdLineError' if not.-checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()- -- Final sanity checking before kicking off a compilation (pipeline).-checkOptions mode dflags srcs objs = do- -- Complain about any unknown flags- let unknown_opts = [ f | (f@('-':_), _) <- srcs ]- when (notNull unknown_opts) (unknownFlagsErr unknown_opts)-- when (notNull (filter wayRTSOnly (ways dflags))- && isInterpretiveMode mode) $- hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")-- -- -prof and --interactive are not a good combination- when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays)- && isInterpretiveMode mode- && not (gopt Opt_ExternalInterpreter dflags)) $- do throwGhcException (UsageError- "-fexternal-interpreter is required when using --interactive with a non-standard way (-prof, -static, or -dynamic).")- -- -ohi sanity check- if (isJust (outputHi dflags) &&- (isCompManagerMode mode || srcs `lengthExceeds` 1))- then throwGhcException (UsageError "-ohi can only be used when compiling a single source file")- else do-- -- -o sanity checking- if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)- && not (isLinkMode mode))- then throwGhcException (UsageError "can't apply -o to multiple source files")- else do-- let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)-- when (not_linking && not (null objs)) $- hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)-- -- Check that there are some input files- -- (except in the interactive case)- if null srcs && (null objs || not_linking) && needsInputsMode mode- then throwGhcException (UsageError "no input files")- else do-- case mode of- StopBefore HCc | hscTarget dflags /= HscC- -> throwGhcException $ UsageError $- "the option -C is only available with an unregisterised GHC"- _ -> return ()-- -- Verify that output files point somewhere sensible.- verifyOutputFiles dflags---- Compiler output options---- Called to verify that the output files point somewhere valid.------ The assumption is that the directory portion of these output--- options will have to exist by the time 'verifyOutputFiles'--- is invoked.------ We create the directories for -odir, -hidir, -outputdir etc. ourselves if--- they don't exist, so don't check for those here (#2278).-verifyOutputFiles :: DynFlags -> IO ()-verifyOutputFiles dflags = do- let ofile = outputFile dflags- when (isJust ofile) $ do- let fn = fromJust ofile- flg <- doesDirNameExist fn- when (not flg) (nonExistentDir "-o" fn)- let ohi = outputHi dflags- when (isJust ohi) $ do- let hi = fromJust ohi- flg <- doesDirNameExist hi- when (not flg) (nonExistentDir "-ohi" hi)- where- nonExistentDir flg dir =- throwGhcException (CmdLineError ("error: directory portion of " ++- show dir ++ " does not exist (used with " ++- show flg ++ " option.)"))---------------------------------------------------------------------------------- GHC modes of operation--type Mode = Either PreStartupMode PostStartupMode-type PostStartupMode = Either PreLoadMode PostLoadMode--data PreStartupMode- = ShowVersion -- ghc -V/--version- | ShowNumVersion -- ghc --numeric-version- | ShowSupportedExtensions -- ghc --supported-extensions- | ShowOptions Bool {- isInteractive -} -- ghc --show-options--showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode-showVersionMode = mkPreStartupMode ShowVersion-showNumVersionMode = mkPreStartupMode ShowNumVersion-showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions-showOptionsMode = mkPreStartupMode (ShowOptions False)--mkPreStartupMode :: PreStartupMode -> Mode-mkPreStartupMode = Left--isShowVersionMode :: Mode -> Bool-isShowVersionMode (Left ShowVersion) = True-isShowVersionMode _ = False--isShowNumVersionMode :: Mode -> Bool-isShowNumVersionMode (Left ShowNumVersion) = True-isShowNumVersionMode _ = False--data PreLoadMode- = ShowGhcUsage -- ghc -?- | ShowGhciUsage -- ghci -?- | ShowInfo -- ghc --info- | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo--showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode-showGhcUsageMode = mkPreLoadMode ShowGhcUsage-showGhciUsageMode = mkPreLoadMode ShowGhciUsage-showInfoMode = mkPreLoadMode ShowInfo--printSetting :: String -> Mode-printSetting k = mkPreLoadMode (PrintWithDynFlags f)- where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))- $ lookup k (compilerInfo dflags)--mkPreLoadMode :: PreLoadMode -> Mode-mkPreLoadMode = Right . Left--isShowGhcUsageMode :: Mode -> Bool-isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True-isShowGhcUsageMode _ = False--isShowGhciUsageMode :: Mode -> Bool-isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True-isShowGhciUsageMode _ = False--data PostLoadMode- = ShowInterface FilePath -- ghc --show-iface- | DoMkDependHS -- ghc -M- | StopBefore Phase -- ghc -E | -C | -S- -- StopBefore StopLn is the default- | DoMake -- ghc --make- | DoBackpack -- ghc --backpack foo.bkp- | DoInteractive -- ghc --interactive- | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]- | DoAbiHash -- ghc --abi-hash- | ShowPackages -- ghc --show-packages- | DoFrontend ModuleName -- ghc --frontend Plugin.Module- | DoVHDL -- ghc --vhdl- | DoVerilog -- ghc --verilog- | DoSystemVerilog -- ghc --systemverilog--doMkDependHSMode, doMakeMode, doInteractiveMode,- doAbiHashMode, showPackagesMode, doVHDLMode, doVerilogMode,- doSystemVerilogMode :: Mode-doMkDependHSMode = mkPostLoadMode DoMkDependHS-doMakeMode = mkPostLoadMode DoMake-doInteractiveMode = mkPostLoadMode DoInteractive-doAbiHashMode = mkPostLoadMode DoAbiHash-showPackagesMode = mkPostLoadMode ShowPackages-doVHDLMode = mkPostLoadMode DoVHDL-doVerilogMode = mkPostLoadMode DoVerilog-doSystemVerilogMode = mkPostLoadMode DoSystemVerilog--showInterfaceMode :: FilePath -> Mode-showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)--stopBeforeMode :: Phase -> Mode-stopBeforeMode phase = mkPostLoadMode (StopBefore phase)--doEvalMode :: String -> Mode-doEvalMode str = mkPostLoadMode (DoEval [str])--doFrontendMode :: String -> Mode-doFrontendMode str = mkPostLoadMode (DoFrontend (mkModuleName str))--doBackpackMode :: Mode-doBackpackMode = mkPostLoadMode DoBackpack--mkPostLoadMode :: PostLoadMode -> Mode-mkPostLoadMode = Right . Right--isDoInteractiveMode :: Mode -> Bool-isDoInteractiveMode (Right (Right DoInteractive)) = True-isDoInteractiveMode _ = False--isStopLnMode :: Mode -> Bool-isStopLnMode (Right (Right (StopBefore StopLn))) = True-isStopLnMode _ = False--isDoMakeMode :: Mode -> Bool-isDoMakeMode (Right (Right DoMake)) = True-isDoMakeMode _ = False--isDoEvalMode :: Mode -> Bool-isDoEvalMode (Right (Right (DoEval _))) = True-isDoEvalMode _ = False--#if defined(GHCI)-isInteractiveMode :: PostLoadMode -> Bool-isInteractiveMode DoInteractive = True-isInteractiveMode _ = False-#endif---- isInterpretiveMode: byte-code compiler involved-isInterpretiveMode :: PostLoadMode -> Bool-isInterpretiveMode DoInteractive = True-isInterpretiveMode (DoEval _) = True-isInterpretiveMode _ = False--needsInputsMode :: PostLoadMode -> Bool-needsInputsMode DoMkDependHS = True-needsInputsMode (StopBefore _) = True-needsInputsMode DoMake = True-needsInputsMode DoVHDL = True-needsInputsMode DoVerilog = True-needsInputsMode DoSystemVerilog = True-needsInputsMode _ = False---- True if we are going to attempt to link in this mode.--- (we might not actually link, depending on the GhcLink flag)-isLinkMode :: PostLoadMode -> Bool-isLinkMode (StopBefore StopLn) = True-isLinkMode DoMake = True-isLinkMode DoInteractive = True-isLinkMode (DoEval _) = True-isLinkMode DoVHDL = True-isLinkMode DoVerilog = True-isLinkMode DoSystemVerilog = True-isLinkMode _ = False--isCompManagerMode :: PostLoadMode -> Bool-isCompManagerMode DoMake = True-isCompManagerMode DoInteractive = True-isCompManagerMode (DoEval _) = True-isCompManagerMode DoVHDL = True-isCompManagerMode DoVerilog = True-isCompManagerMode DoSystemVerilog = True-isCompManagerMode _ = False---- -------------------------------------------------------------------------------- Parsing the mode flag--parseModeFlags :: [Located String]- -> IO (Mode,- [Located String],- [Located String])-parseModeFlags args = do- let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =- runCmdLine (processArgs mode_flags args)- (Nothing, [], [])- mode = case mModeFlag of- Nothing -> doMakeMode- Just (m, _) -> m-- -- See Note [Handling errors when parsing commandline flags]- unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $- map (("on the commandline", )) $ map unLoc errs1 ++ errs2-- return (mode, flags' ++ leftover, warns)--type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])- -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)- -- so we collect the new ones and return them.--mode_flags :: [Flag ModeM]-mode_flags =- [ ------- help / version ----------------------------------------------- defFlag "?" (PassFlag (setMode showGhcUsageMode))- , defFlag "-help" (PassFlag (setMode showGhcUsageMode))- , defFlag "V" (PassFlag (setMode showVersionMode))- , defFlag "-version" (PassFlag (setMode showVersionMode))- , defFlag "-numeric-version" (PassFlag (setMode showNumVersionMode))- , defFlag "-info" (PassFlag (setMode showInfoMode))- , defFlag "-show-options" (PassFlag (setMode showOptionsMode))- , defFlag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))- , defFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))- , defFlag "-show-packages" (PassFlag (setMode showPackagesMode))- ] ++- [ defFlag k' (PassFlag (setMode (printSetting k)))- | k <- ["Project version",- "Project Git commit id",- "Booter version",- "Stage",- "Build platform",- "Host platform",- "Target platform",- "Have interpreter",- "Object splitting supported",- "Have native code generator",- "Support SMP",- "Unregisterised",- "Tables next to code",- "RTS ways",- "Leading underscore",- "Debug on",- "LibDir",- "Global Package DB",- "C compiler flags",- "C compiler link flags",- "ld flags"],- let k' = "-print-" ++ map (replaceSpace . toLower) k- replaceSpace ' ' = '-'- replaceSpace c = c- ] ++- ------- interfaces ----------------------------------------------------- [ defFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)- "--show-iface"))-- ------- primary modes ------------------------------------------------- , defFlag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f- addFlag "-no-link" f))- , defFlag "M" (PassFlag (setMode doMkDependHSMode))- , defFlag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))- , defFlag "C" (PassFlag (setMode (stopBeforeMode HCc)))- , defFlag "S" (PassFlag (setMode (stopBeforeMode (As False))))- , defFlag "-make" (PassFlag (setMode doMakeMode))- , defFlag "-backpack" (PassFlag (setMode doBackpackMode))- , defFlag "-interactive" (PassFlag (setMode doInteractiveMode))- , defFlag "-abi-hash" (PassFlag (setMode doAbiHashMode))- , defFlag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))- , defFlag "-frontend" (SepArg (\s -> setMode (doFrontendMode s) "-frontend"))- , defFlag "-vhdl" (PassFlag (setMode doVHDLMode))- , defFlag "-verilog" (PassFlag (setMode doVerilogMode))- , defFlag "-systemverilog" (PassFlag (setMode doSystemVerilogMode))- ]--setMode :: Mode -> String -> EwM ModeM ()-setMode newMode newFlag = liftEwM $ do- (mModeFlag, errs, flags') <- getCmdLineState- let (modeFlag', errs') =- case mModeFlag of- Nothing -> ((newMode, newFlag), errs)- Just (oldMode, oldFlag) ->- case (oldMode, newMode) of- -- -c/--make are allowed together, and mean --make -no-link- _ | isStopLnMode oldMode && isDoMakeMode newMode- || isStopLnMode newMode && isDoMakeMode oldMode ->- ((doMakeMode, "--make"), [])-- -- If we have both --help and --interactive then we- -- want showGhciUsage- _ | isShowGhcUsageMode oldMode &&- isDoInteractiveMode newMode ->- ((showGhciUsageMode, oldFlag), [])- | isShowGhcUsageMode newMode &&- isDoInteractiveMode oldMode ->- ((showGhciUsageMode, newFlag), [])-- -- If we have both -e and --interactive then -e always wins- _ | isDoEvalMode oldMode &&- isDoInteractiveMode newMode ->- ((oldMode, oldFlag), [])- | isDoEvalMode newMode &&- isDoInteractiveMode oldMode ->- ((newMode, newFlag), [])-- -- Otherwise, --help/--version/--numeric-version always win- | isDominantFlag oldMode -> ((oldMode, oldFlag), [])- | isDominantFlag newMode -> ((newMode, newFlag), [])- -- We need to accumulate eval flags like "-e foo -e bar"- (Right (Right (DoEval esOld)),- Right (Right (DoEval [eNew]))) ->- ((Right (Right (DoEval (eNew : esOld))), oldFlag),- errs)- -- Saying e.g. --interactive --interactive is OK- _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)-- -- --interactive and --show-options are used together- (Right (Right DoInteractive), Left (ShowOptions _)) ->- ((Left (ShowOptions True),- "--interactive --show-options"), errs)- (Left (ShowOptions _), (Right (Right DoInteractive))) ->- ((Left (ShowOptions True),- "--show-options --interactive"), errs)- -- Otherwise, complain- _ -> let err = flagMismatchErr oldFlag newFlag- in ((oldMode, oldFlag), err : errs)- putCmdLineState (Just modeFlag', errs', flags')- where isDominantFlag f = isShowGhcUsageMode f ||- isShowGhciUsageMode f ||- isShowVersionMode f ||- isShowNumVersionMode f--flagMismatchErr :: String -> String -> String-flagMismatchErr oldFlag newFlag- = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'"--addFlag :: String -> String -> EwM ModeM ()-addFlag s flag = liftEwM $ do- (m, e, flags') <- getCmdLineState- putCmdLineState (m, e, mkGeneralLocated loc s : flags')- where loc = "addFlag by " ++ flag ++ " on the commandline"---- ------------------------------------------------------------------------------- Run --make mode--doMake :: [(String,Maybe Phase)] -> Ghc ()-doMake srcs = do- let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs-- hsc_env <- GHC.getSession-- -- if we have no haskell sources from which to do a dependency- -- analysis, then just do one-shot compilation and/or linking.- -- This means that "ghc Foo.o Bar.o -o baz" links the program as- -- we expect.- if (null hs_srcs)- then liftIO (oneShot hsc_env StopLn srcs)- else do-- o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)- non_hs_srcs- dflags <- GHC.getSessionDynFlags- let dflags' = dflags { ldInputs = map (FileOption "") o_files- ++ ldInputs dflags }- _ <- GHC.setSessionDynFlags dflags'-- targets <- mapM (uncurry GHC.guessTarget) hs_srcs- GHC.setTargets targets- ok_flag <- GHC.load LoadAllTargets-- when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))- return ()----- ------------------------------------------------------------------------------ --show-iface mode--doShowIface :: DynFlags -> FilePath -> IO ()-doShowIface dflags file = do- hsc_env <- newHscEnv dflags- showIface hsc_env file---- ------------------------------------------------------------------------------ Various banners and verbosity output.--showBanner :: PostLoadMode -> DynFlags -> IO ()-showBanner _postLoadMode dflags = do- let verb = verbosity dflags--#if defined(GHCI)- -- Show the GHCi banner- when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg-#endif-- -- Display details of the configuration in verbose mode- when (verb >= 2) $- do hPutStr stderr "Glasgow Haskell Compiler, Version "- hPutStr stderr cProjectVersion- hPutStr stderr ", stage "- hPutStr stderr cStage- hPutStr stderr " booted by GHC version "- hPutStrLn stderr cBooterVersion---- We print out a Read-friendly string, but a prettier one than the--- Show instance gives us-showInfo :: DynFlags -> IO ()-showInfo dflags = do- let sq x = " [" ++ x ++ "\n ]"- putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags--showSupportedExtensions :: IO ()-showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions--showVersion :: IO ()-showVersion = putStrLn $ concat [ "CLaSH, version "- , Data.Version.showVersion Paths_clash_ghc.version- , " (using clash-lib, version: "- , Data.Version.showVersion clashLibVersion- , ")"- ]--showOptions :: Bool -> IO ()-showOptions isInteractive = putStr (unlines availableOptions)- where- availableOptions = concat [- flagsForCompletion isInteractive,- map ('-':) (getFlagNames mode_flags)- ]- getFlagNames opts = map flagName opts--showGhcUsage :: DynFlags -> IO ()-showGhcUsage = showUsage False--showGhciUsage :: DynFlags -> IO ()-showGhciUsage = showUsage True--showUsage :: Bool -> DynFlags -> IO ()-showUsage ghci dflags = do- let usage_path = if ghci then ghciUsagePath dflags- else ghcUsagePath dflags- usage <- readFile usage_path- dump usage- where- dump "" = return ()- dump ('$':'$':s) = putStr progName >> dump s- dump (c:s) = putChar c >> dump s--dumpFinalStats :: DynFlags -> IO ()-dumpFinalStats dflags =- when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags--dumpFastStringStats :: DynFlags -> IO ()-dumpFastStringStats dflags = do- buckets <- getFastStringTable- let (entries, longest, has_z) = countFS 0 0 0 buckets- msg = text "FastString stats:" $$- nest 4 (vcat [text "size: " <+> int (length buckets),- text "entries: " <+> int entries,- text "longest chain: " <+> int longest,- text "has z-encoding: " <+> (has_z `pcntOf` entries)- ])- -- we usually get more "has z-encoding" than "z-encoded", because- -- when we z-encode a string it might hash to the exact same string,- -- which will is not counted as "z-encoded". Only strings whose- -- Z-encoding is different from the original string are counted in- -- the "z-encoded" total.- putMsg dflags msg- where- x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'--countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int)-countFS entries longest has_z [] = (entries, longest, has_z)-countFS entries longest has_z (b:bs) =- let- len = length b- longest' = max len longest- entries' = entries + len- has_zs = length (filter hasZEncoding b)- in- countFS entries' longest' (has_z + has_zs) bs--showPackages, dumpPackages, dumpPackagesSimple :: DynFlags -> IO ()-showPackages dflags = putStrLn (showSDoc dflags (pprPackages dflags))-dumpPackages dflags = putMsg dflags (pprPackages dflags)-dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple dflags)---- -------------------------------------------------------------------------------- Frontend plugin support--doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()-#if !defined(GHCI)-doFrontend modname _ = pluginError [modname]-#else-doFrontend modname srcs = do- hsc_env <- getSession- frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname- frontend frontend_plugin- (reverse $ frontendPluginOpts (hsc_dflags hsc_env)) srcs-#endif---- -------------------------------------------------------------------------------- ABI hash support--{-- ghc --abi-hash Data.Foo System.Bar--Generates a combined hash of the ABI for modules Data.Foo and-System.Bar. The modules must already be compiled, and appropriate -i-options may be necessary in order to find the .hi files.--This is used by Cabal for generating the ComponentId for a-package. The ComponentId must change when the visible ABI of-the package chagnes, so during registration Cabal calls ghc --abi-hash-to get a hash of the package's ABI.--}---- | Print ABI hash of input modules.------ The resulting hash is the MD5 of the GHC version used (Trac #5328,--- see 'hiVersion') and of the existing ABI hash from each module (see--- 'mi_mod_hash').-abiHash :: [String] -- ^ List of module names- -> Ghc ()-abiHash strs = do- hsc_env <- getSession- let dflags = hsc_dflags hsc_env-- liftIO $ do-- let find_it str = do- let modname = mkModuleName str- r <- findImportedModule hsc_env modname Nothing- case r of- Found _ m -> return m- _error -> throwGhcException $ CmdLineError $ showSDoc dflags $- cannotFindModule dflags modname r-- mods <- mapM find_it strs-- let get_iface modl = loadUserInterface False (text "abiHash") modl- ifaces <- initIfaceCheck (text "abiHash") hsc_env $ mapM get_iface mods-- bh <- openBinMem (3*1024) -- just less than a block- put_ bh hiVersion- -- package hashes change when the compiler version changes (for now)- -- see #5328- mapM_ (put_ bh . mi_mod_hash) ifaces- f <- fingerprintBinMem bh-- putStrLn (showPpr dflags f)---------------------------------------------------------------------------------- VHDL Generation--makeHDL' :: Clash.Backend.Backend backend => (Int -> HdlSyn -> backend) -> IORef ClashOpts -> [(String,Maybe Phase)] -> Ghc ()-makeHDL' _ _ [] = throwGhcException (CmdLineError "No input files")-makeHDL' backend r srcs = makeHDL backend r $ fmap fst srcs--makeVHDL :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> VHDLState)--makeVerilog :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> VerilogState)--makeSystemVerilog :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> SystemVerilogState)---- -------------------------------------------------------------------------------- Util--unknownFlagsErr :: [String] -> a-unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs- where- oneError f =- "unrecognised flag: " ++ f ++ "\n" ++- (case match f (nubSort allNonDeprecatedFlags) of- [] -> ""- suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs))- -- fixes #11789- -- If the flag contains '=',- -- this uses both the whole and the left side of '=' for comparing.- match f allFlags- | elem '=' f =- let (flagsWithEq, flagsWithoutEq) = partition (elem '=') allFlags- fName = takeWhile (/= '=') f- in (fuzzyMatch f flagsWithEq) ++ (fuzzyMatch fName flagsWithoutEq)- | otherwise = fuzzyMatch f allFlags--{- Note [-Bsymbolic and hooks]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Bsymbolic is a flag that prevents the binding of references to global-symbols to symbols outside the shared library being compiled (see `man-ld`). When dynamically linking, we don't use -Bsymbolic on the RTS-package: that is because we want hooks to be overridden by the user,-we don't want to constrain them to the RTS package.--Unfortunately this seems to have broken somehow on OS X: as a result,-defaultHooks (in hschooks.c) is not called, which does not initialize-the GC stats. As a result, this breaks things like `:set +s` in GHCi-(#8754). As a hacky workaround, we instead call 'defaultHooks'-directly to initalize the flags in the RTS.--A byproduct of this, I believe, is that hooks are likely broken on OS-X when dynamically linking. But this probably doesn't affect most-people since we're linking GHC dynamically, but most things themselves-link statically.--}--foreign import ccall safe "initGCStatistics"- initGCStatistics :: IO ()
src-ghc/Clash/GHC/ClashFlags.hs view
@@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} module Clash.GHC.ClashFlags@@ -55,21 +56,46 @@ flagsClash :: IORef ClashOpts -> [Flag IO] flagsClash r = [- defFlag "fclash-debug" $ SepArg (setDebugLevel r)- , defFlag "fclash-hdldir" $ SepArg (setHdlDir r)- , defFlag "fclash-hdlsyn" $ SepArg (setHdlSyn r)- , defFlag "fclash-nocache" $ NoArg (liftEwM (setNoCache r))- , defFlag "fclash-noclean" $ NoArg (liftEwM (setNoClean r))- , defFlag "fclash-spec-limit" $ IntSuffix (liftEwM . setSpecLimit r)- , defFlag "fclash-inline-limit" $ IntSuffix (liftEwM . setInlineLimit r)- , defFlag "fclash-inline-function-limit" $ IntSuffix (liftEwM . setInlineFunctionLimit r)- , defFlag "fclash-inline-constant-limit" $ IntSuffix (liftEwM . setInlineConstantLimit r)- , defFlag "fclash-intwidth" $ IntSuffix (setIntWidth r)- , defFlag "fclash-error-extra" $ NoArg (liftEwM (setErrorExtra r))- , defFlag "fclash-float-support" $ NoArg (liftEwM (setFloatSupport r))- , defFlag "fclash-allow-zero-width" $ NoArg (setAllowZeroWidth r)+ defFlag "fclash-debug" $ SepArg (setDebugLevel r)+ , defFlag "fclash-hdldir" $ SepArg (setHdlDir r)+ , defFlag "fclash-hdlsyn" $ SepArg (setHdlSyn r)+ , defFlag "fclash-nocache" $ NoArg (deprecated "nocache" "no-cache" setNoCache r)+ , defFlag "fclash-no-cache" $ NoArg (liftEwM (setNoCache r))+ , defFlag "fclash-no-check-inaccessible-idirs" $ NoArg (liftEwM (setNoIDirCheck r))+ , defFlag "fclash-noclean" $ NoArg (deprecated "noclean" "no-clean" setNoClean r)+ , defFlag "fclash-no-clean" $ NoArg (liftEwM (setNoClean r))+ , defFlag "fclash-no-prim-warn" $ NoArg (liftEwM (setNoPrimWarn r))+ , defFlag "fclash-spec-limit" $ IntSuffix (liftEwM . setSpecLimit r)+ , defFlag "fclash-inline-limit" $ IntSuffix (liftEwM . setInlineLimit r)+ , defFlag "fclash-inline-function-limit" $ IntSuffix (liftEwM . setInlineFunctionLimit r)+ , defFlag "fclash-inline-constant-limit" $ IntSuffix (liftEwM . setInlineConstantLimit r)+ , defFlag "fclash-intwidth" $ IntSuffix (setIntWidth r)+ , defFlag "fclash-error-extra" $ NoArg (liftEwM (setErrorExtra r))+ , defFlag "fclash-float-support" $ NoArg (liftEwM (setFloatSupport r))+ , defFlag "fclash-allow-zero-width" $ NoArg (setAllowZeroWidth r)+ , defFlag "fclash-component-prefix" $ SepArg (liftEwM . setComponentPrefix r)+ , defFlag "fclash-old-inline-strategy" $ NoArg (liftEwM (setOldInlineStrategy r))+ , defFlag "fclash-no-escaped-identifiers" $ NoArg (liftEwM (setNoEscapedIds r))+ , defFlag "fclash-compile-ultra" $ NoArg (liftEwM (setUltra r))+ , defFlag "fclash-force-undefined" $ OptIntSuffix (setUndefined r) ] +-- | Print deprecated flag warning+deprecated+ :: String+ -- ^ Deprecated flag+ -> String+ -- ^ Use X instead+ -> (a -> IO ())+ -> a+ -> EwM IO ()+deprecated wrong right f a = do+ addWarn ("Using '-fclash-" ++ wrong+ ++ "' is deprecated. Use '-fclash-"+ ++ right+ ++ "' instead.")+ liftEwM (f a)+ setInlineLimit :: IORef ClashOpts -> Int -> IO ()@@ -96,15 +122,23 @@ -> String -> EwM IO () setDebugLevel r s = case readMaybe s of- Just dbgLvl -> liftEwM $ modifyIORef r (\c -> c {opt_dbgLevel = dbgLvl})+ Just dbgLvl -> liftEwM $ do+ modifyIORef r (\c -> c {opt_dbgLevel = dbgLvl})+ when (dbgLvl > DebugNone) $ setNoCache r -- when debugging disable cache Nothing -> addWarn (s ++ " is an invalid debug level") setNoCache :: IORef ClashOpts -> IO () setNoCache r = modifyIORef r (\c -> c {opt_cachehdl = False}) +setNoIDirCheck :: IORef ClashOpts -> IO ()+setNoIDirCheck r = modifyIORef r (\c -> c {opt_checkIDir = False})+ setNoClean :: IORef ClashOpts -> IO () setNoClean r = modifyIORef r (\c -> c {opt_cleanhdl = False}) +setNoPrimWarn :: IORef ClashOpts -> IO ()+setNoPrimWarn r = modifyIORef r (\c -> c {opt_primWarn = False})+ setIntWidth :: IORef ClashOpts -> Int -> EwM IO ()@@ -123,9 +157,12 @@ -> EwM IO () setHdlSyn r s = case readMaybe s of Just hdlSyn -> liftEwM $ modifyIORef r (\c -> c {opt_hdlSyn = hdlSyn})- Nothing -> if s == "Xilinx"- then liftEwM $ modifyIORef r (\c -> c {opt_hdlSyn = Vivado})- else addWarn (s ++ " is an unknown hdl synthesis tool")+ Nothing -> case s of+ "Xilinx" -> liftEwM $ modifyIORef r (\c -> c {opt_hdlSyn = Vivado})+ "ISE" -> liftEwM $ modifyIORef r (\c -> c {opt_hdlSyn = Vivado})+ "Altera" -> liftEwM $ modifyIORef r (\c -> c {opt_hdlSyn = Quartus})+ "Intel" -> liftEwM $ modifyIORef r (\c -> c {opt_hdlSyn = Quartus})+ _ -> addWarn (s ++ " is an unknown hdl synthesis tool") setErrorExtra :: IORef ClashOpts -> IO () setErrorExtra r = modifyIORef r (\c -> c {opt_errorExtra = True})@@ -134,6 +171,28 @@ setFloatSupport r = modifyIORef r (\c -> c {opt_floatSupport = True}) setAllowZeroWidth :: IORef ClashOpts -> EwM IO ()-setAllowZeroWidth r = do+setAllowZeroWidth _ = do addWarn ("-fclash-allow-zero-width is deprecated and will be removed in Clash 1.0")- liftEwM (modifyIORef r (\c -> c {opt_allowZero = True}))+ -- liftEwM (modifyIORef r (\c -> c {opt_allowZero = True}))++setComponentPrefix+ :: IORef ClashOpts+ -> String+ -> IO ()+setComponentPrefix r s = modifyIORef r (\c -> c {opt_componentPrefix = Just s})++setOldInlineStrategy :: IORef ClashOpts -> IO ()+setOldInlineStrategy r = modifyIORef r (\c -> c {opt_newInlineStrat = False})++setNoEscapedIds :: IORef ClashOpts -> IO ()+setNoEscapedIds r = modifyIORef r (\c -> c {opt_escapedIds = False})++setUltra :: IORef ClashOpts -> IO ()+setUltra r = modifyIORef r (\c -> c {opt_ultra = True})++setUndefined :: IORef ClashOpts -> Maybe Int -> EwM IO ()+setUndefined _ (Just x) | x < 0 || x > 1 =+ addWarn ("-fclash-force-undefined=" ++ show x ++ " ignored, " ++ show x +++ " not in range [0,1]")+setUndefined r iM =+ liftEwM (modifyIORef r (\c -> c {opt_forceUndefined = Just iM}))
src-ghc/Clash/GHC/Evaluator.hs view
@@ -9,3736 +9,4270 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE UnboxedTuples #-}--module Clash.GHC.Evaluator where--import Control.Concurrent.Supply (Supply,freshId)-import Control.Monad (ap)-import Control.Monad.Trans.Except (runExcept)-import Data.Bits-import Data.Char (chr,ord)-import qualified Data.Either as Either-import qualified Data.HashMap.Strict as HashMap-import qualified Data.IntMap as IntMap-import Data.Maybe- (fromMaybe, mapMaybe)-import qualified Data.List as List-import qualified Data.Primitive.ByteArray as ByteArray-import Data.Proxy (Proxy)-import Data.Reflection (reifyNat)-import Data.Text (Text)-import qualified Data.Vector.Primitive as Vector-import GHC.Float-import GHC.Int-import GHC.Integer (decodeDoubleInteger,encodeDoubleInteger)-import GHC.Integer.GMP.Internals (Integer (..), BigNat (..))-import GHC.Prim-import GHC.Real (Ratio (..))-import GHC.TypeLits (KnownNat)-import GHC.Types (IO (..))-import GHC.Word-import System.IO.Unsafe (unsafeDupablePerformIO)-import qualified Unbound.Generics.LocallyNameless.Name as U-import Unbound.Generics.LocallyNameless- (Fresh (..), bind, embed, rebind, runFreshM, makeName)--import BasicTypes (Boxity (..))-import Name (getSrcSpan, nameOccName, occNameString)-import PrelNames- (typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatSubTyFamNameKey)-import SrcLoc (wiredInSrcSpan)-import qualified TyCon-import TysWiredIn (tupleTyCon)-import Unique (getKey)--import Clash.Class.BitPack (pack,unpack)-import Clash.Core.DataCon (DataCon (..), dataConInstArgTys)-import Clash.Core.Evaluator- (Heap (..), PrimEvaluator, Value (..), valToTerm, whnf)-import Clash.Core.Literal (Literal (..))-import Clash.Core.Name- (Name (..), NameSort (..), name2String, string2SystemName)-import Clash.Core.Term (Pat (..), Term (..))-import Clash.Core.Type- (Type (..), ConstTy (..), LitTy (..), TypeView (..), applyTy, mkFunTy, mkTyConApp,- splitFunForallTy, tyView)-import Clash.Core.TyCon- (TyCon, TyConMap, TyConName, TyConOccName, tyConDataCons)-import Clash.Core.TysPrim-import Clash.Core.Util (mkApps,mkRTree,mkVec,tyNatSize)-import Clash.Core.Var (Var (..))-import Clash.GHC.GHC2Core (modNameM)-import Clash.Rewrite.Util (mkSelectorCase)-import Clash.Util- (MonadUnique (..), clogBase, flogBase, curLoc)--import Clash.Promoted.Nat.Unsafe (unsafeSNat)-import qualified Clash.Sized.Internal.BitVector as BitVector-import qualified Clash.Sized.Internal.Signed as Signed-import qualified Clash.Sized.Internal.Unsigned as Unsigned-import Clash.Sized.Internal.BitVector(BitVector(..), Bit)-import Clash.Sized.Internal.Signed (Signed (..))-import Clash.Sized.Internal.Unsigned (Unsigned (..))--newtype PrimEvalMonad a = PEM { runPEM :: Supply -> (a,Supply) }--instance Functor PrimEvalMonad where- fmap f m = PEM (\s -> case runPEM m s of (a,s') -> (f a, s'))--instance Applicative PrimEvalMonad where- pure = return- (<*>) = ap--instance Monad PrimEvalMonad where- return a = PEM (\s -> (a,s))- m >>= k = PEM (\s -> case runPEM m s of (a,s') -> runPEM (k a) s')--instance Fresh PrimEvalMonad where- fresh (U.Fn nm _) =- PEM (\s -> case freshId s of- (!i,!s') -> let !i' = toInteger i- in (U.Fn nm i',s'))- fresh nm@(U.Bn {}) = PEM (\s -> (nm,s))--instance MonadUnique PrimEvalMonad where- getUniqueM = PEM (\s -> case freshId s of (!i,!s') -> (i,s'))--reduceConstant :: PrimEvaluator-reduceConstant isSubj gbl tcm h k nm ty tys args = case nm of--------------------- GHC.Prim.Char#------------------- "GHC.Prim.gtChar#" | Just (i,j) <- charLiterals args- -> reduce (boolToIntLiteral (i > j))- "GHC.Prim.geChar#" | Just (i,j) <- charLiterals args- -> reduce (boolToIntLiteral (i >= j))- "GHC.Prim.eqChar#" | Just (i,j) <- charLiterals args- -> reduce (boolToIntLiteral (i == j))- "GHC.Prim.neChar#" | Just (i,j) <- charLiterals args- -> reduce (boolToIntLiteral (i /= j))- "GHC.Prim.ltChar#" | Just (i,j) <- charLiterals args- -> reduce (boolToIntLiteral (i < j))- "GHC.Prim.leChar#" | Just (i,j) <- charLiterals args- -> reduce (boolToIntLiteral (i <= j))- "GHC.Prim.ord#" | [i] <- charLiterals' args- -> reduce (integerToIntLiteral (toInteger $ ord i))--------------------- GHC.Prim.Int#------------------ "GHC.Prim.+#" | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i+j))- "GHC.Prim.-#" | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i-j))- "GHC.Prim.*#" | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i*j))-- "GHC.Prim.mulIntMayOflo#" | Just (i,j) <- intLiterals args- -> let !(I# a) = fromInteger i- !(I# b) = fromInteger j- c :: Int#- c = mulIntMayOflo# a b- in reduce (integerToIntLiteral (toInteger $ I# c))-- "GHC.Prim.quotInt#" | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i `quot` j))- "GHC.Prim.remInt#" | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i `rem` j))- "GHC.Prim.quotRemInt#" | Just (i,j) <- intLiterals args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- (q,r) = quotRem i j- ret = mkApps (Data tupDc) (map Right tyArgs ++- [Left (integerToIntLiteral q), Left (integerToIntLiteral r)])- in reduce ret-- "GHC.Prim.andI#" | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i .&. j))- "GHC.Prim.orI#" | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i .|. j))- "GHC.Prim.xorI#" | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i `xor` j))- "GHC.Prim.notI#" | [i] <- intLiterals' args- -> reduce (integerToIntLiteral (complement i))-- "GHC.Prim.negateInt#"- | [Lit (IntLiteral i)] <- args- -> reduce (integerToIntLiteral (negate i))-- "GHC.Prim.addIntC#" | Just (i,j) <- intLiterals args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- !(I# a) = fromInteger i- !(I# b) = fromInteger j- !(# d, c #) = addIntC# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . IntLiteral . toInteger $ I# d)- , Left (Literal . IntLiteral . toInteger $ I# c)])- "GHC.Prim.subIntC#" | Just (i,j) <- intLiterals args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- !(I# a) = fromInteger i- !(I# b) = fromInteger j- !(# d, c #) = subIntC# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . IntLiteral . toInteger $ I# d)- , Left (Literal . IntLiteral . toInteger $ I# c)])-- "GHC.Prim.>#" | Just (i,j) <- intLiterals args- -> reduce (boolToIntLiteral (i > j))- "GHC.Prim.>=#" | Just (i,j) <- intLiterals args- -> reduce (boolToIntLiteral (i >= j))- "GHC.Prim.==#" | Just (i,j) <- intLiterals args- -> reduce (boolToIntLiteral (i == j))- "GHC.Prim./=#" | Just (i,j) <- intLiterals args- -> reduce (boolToIntLiteral (i /= j))- "GHC.Prim.<#" | Just (i,j) <- intLiterals args- -> reduce (boolToIntLiteral (i < j))- "GHC.Prim.<=#" | Just (i,j) <- intLiterals args- -> reduce (boolToIntLiteral (i <= j))-- "GHC.Prim.chr#" | [i] <- intLiterals' args- -> reduce (charToCharLiteral (chr $ fromInteger i))-- "GHC.Prim.int2Word#"- | [Lit (IntLiteral i)] <- args- -> reduce . Literal . WordLiteral . toInteger $ (fromInteger :: Integer -> Word) i -- for overflow behaviour-- "GHC.Prim.int2Float#"- | [Lit (IntLiteral i)] <- args- -> reduce . Literal . FloatLiteral . toRational $ (fromInteger i :: Float)- "GHC.Prim.int2Double#"- | [Lit (IntLiteral i)] <- args- -> reduce . Literal . DoubleLiteral . toRational $ (fromInteger i :: Double)-- "GHC.Prim.word2Float#"- | [Lit (WordLiteral i)] <- args- -> reduce . Literal . FloatLiteral . toRational $ (fromInteger i :: Float)- "GHC.Prim.word2Double#"- | [Lit (WordLiteral i)] <- args- -> reduce . Literal . DoubleLiteral . toRational $ (fromInteger i :: Double)-- "GHC.Prim.uncheckedIShiftL#"- | [ Lit (IntLiteral i)- , Lit (IntLiteral s)- ] <- args- -> reduce (integerToIntLiteral (i `shiftL` fromInteger s))- "GHC.Prim.uncheckedIShiftRA#"- | [ Lit (IntLiteral i)- , Lit (IntLiteral s)- ] <- args- -> reduce (integerToIntLiteral (i `shiftR` fromInteger s))- "GHC.Prim.uncheckedIShiftRL#" | Just (i,j) <- intLiterals args- -> let !(I# a) = fromInteger i- !(I# b) = fromInteger j- c :: Int#- c = uncheckedIShiftRL# a b- in reduce (integerToIntLiteral (toInteger $ I# c))---------------------- GHC.Prim.Word#------------------- "GHC.Prim.plusWord#" | Just (i,j) <- wordLiterals args- -> reduce (integerToWordLiteral (i+j))-- "GHC.Prim.subWordC#" | Just (i,j) <- wordLiterals args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- !(W# a) = fromInteger i- !(W# b) = fromInteger j- !(# d, c #) = subWordC# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . WordLiteral . toInteger $ W# d)- , Left (Literal . IntLiteral . toInteger $ I# c)])-- "GHC.Prim.plusWord2#" | Just (i,j) <- wordLiterals args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- !(W# a) = fromInteger i- !(W# b) = fromInteger j- !(# h', l #) = plusWord2# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . WordLiteral . toInteger $ W# h')- , Left (Literal . WordLiteral . toInteger $ W# l)])-- "GHC.Prim.minusWord#" | Just (i,j) <- wordLiterals args- -> reduce (integerToWordLiteral (i-j))- "GHC.Prim.timesWord#" | Just (i,j) <- wordLiterals args- -> reduce (integerToWordLiteral (i*j))-- "GHC.Prim.timesWord2#" | Just (i,j) <- wordLiterals args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- !(W# a) = fromInteger i- !(W# b) = fromInteger j- !(# h', l #) = timesWord2# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . WordLiteral . toInteger $ W# h')- , Left (Literal . WordLiteral . toInteger $ W# l)])-- "GHC.Prim.quotWord#" | Just (i,j) <- wordLiterals args- -> reduce (integerToWordLiteral (i `quot` j))- "GHC.Prim.remWord#" | Just (i,j) <- wordLiterals args- -> reduce (integerToWordLiteral (i `rem` j))- "GHC.Prim.quotRemWord#" | Just (i,j) <- wordLiterals args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- (q,r) = quotRem i j- ret = mkApps (Data tupDc) (map Right tyArgs ++- [Left (integerToWordLiteral q), Left (integerToWordLiteral r)])- in reduce ret- "GHC.Prim.quotRemWord2#" | [i,j,k'] <- wordLiterals' args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- !(W# a) = fromInteger i- !(W# b) = fromInteger j- !(W# c) = fromInteger k'- !(# x, y #) = quotRemWord2# a b c- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . WordLiteral . toInteger $ W# x)- , Left (Literal . WordLiteral . toInteger $ W# y)])-- "GHC.Prim.and#" | Just (i,j) <- wordLiterals args- -> reduce (integerToWordLiteral (i .&. j))- "GHC.Prim.or#" | Just (i,j) <- wordLiterals args- -> reduce (integerToWordLiteral (i .|. j))- "GHC.Prim.xor#" | Just (i,j) <- wordLiterals args- -> reduce (integerToWordLiteral (i `xor` j))- "GHC.Prim.not#" | [i] <- wordLiterals' args- -> reduce (integerToWordLiteral (complement i))-- "GHC.Prim.uncheckedShiftL#"- | [ Lit (WordLiteral w)- , Lit (IntLiteral i)- ] <- args- -> reduce (Literal (WordLiteral (w `shiftL` fromInteger i)))- "GHC.Prim.uncheckedShiftRL#"- | [ Lit (WordLiteral w)- , Lit (IntLiteral i)- ] <- args- -> reduce (Literal (WordLiteral (w `shiftR` fromInteger i)))-- "GHC.Prim.word2Int#"- | [Lit (WordLiteral i)] <- args- -> reduce . Literal . IntLiteral . toInteger $ (fromInteger :: Integer -> Int) i -- for overflow behaviour-- "GHC.Prim.gtWord#" | Just (i,j) <- wordLiterals args- -> reduce (boolToIntLiteral (i > j))- "GHC.Prim.geWord#" | Just (i,j) <- wordLiterals args- -> reduce (boolToIntLiteral (i >= j))- "GHC.Prim.eqWord#" | Just (i,j) <- wordLiterals args- -> reduce (boolToIntLiteral (i == j))- "GHC.Prim.neWord#" | Just (i,j) <- wordLiterals args- -> reduce (boolToIntLiteral (i /= j))- "GHC.Prim.ltWord#" | Just (i,j) <- wordLiterals args- -> reduce (boolToIntLiteral (i < j))- "GHC.Prim.leWord#" | Just (i,j) <- wordLiterals args- -> reduce (boolToIntLiteral (i <= j))-- "GHC.Prim.popCnt8#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word8) $ i- "GHC.Prim.popCnt16#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word16) $ i- "GHC.Prim.popCnt32#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word32) $ i- "GHC.Prim.popCnt64#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word64) $ i- "GHC.Prim.popCnt#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word) $ i-- "GHC.Prim.clz8#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word8) $ i- "GHC.Prim.clz16#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word16) $ i- "GHC.Prim.clz32#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word32) $ i- "GHC.Prim.clz64#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word64) $ i- "GHC.Prim.clz#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word) $ i-- "GHC.Prim.ctz8#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i .&. (bit 8 - 1)- "GHC.Prim.ctz16#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i .&. (bit 16 - 1)- "GHC.Prim.ctz32#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i .&. (bit 32 - 1)- "GHC.Prim.ctz64#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word64) $ i .&. (bit 64 - 1)- "GHC.Prim.ctz#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i-- "GHC.Prim.byteSwap16#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . byteSwap16 . (fromInteger :: Integer -> Word16) $ i- "GHC.Prim.byteSwap32#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . byteSwap32 . (fromInteger :: Integer -> Word32) $ i- "GHC.Prim.byteSwap64#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . byteSwap64 . (fromInteger :: Integer -> Word64) $ i- "GHC.Prim.byteSwap#" | [i] <- wordLiterals' args -- assume 64bits- -> reduce . integerToWordLiteral . toInteger . byteSwap64 . (fromInteger :: Integer -> Word64) $ i----------------- Narrowing-------------- "GHC.Prim.narrow8Int#" | [i] <- intLiterals' args- -> let !(I# a) = fromInteger i- b = narrow8Int# a- in reduce . Literal . IntLiteral . toInteger $ I# b- "GHC.Prim.narrow16Int#" | [i] <- intLiterals' args- -> let !(I# a) = fromInteger i- b = narrow16Int# a- in reduce . Literal . IntLiteral . toInteger $ I# b- "GHC.Prim.narrow32Int#" | [i] <- intLiterals' args- -> let !(I# a) = fromInteger i- b = narrow32Int# a- in reduce . Literal . IntLiteral . toInteger $ I# b- "GHC.Prim.narrow8Word#" | [i] <- wordLiterals' args- -> let !(W# a) = fromInteger i- b = narrow8Word# a- in reduce . Literal . WordLiteral . toInteger $ W# b- "GHC.Prim.narrow16Word#" | [i] <- wordLiterals' args- -> let !(W# a) = fromInteger i- b = narrow16Word# a- in reduce . Literal . WordLiteral . toInteger $ W# b- "GHC.Prim.narrow32Word#" | [i] <- wordLiterals' args- -> let !(W# a) = fromInteger i- b = narrow32Word# a- in reduce . Literal . WordLiteral . toInteger $ W# b--------------- Double#------------ "GHC.Prim.>##" | Just r <- liftDDI (>##) args- -> reduce r- "GHC.Prim.>=##" | Just r <- liftDDI (>=##) args- -> reduce r- "GHC.Prim.==##" | Just r <- liftDDI (==##) args- -> reduce r- "GHC.Prim./=##" | Just r <- liftDDI (/=##) args- -> reduce r- "GHC.Prim.<##" | Just r <- liftDDI (<##) args- -> reduce r- "GHC.Prim.<=##" | Just r <- liftDDI (<=##) args- -> reduce r- "GHC.Prim.+##" | Just r <- liftDDD (+##) args- -> reduce r- "GHC.Prim.-##" | Just r <- liftDDD (-##) args- -> reduce r- "GHC.Prim.*##" | Just r <- liftDDD (*##) args- -> reduce r- "GHC.Prim./##" | Just r <- liftDDD (/##) args- -> reduce r-- "GHC.Prim.negateDouble#" | Just r <- liftDD negateDouble# args- -> reduce r- "GHC.Prim.fabsDouble#" | Just r <- liftDD fabsDouble# args- -> reduce r-- "GHC.Prim.double2Int#" | [i] <- doubleLiterals' args- -> let !(D# a) = fromRational i- r = double2Int# a- in reduce . Literal . IntLiteral . toInteger $ I# r- "GHC.Prim.double2Float#"- | [Lit (DoubleLiteral d)] <- args- -> reduce (Literal (FloatLiteral (toRational (fromRational d :: Float))))--- "GHC.Prim.expDouble#" | Just r <- liftDD expDouble# args- -> reduce r- "GHC.Prim.logDouble#" | Just r <- liftDD logDouble# args- -> reduce r- "GHC.Prim.sqrtDouble#" | Just r <- liftDD sqrtDouble# args- -> reduce r- "GHC.Prim.sinDouble#" | Just r <- liftDD sinDouble# args- -> reduce r- "GHC.Prim.cosDouble#" | Just r <- liftDD cosDouble# args- -> reduce r- "GHC.Prim.tanDouble#" | Just r <- liftDD tanDouble# args- -> reduce r- "GHC.Prim.asinDouble#" | Just r <- liftDD asinDouble# args- -> reduce r- "GHC.Prim.acosDouble#" | Just r <- liftDD acosDouble# args- -> reduce r- "GHC.Prim.atanDouble#" | Just r <- liftDD atanDouble# args- -> reduce r- "GHC.Prim.sinhDouble#" | Just r <- liftDD sinhDouble# args- -> reduce r- "GHC.Prim.coshDouble#" | Just r <- liftDD coshDouble# args- -> reduce r- "GHC.Prim.tanhDouble#" | Just r <- liftDD tanhDouble# args- -> reduce r- "GHC.Prim.**##" | Just r <- liftDDD (**##) args- -> reduce r--- decodeDouble_2Int# :: Double# -> (#Int#, Word#, Word#, Int##)- "GHC.Prim.decodeDouble_2Int#" | [i] <- doubleLiterals' args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- !(D# a) = fromRational i- !(# p, q, r, s #) = decodeDouble_2Int# a- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . IntLiteral . toInteger $ I# p)- , Left (Literal . WordLiteral . toInteger $ W# q)- , Left (Literal . WordLiteral . toInteger $ W# r)- , Left (Literal . IntLiteral . toInteger $ I# s)])--- decodeDouble_Int64# :: Double# -> (#Int#, Int##)- "GHC.Prim.decodeDouble_Int64#" | [i] <- doubleLiterals' args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- !(D# a) = fromRational i- !(# p, q #) = decodeDouble_Int64# a- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . IntLiteral . toInteger $ I# p)- , Left (Literal . IntLiteral . toInteger $ I# q)])------------- Float---------- "GHC.Prim.gtFloat#" | Just r <- liftFFI gtFloat# args- -> reduce r- "GHC.Prim.geFloat#" | Just r <- liftFFI geFloat# args- -> reduce r- "GHC.Prim.eqFloat#" | Just r <- liftFFI eqFloat# args- -> reduce r- "GHC.Prim.neFloat#" | Just r <- liftFFI neFloat# args- -> reduce r- "GHC.Prim.ltFloat#" | Just r <- liftFFI ltFloat# args- -> reduce r- "GHC.Prim.leFloat#" | Just r <- liftFFI leFloat# args- -> reduce r-- "GHC.Prim.plusFloat#" | Just r <- liftFFF plusFloat# args- -> reduce r- "GHC.Prim.minusFloat#" | Just r <- liftFFF minusFloat# args- -> reduce r- "GHC.Prim.timesFloat#" | Just r <- liftFFF timesFloat# args- -> reduce r- "GHC.Prim.divideFloat#" | Just r <- liftFFF divideFloat# args- -> reduce r-- "GHC.Prim.negateFloat#" | Just r <- liftFF negateFloat# args- -> reduce r- "GHC.Prim.fabsFloat#" | Just r <- liftFF fabsFloat# args- -> reduce r-- "GHC.Prim.float2Int#" | [i] <- floatLiterals' args- -> let !(F# a) = fromRational i- r = float2Int# a- in reduce . Literal . IntLiteral . toInteger $ I# r-- "GHC.Prim.expFloat#" | Just r <- liftFF expFloat# args- -> reduce r- "GHC.Prim.logFloat#" | Just r <- liftFF logFloat# args- -> reduce r- "GHC.Prim.sqrtFloat#" | Just r <- liftFF sqrtFloat# args- -> reduce r- "GHC.Prim.sinFloat#" | Just r <- liftFF sinFloat# args- -> reduce r- "GHC.Prim.cosFloat#" | Just r <- liftFF cosFloat# args- -> reduce r- "GHC.Prim.tanFloat#" | Just r <- liftFF tanFloat# args- -> reduce r- "GHC.Prim.asinFloat#" | Just r <- liftFF asinFloat# args- -> reduce r- "GHC.Prim.acosFloat#" | Just r <- liftFF acosFloat# args- -> reduce r- "GHC.Prim.atanFloat#" | Just r <- liftFF atanFloat# args- -> reduce r- "GHC.Prim.sinhFloat#" | Just r <- liftFF sinhFloat# args- -> reduce r- "GHC.Prim.coshFloat#" | Just r <- liftFF coshFloat# args- -> reduce r- "GHC.Prim.tanhFloat#" | Just r <- liftFF tanhFloat# args- -> reduce r- "GHC.Prim.powerFloat#" | Just r <- liftFFF powerFloat# args- -> reduce r-- "GHC.Prim.float2Double#" | [i] <- floatLiterals' args- -> let !(F# a) = fromRational i- r = float2Double# a- in reduce . Literal . DoubleLiteral . toRational $ D# r--- "GHC.Prim.newByteArray#"- | [iV,PrimVal rwNm rwTy _ _] <- args- , [i] <- intLiterals' [iV]- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- Heap (gh,p) ph ids = h- lit = Literal (ByteArrayLiteral (Vector.replicate (fromInteger i) 0))- h' = Heap (IntMap.insert p lit gh,p+1) ph ids- mbaTy = mkFunTy intPrimTy (last tyArgs)- newE = mkApps (Data tupDc) (map Right tyArgs ++- [Left (Prim rwNm rwTy)- ,Left (mkApps (Prim "GHC.Prim.MutableByteArray#" mbaTy)- [Left (Literal . IntLiteral $ toInteger p)])- ])- in Just (h',k,newE)-- "GHC.Prim.setByteArray#"- | [PrimVal _mbaNm _mbaTy _ [baV]- ,offV,lenV,cV- ,PrimVal rwNm rwTy _ _- ] <- args- , [ba,off,len,c] <- intLiterals' [baV,offV,lenV,cV]- -> let Heap (gh,p) ph ids = h- Just (Literal (ByteArrayLiteral (Vector.Vector voff vlen ba1))) =- IntMap.lookup (fromInteger ba) gh- !(I# off') = fromInteger off- !(I# len') = fromInteger len- !(I# c') = fromInteger c- ba2 = unsafeDupablePerformIO $ do- ByteArray.MutableByteArray mba <- ByteArray.unsafeThawByteArray ba1- svoid (setByteArray# mba off' len' c')- ByteArray.unsafeFreezeByteArray (ByteArray.MutableByteArray mba)- ba3 = Literal (ByteArrayLiteral (Vector.Vector voff vlen ba2))- h' = Heap (IntMap.insert (fromInteger ba) ba3 gh,p) ph ids- in Just (h',k,Prim rwNm rwTy)-- "GHC.Prim.writeWordArray#"- | [PrimVal _mbaNm _mbaTy _ [baV]- ,iV,wV- ,PrimVal rwNm rwTy _ _- ] <- args- , [ba,i] <- intLiterals' [baV,iV]- , [w] <- wordLiterals' [wV]- -> let Heap (gh,p) ph ids = h- Just (Literal (ByteArrayLiteral (Vector.Vector off len ba1))) =- IntMap.lookup (fromInteger ba) gh- !(I# i') = fromInteger i- !(W# w') = fromIntegral w- ba2 = unsafeDupablePerformIO $ do- ByteArray.MutableByteArray mba <- ByteArray.unsafeThawByteArray ba1- svoid (writeWordArray# mba i' w')- ByteArray.unsafeFreezeByteArray (ByteArray.MutableByteArray mba)- ba3 = Literal (ByteArrayLiteral (Vector.Vector off len ba2))- h' = Heap (IntMap.insert (fromInteger ba) ba3 gh,p) ph ids- in Just (h',k,Prim rwNm rwTy)-- "GHC.Prim.unsafeFreezeByteArray#"- | [PrimVal _mbaNm _mbaTy _ [baV]- ,PrimVal rwNm rwTy _ _- ] <- args- , [ba] <- intLiterals' [baV]- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- Heap (gh,_) _ _ = h- Just ba' = IntMap.lookup (fromInteger ba) gh- in reduce $ mkApps (Data tupDc) (map Right tyArgs ++- [Left (Prim rwNm rwTy)- ,Left ba'])-- "GHC.Prim.sizeofByteArray#"- | [Lit (ByteArrayLiteral ba)] <- args- -> reduce (Literal (IntLiteral (toInteger (Vector.length ba))))-- "GHC.Prim.indexWordArray#"- | [Lit (ByteArrayLiteral (Vector.Vector _ _ (ByteArray.ByteArray ba))),iV] <- args- , [i] <- intLiterals' [iV]- -> let !(I# i') = fromInteger i- !w = indexWordArray# ba i'- in reduce (Literal (WordLiteral (toInteger (W# w))))-- "GHC.Prim.getSizeofMutBigNat#"- | [PrimVal _mbaNm _mbaTy _ [baV]- ,PrimVal rwNm rwTy _ _- ] <- args- , [ba] <- intLiterals' [baV]- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- Heap (gh,_) _ _ = h- Just (Literal (ByteArrayLiteral ba')) = IntMap.lookup (fromInteger ba) gh- lit = Literal (IntLiteral (toInteger (Vector.length ba')))- in reduce $ mkApps (Data tupDc) (map Right tyArgs ++- [Left (Prim rwNm rwTy)- ,Left lit])-- "GHC.Prim.resizeMutableByteArray#"- | [PrimVal mbaNm mbaTy _ [baV]- ,iV- ,PrimVal rwNm rwTy _ _- ] <- args- , [ba,i] <- intLiterals' [baV,iV]- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- Heap (gh,p) ph ids = h- Just (Literal (ByteArrayLiteral (Vector.Vector 0 _ ba1)))- = IntMap.lookup (fromInteger ba) gh- !(I# i') = fromInteger i- ba2 = unsafeDupablePerformIO $ do- ByteArray.MutableByteArray mba <- ByteArray.unsafeThawByteArray ba1- mba' <- IO (\s -> case resizeMutableByteArray# mba i' s of- (# s', mba' #) -> (# s', ByteArray.MutableByteArray mba' #))- ByteArray.unsafeFreezeByteArray mba'- ba3 = Literal (ByteArrayLiteral (Vector.Vector 0 (I# i') ba2))- h' = Heap (IntMap.insert p ba3 gh,p+1) ph ids- newE = mkApps (Data tupDc) (map Right tyArgs ++- [Left (Prim rwNm rwTy)- ,Left (mkApps (Prim mbaNm mbaTy)- [Left (Literal . IntLiteral $ toInteger p)])- ])- in Just (h',k,newE)-- "GHC.Prim.shrinkMutableByteArray#"- | [PrimVal _mbaNm _mbaTy _ [baV]- ,lenV- ,PrimVal rwNm rwTy _ _- ] <- args- , [ba,len] <- intLiterals' [baV,lenV]- -> let Heap (gh,p) ph ids = h- Just (Literal (ByteArrayLiteral (Vector.Vector voff vlen ba1))) =- IntMap.lookup (fromInteger ba) gh- !(I# len') = fromInteger len- ba2 = unsafeDupablePerformIO $ do- ByteArray.MutableByteArray mba <- ByteArray.unsafeThawByteArray ba1- svoid (shrinkMutableByteArray# mba len')- ByteArray.unsafeFreezeByteArray (ByteArray.MutableByteArray mba)- ba3 = Literal (ByteArrayLiteral (Vector.Vector voff vlen ba2))- h' = Heap (IntMap.insert (fromInteger ba) ba3 gh,p) ph ids- in Just (h',k,Prim rwNm rwTy)-- "GHC.Prim.copyByteArray#"- | [Lit (ByteArrayLiteral (Vector.Vector _ _ (ByteArray.ByteArray src_ba)))- ,src_offV- ,PrimVal _mbaNm _mbaTy _ [dst_mbaV]- ,dst_offV, nV- ,PrimVal rwNm rwTy _ _- ] <- args- , [src_off,dst_mba,dst_off,n] <- intLiterals' [src_offV,dst_mbaV,dst_offV,nV]- -> let Heap (gh,p) ph ids = h- Just (Literal (ByteArrayLiteral (Vector.Vector voff vlen dst_ba))) =- IntMap.lookup (fromInteger dst_mba) gh- !(I# src_off') = fromInteger src_off- !(I# dst_off') = fromInteger dst_off- !(I# n') = fromInteger n- ba2 = unsafeDupablePerformIO $ do- ByteArray.MutableByteArray dst_mba1 <- ByteArray.unsafeThawByteArray dst_ba- svoid (copyByteArray# src_ba src_off' dst_mba1 dst_off' n')- ByteArray.unsafeFreezeByteArray (ByteArray.MutableByteArray dst_mba1)- ba3 = Literal (ByteArrayLiteral (Vector.Vector voff vlen ba2))- h' = Heap (IntMap.insert (fromInteger dst_mba) ba3 gh,p) ph ids- in Just (h',k,Prim rwNm rwTy)-- "GHC.Prim.readWordArray#"- | [PrimVal _mbaNm _mbaTy _ [baV]- ,offV- ,PrimVal rwNm rwTy _ _- ] <- args- , [ba,off] <- intLiterals' [baV,offV]- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- Heap (gh,_) _ _ = h- Just (Literal (ByteArrayLiteral (Vector.Vector _ _ ba1))) =- IntMap.lookup (fromInteger ba) gh- !(I# off') = fromInteger off- w = unsafeDupablePerformIO $ do- ByteArray.MutableByteArray mba <- ByteArray.unsafeThawByteArray ba1- IO (\s -> case readWordArray# mba off' s of- (# s', w' #) -> (# s', W# w' #))- newE = mkApps (Data tupDc) (map Right tyArgs ++- [Left (Prim rwNm rwTy)- ,Left (Literal (WordLiteral (toInteger w)))- ])- in reduce newE---- decodeFloat_Int# :: Float# -> (#Int#, Int##)- "GHC.Prim.decodeFloat_Int#" | [i] <- floatLiterals' args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- !(F# a) = fromRational i- !(# p, q #) = decodeFloat_Int# a- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . IntLiteral . toInteger $ I# p)- , Left (Literal . IntLiteral . toInteger $ I# q)])--- "GHC.Prim.tagToEnum#"- | [ConstTy (TyCon tcN)] <- tys- , [Lit (IntLiteral i)] <- args- -> let dc = do { tc <- HashMap.lookup (nameOcc tcN) tcm- ; let dcs = tyConDataCons tc- ; List.find ((== (i+1)) . toInteger . dcTag) dcs- }- in ((h,k,) . Data) <$> dc--- "GHC.Classes.geInt" | Just (i,j) <- intCLiterals args- -> reduce (boolToBoolLiteral tcm ty (i >= j))-- "GHC.Classes.&&"- | [DC lCon _- ,DC rCon _] <- args- -> reduce $ boolToBoolLiteral tcm ty- ((name2String (dcName lCon) == "GHC.Types.True") &&- (name2String (dcName rCon) == "GHC.Types.True"))-- "GHC.Classes.||"- | [DC lCon _- ,DC rCon _] <- args- -> reduce $ boolToBoolLiteral tcm ty- ((name2String (dcName lCon) == "GHC.Types.True") ||- (name2String (dcName rCon) == "GHC.Types.True"))-- "GHC.Classes.divInt#" | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i `div` j))-- "GHC.Classes.not"- | [DC bCon _] <- args- -> reduce (boolToBoolLiteral tcm ty (name2String (dcName bCon) == "GHC.Types.False"))-- "GHC.Integer.Logarithms.integerLogBase#"- | Just (a,b) <- integerLiterals args- , Just c <- flogBase a b- -> (reduce . Literal . IntLiteral . toInteger) c-- "GHC.Integer.Type.smallInteger"- | [Lit (IntLiteral i)] <- args- -> reduce (Literal (IntegerLiteral i))-- "GHC.Integer.Type.integerToInt"- | [i] <- integerLiterals' args- -> reduce (integerToIntLiteral i)-- "GHC.Integer.Type.decodeDoubleInteger" -- :: Double# -> (#Integer, Int##)- | [Lit (DoubleLiteral i)] <- args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- !(D# a) = fromRational i- !(# b, c #) = decodeDoubleInteger a- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (integerToIntegerLiteral b)- , Left (integerToIntLiteral . toInteger $ I# c)])-- "GHC.Integer.Type.encodeDoubleInteger" -- :: Integer -> Int# -> Double#- | [iV, Lit (IntLiteral j)] <- args- , [i] <- integerLiterals' [iV]- -> let !(I# k') = fromInteger j- r = encodeDoubleInteger i k'- in reduce . Literal . DoubleLiteral . toRational $ D# r-- "GHC.Integer.Type.quotRemInteger" -- :: Integer -> Integer -> (#Integer, Integer#)- | [i, j] <- integerLiterals' args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- (q,r) = quotRem i j- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (integerToIntegerLiteral q)- , Left (integerToIntegerLiteral r)])-- "GHC.Integer.Type.plusInteger" | Just (i,j) <- integerLiterals args- -> reduce (integerToIntegerLiteral (i+j))-- "GHC.Integer.Type.minusInteger" | Just (i,j) <- integerLiterals args- -> reduce (integerToIntegerLiteral (i-j))-- "GHC.Integer.Type.timesInteger" | Just (i,j) <- integerLiterals args- -> reduce (integerToIntegerLiteral (i*j))-- "GHC.Integer.Type.negateInteger"- | [i] <- integerLiterals' args- -> reduce (integerToIntegerLiteral (negate i))-- "GHC.Integer.Type.divInteger" | Just (i,j) <- integerLiterals args- -> reduce (integerToIntegerLiteral (i `div` j))-- "GHC.Integer.Type.modInteger" | Just (i,j) <- integerLiterals args- -> reduce (integerToIntegerLiteral (i `mod` j))-- "GHC.Integer.Type.quotInteger" | Just (i,j) <- integerLiterals args- -> reduce (integerToIntegerLiteral (i `quot` j))-- "GHC.Integer.Type.remInteger" | Just (i,j) <- integerLiterals args- -> reduce (integerToIntegerLiteral (i `rem` j))-- "GHC.Integer.Type.divModInteger" | Just (i,j) <- integerLiterals args- -> let (_,tyView -> TyConApp ubTupTcNm [liftedKi,_,intTy,_]) = splitFunForallTy ty- (Just ubTupTc) = HashMap.lookup (nameOcc ubTupTcNm) tcm- [ubTupDc] = tyConDataCons ubTupTc- (d,m) = divMod i j- in reduce $- mkApps (Data ubTupDc) [ Right liftedKi, Right liftedKi- , Right intTy, Right intTy- , Left (Literal (IntegerLiteral d))- , Left (Literal (IntegerLiteral m))- ]-- "GHC.Integer.Type.gtInteger" | Just (i,j) <- integerLiterals args- -> reduce (boolToBoolLiteral tcm ty (i > j))-- "GHC.Integer.Type.geInteger" | Just (i,j) <- integerLiterals args- -> reduce (boolToBoolLiteral tcm ty (i >= j))-- "GHC.Integer.Type.eqInteger" | Just (i,j) <- integerLiterals args- -> reduce (boolToBoolLiteral tcm ty (i == j))-- "GHC.Integer.Type.neqInteger" | Just (i,j) <- integerLiterals args- -> reduce (boolToBoolLiteral tcm ty (i /= j))-- "GHC.Integer.Type.ltInteger" | Just (i,j) <- integerLiterals args- -> reduce (boolToBoolLiteral tcm ty (i < j))-- "GHC.Integer.Type.leInteger" | Just (i,j) <- integerLiterals args- -> reduce (boolToBoolLiteral tcm ty (i <= j))-- "GHC.Integer.Type.gtInteger#" | Just (i,j) <- integerLiterals args- -> reduce (boolToIntLiteral (i > j))-- "GHC.Integer.Type.geInteger#" | Just (i,j) <- integerLiterals args- -> reduce (boolToIntLiteral (i >= j))-- "GHC.Integer.Type.eqInteger#" | Just (i,j) <- integerLiterals args- -> reduce (boolToIntLiteral (i == j))-- "GHC.Integer.Type.neqInteger#" | Just (i,j) <- integerLiterals args- -> reduce (boolToIntLiteral (i /= j))-- "GHC.Integer.Type.ltInteger#" | Just (i,j) <- integerLiterals args- -> reduce (boolToIntLiteral (i < j))-- "GHC.Integer.Type.leInteger#" | Just (i,j) <- integerLiterals args- -> reduce (boolToIntLiteral (i <= j))-- "GHC.Integer.Type.shiftRInteger"- | [iV, Lit (IntLiteral j)] <- args- , [i] <- integerLiterals' [iV]- -> reduce (integerToIntegerLiteral (i `shiftR` fromInteger j))-- "GHC.Integer.Type.shiftLInteger"- | [iV, Lit (IntLiteral j)] <- args- , [i] <- integerLiterals' [iV]- -> reduce (integerToIntegerLiteral (i `shiftL` fromInteger j))-- "GHC.Integer.Type.wordToInteger"- | [Lit (WordLiteral w)] <- args- -> reduce (Literal (IntegerLiteral w))-- "GHC.Natural.NatS#"- | [Lit (WordLiteral w)] <- args- -> reduce (Literal (NaturalLiteral w))-- -- GHC.Real.^ -- XXX: Very fragile- -- ^_f, $wf, $wf1 are specialisations of the internal function f in the implementation of (^) in GHC.Real- "GHC.Real.^_f" -- :: Integer -> Integer -> Integer- | [i,j] <- integerLiterals' args- -> reduce (integerToIntegerLiteral $ i ^ j)- "GHC.Real.$wf" -- :: Integer -> Int# -> Integer- | [iV, Lit (IntLiteral j)] <- args- , [i] <- integerLiterals' [iV]- -> reduce (integerToIntegerLiteral $ i ^ j)- "GHC.Real.$wf1" -- :: Int# -> Int# -> Int#- | [Lit (IntLiteral i), Lit (IntLiteral j)] <- args- -> reduce (integerToIntLiteral $ i ^ j)--- "GHC.TypeLits.natVal"- | [Lit (NaturalLiteral n), _] <- args- -> reduce (integerToIntegerLiteral n)-- "GHC.TypeNats.natVal"- | [Lit (NaturalLiteral n), _] <- args- -> reduce (Literal (NaturalLiteral n))-- "GHC.Types.C#"- | isSubj- , [Lit (CharLiteral c)] <- args- -> let (_,tyView -> TyConApp charTcNm []) = splitFunForallTy ty- (Just charTc) = HashMap.lookup (nameOcc charTcNm) tcm- [charDc] = tyConDataCons charTc- in reduce (mkApps (Data charDc) [Left (Literal (CharLiteral c))])-- "GHC.Types.I#"- | isSubj- , [Lit (IntLiteral i)] <- args- -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty- (Just intTc) = HashMap.lookup (nameOcc intTcNm) tcm- [intDc] = tyConDataCons intTc- in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])- "GHC.Int.I8#"- | isSubj- , [Lit (IntLiteral i)] <- args- -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty- (Just intTc) = HashMap.lookup (nameOcc intTcNm) tcm- [intDc] = tyConDataCons intTc- in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])- "GHC.Int.I16#"- | isSubj- , [Lit (IntLiteral i)] <- args- -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty- (Just intTc) = HashMap.lookup (nameOcc intTcNm) tcm- [intDc] = tyConDataCons intTc- in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])- "GHC.Int.I32#"- | isSubj- , [Lit (IntLiteral i)] <- args- -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty- (Just intTc) = HashMap.lookup (nameOcc intTcNm) tcm- [intDc] = tyConDataCons intTc- in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])- "GHC.Int.I64#"- | isSubj- , [Lit (IntLiteral i)] <- args- -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty- (Just intTc) = HashMap.lookup (nameOcc intTcNm) tcm- [intDc] = tyConDataCons intTc- in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])-- "GHC.Types.W#"- | isSubj- , [Lit (WordLiteral c)] <- args- -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty- (Just wordTc) = HashMap.lookup (nameOcc wordTcNm) tcm- [wordDc] = tyConDataCons wordTc- in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])- "GHC.Word.W8#"- | isSubj- , [Lit (WordLiteral c)] <- args- -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty- (Just wordTc) = HashMap.lookup (nameOcc wordTcNm) tcm- [wordDc] = tyConDataCons wordTc- in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])- "GHC.Word.W16#"- | isSubj- , [Lit (WordLiteral c)] <- args- -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty- (Just wordTc) = HashMap.lookup (nameOcc wordTcNm) tcm- [wordDc] = tyConDataCons wordTc- in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])- "GHC.Word.W32#"- | isSubj- , [Lit (WordLiteral c)] <- args- -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty- (Just wordTc) = HashMap.lookup (nameOcc wordTcNm) tcm- [wordDc] = tyConDataCons wordTc- in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])- "GHC.Word.W64#"- | [Lit (WordLiteral c)] <- args- -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty- (Just wordTc) = HashMap.lookup (nameOcc wordTcNm) tcm- [wordDc] = tyConDataCons wordTc- in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])-- "GHC.Float.$w$sfromRat''" -- XXX: Very fragile- | [Lit (IntLiteral _minEx)- ,Lit (IntLiteral matDigs)- ,nV- ,dV] <- args- , [n,d] <- integerLiterals' [nV,dV]- -> case fromInteger matDigs of- matDigs'- | matDigs' == floatDigits (undefined :: Float)- -> reduce (Literal (FloatLiteral (toRational (fromRational (n :% d) :: Float))))- | matDigs' == floatDigits (undefined :: Double)- -> reduce (Literal (DoubleLiteral (toRational (fromRational (n :% d) :: Double))))- _ -> error $ $(curLoc) ++ "GHC.Float.$w$sfromRat'': Not a Float or Double"-- "GHC.Float.$w$sfromRat''1" -- XXX: Very fragile- | [Lit (IntLiteral _minEx)- ,Lit (IntLiteral matDigs)- ,nV- ,dV] <- args- , [n,d] <- integerLiterals' [nV,dV]- -> case fromInteger matDigs of- matDigs'- | matDigs' == floatDigits (undefined :: Float)- -> reduce (Literal (FloatLiteral (toRational (fromRational (n :% d) :: Float))))- | matDigs' == floatDigits (undefined :: Double)- -> reduce (Literal (DoubleLiteral (toRational (fromRational (n :% d) :: Double))))- _ -> error $ $(curLoc) ++ "GHC.Float.$w$sfromRat'': Not a Float or Double"-- "GHC.Integer.Type.doubleFromInteger"- | [i] <- integerLiterals' args- -> reduce (Literal (DoubleLiteral (toRational (fromInteger i :: Double))))-- "GHC.Base.eqString"- | [PrimVal _ _ _ [Lit (StringLiteral s1)]- ,PrimVal _ _ _ [Lit (StringLiteral s2)]- ] <- args- -> reduce (boolToBoolLiteral tcm ty (s1 == s2))- | otherwise -> error (show args)--- "Clash.Class.BitPack.packDouble#" -- :: Double -> BitVector 64- | [DC _ [Left arg]] <- args- , (h2,[],Literal (DoubleLiteral i)) <- whnf reduceConstant gbl tcm True (h,[],arg)- -> let resTyInfo = extractTySizeInfo tcm ty tys- in Just (h2,k,mkBitVectorLit' resTyInfo (BitVector.unsafeToInteger $ (pack :: Double -> BitVector 64) $ fromRational i))-- "Clash.Class.BitPack.packFloat#" -- :: Float -> BitVector 32- | [DC _ [Left arg]] <- args- , (h2,[],Literal (FloatLiteral i)) <- whnf reduceConstant gbl tcm True (h,[],arg)- -> let resTyInfo = extractTySizeInfo tcm ty tys- in Just (h2,k,mkBitVectorLit' resTyInfo (BitVector.unsafeToInteger $ (pack :: Float -> BitVector 32) $ fromRational i))-- "Clash.Class.BitPack.unpackFloat#"- | [i] <- bitVectorLiterals' args- -> reduce (Literal (FloatLiteral (toRational $ (unpack :: BitVector 32 -> Float) (fromInteger i))))-- "Clash.Class.BitPack.unpackDouble#"- | [i] <- bitVectorLiterals' args- -> reduce (Literal (DoubleLiteral (toRational $ (unpack :: BitVector 64 -> Double) (fromInteger i))))--- "Clash.Promoted.Nat.powSNat"- | [Right a, Right b] <- map (runExcept . tyNatSize tcm) tys- -> let c = case a of- 2 -> 1 `shiftL` (fromInteger b)- _ -> a ^ b- (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty- (Just snatTc) = HashMap.lookup (nameOcc snatTcNm) tcm- [snatDc] = tyConDataCons snatTc- in reduce $- mkApps (Data snatDc) [ Right (LitTy (NumTy c))- , Left (Literal (NaturalLiteral c))]-- "Clash.Promoted.Nat.flogBaseSNat"- | [_,_,Right a, Right b] <- map (runExcept . tyNatSize tcm) tys- , Just c <- flogBase a b- , let c' = toInteger c- -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty- (Just snatTc) = HashMap.lookup (nameOcc snatTcNm) tcm- [snatDc] = tyConDataCons snatTc- in reduce $- mkApps (Data snatDc) [ Right (LitTy (NumTy c'))- , Left (Literal (NaturalLiteral c'))]-- "Clash.Promoted.Nat.clogBaseSNat"- | [_,_,Right a, Right b] <- map (runExcept . tyNatSize tcm) tys- , Just c <- clogBase a b- , let c' = toInteger c- -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty- (Just snatTc) = HashMap.lookup (nameOcc snatTcNm) tcm- [snatDc] = tyConDataCons snatTc- in reduce $- mkApps (Data snatDc) [ Right (LitTy (NumTy c'))- , Left (Literal (NaturalLiteral c'))]-- "Clash.Promoted.Nat.logBaseSNat"- | [_,Right a, Right b] <- map (runExcept . tyNatSize tcm) tys- , Just c <- flogBase a b- , let c' = toInteger c- -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty- (Just snatTc) = HashMap.lookup (nameOcc snatTcNm) tcm- [snatDc] = tyConDataCons snatTc- in reduce $- mkApps (Data snatDc) [ Right (LitTy (NumTy c'))- , Left (Literal (NaturalLiteral c'))]----------------- BitVector---------------- Initialisation- "Clash.Sized.Internal.BitVector.size#"- | Just (_, kn) <- extractKnownNat tcm tys- -> let (_,tyView -> TyConApp intTcNm _) = splitFunForallTy ty- (Just intTc) = HashMap.lookup (nameOcc intTcNm) tcm- [intCon] = tyConDataCons intTc- in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral kn))])- "Clash.Sized.Internal.BitVector.maxIndex#"- | Just (_, kn) <- extractKnownNat tcm tys- -> let (_,tyView -> TyConApp intTcNm _) = splitFunForallTy ty- (Just intTc) = HashMap.lookup (nameOcc intTcNm) tcm- [intCon] = tyConDataCons intTc- in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral (kn-1)))])---- Construction- "Clash.Sized.Internal.BitVector.high" -- :: Bit- -> reduce (mkBitLit ty 1)- "Clash.Sized.Internal.BitVector.low" -- :: Bit- -> reduce (mkBitLit ty 0)---- Eq- "Clash.Sized.Internal.BitVector.eq##" | [i,j] <- bitLiterals args- -> reduce (boolToBoolLiteral tcm ty (i == j))- "Clash.Sized.Internal.BitVector.neq##" | [i,j] <- bitLiterals args- -> reduce (boolToBoolLiteral tcm ty (i /= j))---- Ord- "Clash.Sized.Internal.BitVector.lt##" | [i,j] <- bitLiterals args- -> reduce (boolToBoolLiteral tcm ty (i < j))- "Clash.Sized.Internal.BitVector.ge##" | [i,j] <- bitLiterals args- -> reduce (boolToBoolLiteral tcm ty (i >= j))- "Clash.Sized.Internal.BitVector.gt##" | [i,j] <- bitLiterals args- -> reduce (boolToBoolLiteral tcm ty (i > j))- "Clash.Sized.Internal.BitVector.le##" | [i,j] <- bitLiterals args- -> reduce (boolToBoolLiteral tcm ty (i <= j))---- Bits- "Clash.Sized.Internal.BitVector.and##"- | [i,j] <- bitLiterals args- -> reduce (mkBitLit ty (i .&. j))- "Clash.Sized.Internal.BitVector.or##"- | [i,j] <- bitLiterals args- -> reduce (mkBitLit ty (i .|. j))- "Clash.Sized.Internal.BitVector.xor##"- | [i,j] <- bitLiterals args- -> reduce (mkBitLit ty (i `xor` j))-- "Clash.Sized.Internal.BitVector.complement##"- | [i] <- bitLiterals args- -> reduce (mkBitLit ty (complement i))---- Pack- "Clash.Sized.Internal.BitVector.pack#"- | [i] <- bitLiterals args- -> let resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkBitVectorLit' resTyInfo i)-- "Clash.Sized.Internal.BitVector.unpack#"- | [i] <- bitVectorLiterals' args- -> reduce (mkBitLit ty i)---- Concatenation- "Clash.Sized.Internal.BitVector.++#" -- :: KnownNat m => BitVector n -> BitVector m -> BitVector (n + m)- | Just (_,m) <- extractKnownNat tcm tys- , [i,j] <- bitVectorLiterals' args- -> let val = i `shiftL` fromInteger m .|. j- resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkBitVectorLit' resTyInfo val)---- Reduction- "Clash.Sized.Internal.BitVector.reduceAnd#" -- :: KnownNat n => BitVector n -> Bit- | [i] <- bitVectorLiterals' args- , Just (_, kn) <- extractKnownNat tcm tys- -> let resTy = getResultTy tcm ty tys- val = reifyNat kn (op (fromInteger i))- in reduce (mkBitLit resTy val)- where- op :: KnownNat n => BitVector n -> Proxy n -> Integer- op u _ = toInteger (BitVector.reduceAnd# u)- "Clash.Sized.Internal.BitVector.reduceOr#" -- :: KnownNat n => BitVector n -> Bit- | [i] <- bitVectorLiterals' args- , Just (_, kn) <- extractKnownNat tcm tys- -> let resTy = getResultTy tcm ty tys- val = reifyNat kn (op (fromInteger i))- in reduce (mkBitLit resTy val)- where- op :: KnownNat n => BitVector n -> Proxy n -> Integer- op u _ = toInteger (BitVector.reduceOr# u)- "Clash.Sized.Internal.BitVector.reduceXor#" -- :: KnownNat n => BitVector n -> Bit- | [i] <- bitVectorLiterals' args- , Just (_, kn) <- extractKnownNat tcm tys- -> let resTy = getResultTy tcm ty tys- val = reifyNat kn (op (fromInteger i))- in reduce (mkBitLit resTy val)- where- op :: KnownNat n => BitVector n -> Proxy n -> Integer- op u _ = toInteger (BitVector.reduceXor# u)----- Indexing- "Clash.Sized.Internal.BitVector.index#" -- :: KnownNat n => BitVector n -> Int -> Bit- | Just (_,kn,i,j) <- bitVectorLitIntLit tcm tys args- -> let resTy = getResultTy tcm ty tys- val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkBitLit resTy val)- where- op :: KnownNat n => BitVector n -> Int -> Proxy n -> Integer- op u i _ = toInteger (BitVector.index# u i)- "Clash.Sized.Internal.BitVector.replaceBit#" -- :: :: KnownNat n => BitVector n -> Int -> Bit -> BitVector n- | Just (_, n) <- extractKnownNat tcm tys- , [ _- , PrimVal bvNm _ _ [_, Lit (IntegerLiteral bv)]- , valArgs -> Just [Literal (IntLiteral i)]- , PrimVal bNm _ _ [Lit (IntegerLiteral b)]- ] <- args- , bvNm == "Clash.Sized.Internal.BitVector.fromInteger#"- , bNm == "Clash.Sized.Internal.BitVector.fromInteger##"- -> let resTyInfo = extractTySizeInfo tcm ty tys- val = reifyNat n (op (fromInteger bv) (fromInteger i) (fromInteger b))- in reduce (mkBitVectorLit' resTyInfo val)- where- op :: KnownNat n => BitVector n -> Int -> Bit -> Proxy n -> Integer- op bv i b _ = toInteger (BitVector.replaceBit# bv i b)- "Clash.Sized.Internal.BitVector.setSlice#"- -- :: BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n)- -- -> BitVector (m + 1 + i)- | mTy : _ : nTy : _ <- tys- , Right m <- runExcept (tyNatSize tcm mTy)- , Right n <- runExcept (tyNatSize tcm nTy)- , [i,j] <- bitVectorLiterals' args- -> let val = BitVector.unsafeToInteger- $ BitVector.setSlice# (BV i) (unsafeSNat m) (unsafeSNat n) (BV j)- resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkBitVectorLit' resTyInfo val)- "Clash.Sized.Internal.BitVector.slice#"- -- :: BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n)- | mTy : _ : nTy : _ <- tys- , Right m <- runExcept (tyNatSize tcm mTy)- , Right n <- runExcept (tyNatSize tcm nTy)- , [i] <- bitVectorLiterals' args- -> let val = BitVector.unsafeToInteger- $ BitVector.slice# (BV i) (unsafeSNat m) (unsafeSNat n)- resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkBitVectorLit' resTyInfo val)- "Clash.Sized.Internal.BitVector.split#" -- :: forall n m. KnownNat n => BitVector (m + n) -> (BitVector m, BitVector n)- | nTy : mTy : _ <- tys- , Right n <- runExcept (tyNatSize tcm nTy)- , Right m <- runExcept (tyNatSize tcm mTy)- , [i] <- bitVectorLiterals' args- -> let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys- (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty'- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- bvTy : _ = tyArgs- valM = i `shiftR` fromInteger n- valN = i .&. mask- mask = bit (fromInteger n) - 1- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (mkBitVectorLit bvTy mTy m valM)- , Left (mkBitVectorLit bvTy nTy n valN)])-- "Clash.Sized.Internal.BitVector.msb#" -- :: forall n. KnownNat n => BitVector n -> Bit- | [i] <- bitVectorLiterals' args- , Just (_, kn) <- extractKnownNat tcm tys- -> let resTy = getResultTy tcm ty tys- val = reifyNat kn (op (fromInteger i))- in reduce (mkBitLit resTy val)- where- op :: KnownNat n => BitVector n -> Proxy n -> Integer- op u _ = toInteger (BitVector.msb# u)- "Clash.Sized.Internal.BitVector.lsb#" -- BitVector n -> Bit- | [i] <- bitVectorLiterals' args- , Just (_, kn) <- extractKnownNat tcm tys- -> let resTy = getResultTy tcm ty tys- val = reifyNat kn (op (fromInteger i))- in reduce (mkBitLit resTy val)- where- op :: KnownNat n => BitVector n -> Proxy n -> Integer- op u _ = toInteger (BitVector.lsb# u)----- Eq- "Clash.Sized.Internal.BitVector.eq#" | Just (i,j) <- bitVectorLiterals args- -> reduce (boolToBoolLiteral tcm ty (i == j))- "Clash.Sized.Internal.BitVector.neq#" | Just (i,j) <- bitVectorLiterals args- -> reduce (boolToBoolLiteral tcm ty (i /= j))---- Ord- "Clash.Sized.Internal.BitVector.lt#" | Just (i,j) <- bitVectorLiterals args- -> reduce (boolToBoolLiteral tcm ty (i < j))- "Clash.Sized.Internal.BitVector.ge#" | Just (i,j) <- bitVectorLiterals args- -> reduce (boolToBoolLiteral tcm ty (i >= j))- "Clash.Sized.Internal.BitVector.gt#" | Just (i,j) <- bitVectorLiterals args- -> reduce (boolToBoolLiteral tcm ty (i > j))- "Clash.Sized.Internal.BitVector.le#" | Just (i,j) <- bitVectorLiterals args- -> reduce (boolToBoolLiteral tcm ty (i <= j))---- Bounded- "Clash.Sized.Internal.BitVector.minBound#"- | Just (nTy,len) <- extractKnownNat tcm tys- -> reduce (mkBitVectorLit ty nTy len 0)- "Clash.Sized.Internal.BitVector.maxBound#"- | Just (litTy,mb) <- extractKnownNat tcm tys- -> let maxB = (2 ^ mb) - 1- in reduce (mkBitVectorLit ty litTy mb maxB)---- Num- "Clash.Sized.Internal.BitVector.+#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2 (BitVector.+#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.BitVector.-#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2 (BitVector.-#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.BitVector.*#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2 (BitVector.*#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.BitVector.negate#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i] <- bitVectorLiterals' args- -> let val = reifyNat kn (op (fromInteger i))- in reduce (mkBitVectorLit ty nTy kn val)- where- op :: KnownNat n => BitVector n -> Proxy n -> Integer- op u _ = toInteger (BitVector.negate# u)---- ExtendingNum- "Clash.Sized.Internal.BitVector.plus#" -- :: BitVector m -> BitVector n -> BitVector (Max m n + 1)- | Just (i,j) <- bitVectorLiterals args- -> let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- in reduce (mkBitVectorLit resTy resSizeTy resSizeInt (i+j))-- "Clash.Sized.Internal.BitVector.minus#"- | [i,j] <- bitVectorLiterals' args- -> let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- val = reifyNat resSizeInt (runSizedF (BitVector.-#) i j)- in reduce (mkBitVectorLit resTy resSizeTy resSizeInt val)-- "Clash.Sized.Internal.BitVector.times#"- | Just (i,j) <- bitVectorLiterals args- -> let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- in reduce (mkBitVectorLit resTy resSizeTy resSizeInt (i*j))---- Integral- "Clash.Sized.Internal.BitVector.quot#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2 (BitVector.quot#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.BitVector.rem#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2 (BitVector.rem#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.BitVector.toInteger#"- | [PrimVal nm' _ _ [_, Lit (IntegerLiteral i)]] <- args- , nm' == "Clash.Sized.Internal.BitVector.fromInteger#"- -> reduce (integerToIntegerLiteral i)---- Bits- "Clash.Sized.Internal.BitVector.and#"- | Just (i,j) <- bitVectorLiterals args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> reduce (mkBitVectorLit ty nTy kn (i .&. j))- "Clash.Sized.Internal.BitVector.or#"- | Just (i,j) <- bitVectorLiterals args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> reduce (mkBitVectorLit ty nTy kn (i .|. j))- "Clash.Sized.Internal.BitVector.xor#"- | Just (i,j) <- bitVectorLiterals args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> reduce (mkBitVectorLit ty nTy kn (i `xor` j))-- "Clash.Sized.Internal.BitVector.complement#"- | [i] <- bitVectorLiterals' args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> let val = reifyNat kn (op (fromInteger i))- in reduce (mkBitVectorLit ty nTy kn val)- where- op :: KnownNat n => BitVector n -> Proxy n -> Integer- op u _ = toInteger (BitVector.complement# u)-- "Clash.Sized.Internal.BitVector.shiftL#"- | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args- -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkBitVectorLit ty nTy kn val)- where- op :: KnownNat n => BitVector n -> Int -> Proxy n -> Integer- op u i _ = toInteger (BitVector.shiftL# u i)- "Clash.Sized.Internal.BitVector.shiftR#"- | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args- -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkBitVectorLit ty nTy kn val)- where- op :: KnownNat n => BitVector n -> Int -> Proxy n -> Integer- op u i _ = toInteger (BitVector.shiftR# u i)- "Clash.Sized.Internal.BitVector.rotateL#"- | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args- -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkBitVectorLit ty nTy kn val)- where- op :: KnownNat n => BitVector n -> Int -> Proxy n -> Integer- op u i _ = toInteger (BitVector.rotateL# u i)- "Clash.Sized.Internal.BitVector.rotateR#"- | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args- -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkBitVectorLit ty nTy kn val)- where- op :: KnownNat n => BitVector n -> Int -> Proxy n -> Integer- op u i _ = toInteger (BitVector.rotateR# u i)---- Resize- "Clash.Sized.Internal.BitVector.resize#" -- forall n m . KnownNat m => BitVector n -> BitVector m- | _ : mTy : _ <- tys- , Right km <- runExcept (tyNatSize tcm mTy)- , [i] <- bitVectorLiterals' args- -> let bitsKeep = (bit (fromInteger km)) - 1- val = i .&. bitsKeep- in reduce (mkBitVectorLit ty mTy km val)------------- Index------------ BitPack- "Clash.Sized.Internal.Index.pack#"- | nTy : _ <- tys- , Right _ <- runExcept (tyNatSize tcm nTy)- , [i] <- indexLiterals' args- -> let resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkBitVectorLit' resTyInfo i)- "Clash.Sized.Internal.Index.unpack#"- | Just (nTy,kn) <- extractKnownNat tcm tys- , [i] <- bitVectorLiterals' args- -> (h,k,) <$> mkIndexLit ty nTy kn i---- Eq- "Clash.Sized.Internal.Index.eq#" | Just (i,j) <- indexLiterals args- -> reduce (boolToBoolLiteral tcm ty (i == j))- "Clash.Sized.Internal.Index.neq#" | Just (i,j) <- indexLiterals args- -> reduce (boolToBoolLiteral tcm ty (i /= j))---- Ord- "Clash.Sized.Internal.Index.lt#"- | Just (i,j) <- indexLiterals args- -> reduce (boolToBoolLiteral tcm ty (i < j))- "Clash.Sized.Internal.Index.ge#"- | Just (i,j) <- indexLiterals args- -> reduce (boolToBoolLiteral tcm ty (i >= j))- "Clash.Sized.Internal.Index.gt#"- | Just (i,j) <- indexLiterals args- -> reduce (boolToBoolLiteral tcm ty (i > j))- "Clash.Sized.Internal.Index.le#"- | Just (i,j) <- indexLiterals args- -> reduce (boolToBoolLiteral tcm ty (i <= j))---- Bounded- "Clash.Sized.Internal.Index.maxBound#"- | Just (nTy,mb) <- extractKnownNat tcm tys- -> (h,k,) <$> mkIndexLit ty nTy mb (mb - 1)---- Num- "Clash.Sized.Internal.Index.+#"- | Just (nTy,kn) <- extractKnownNat tcm tys- , [i,j] <- indexLiterals' args- -> (h,k,) <$> mkIndexLit ty nTy kn (i + j)- "Clash.Sized.Internal.Index.-#"- | Just (nTy,kn) <- extractKnownNat tcm tys- , [i,j] <- indexLiterals' args- -> (h,k,) <$> mkIndexLit ty nTy kn (i - j)- "Clash.Sized.Internal.Index.*#"- | Just (nTy,kn) <- extractKnownNat tcm tys- , [i,j] <- indexLiterals' args- -> (h,k,) <$> mkIndexLit ty nTy kn (i * j)---- ExtendingNum- "Clash.Sized.Internal.Index.plus#"- | mTy : nTy : _ <- tys- , Right _ <- runExcept (tyNatSize tcm mTy)- , Right _ <- runExcept (tyNatSize tcm nTy)- , Just (i,j) <- indexLiterals args- -> let resTyInfo = extractTySizeInfo tcm ty tys- in (h,k,) <$> mkIndexLit' resTyInfo (i + j)- "Clash.Sized.Internal.Index.minus#"- | mTy : nTy : _ <- tys- , Right _ <- runExcept (tyNatSize tcm mTy)- , Right _ <- runExcept (tyNatSize tcm nTy)- , Just (i,j) <- indexLiterals args- -> let resTyInfo = extractTySizeInfo tcm ty tys- in (h,k,) <$> mkIndexLit' resTyInfo (i - j)- "Clash.Sized.Internal.Index.times#"- | mTy : nTy : _ <- tys- , Right _ <- runExcept (tyNatSize tcm mTy)- , Right _ <- runExcept (tyNatSize tcm nTy)- , Just (i,j) <- indexLiterals args- -> let resTyInfo = extractTySizeInfo tcm ty tys- in (h,k,) <$> mkIndexLit' resTyInfo (i * j)---- Integral- "Clash.Sized.Internal.Index.quot#"- | Just (nTy,kn) <- extractKnownNat tcm tys- , Just (i,j) <- indexLiterals args- -> (h,k,) <$> mkIndexLit ty nTy kn (i `quot` j)- "Clash.Sized.Internal.Index.rem#"- | Just (nTy,kn) <- extractKnownNat tcm tys- , Just (i,j) <- indexLiterals args- -> (h,k,) <$> mkIndexLit ty nTy kn (i `rem` j)- "Clash.Sized.Internal.Index.toInteger#"- | [PrimVal nm' _ _ [_, Lit (IntegerLiteral i)]] <- args- , nm' == "Clash.Sized.Internal.Index.fromInteger#"- -> reduce (integerToIntegerLiteral i)---- Resize- "Clash.Sized.Internal.Index.resize#"- | Just (mTy,m) <- extractKnownNat tcm tys- , [i] <- indexLiterals' args- -> (h,k,) <$> mkIndexLit ty mTy m i-------------- Signed----------- "Clash.Sized.Internal.Signed.size#"- | Just (_, kn) <- extractKnownNat tcm tys- -> let (_,tyView -> TyConApp intTcNm _) = splitFunForallTy ty- (Just intTc) = HashMap.lookup (nameOcc intTcNm) tcm- [intCon] = tyConDataCons intTc- in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral kn))])---- BitPack- "Clash.Sized.Internal.Signed.pack#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i] <- signedLiterals' args- -> reduce (mkBitVectorLit ty nTy kn i)- "Clash.Sized.Internal.Signed.unpack#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i] <- bitVectorLiterals' args- -> reduce (mkSignedLit ty nTy kn i)---- Eq- "Clash.Sized.Internal.Signed.eq#" | Just (i,j) <- signedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i == j))- "Clash.Sized.Internal.Signed.neq#" | Just (i,j) <- signedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i /= j))---- Ord- "Clash.Sized.Internal.Signed.lt#" | Just (i,j) <- signedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i < j))- "Clash.Sized.Internal.Signed.ge#" | Just (i,j) <- signedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i >= j))- "Clash.Sized.Internal.Signed.gt#" | Just (i,j) <- signedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i > j))- "Clash.Sized.Internal.Signed.le#" | Just (i,j) <- signedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i <= j))---- Bounded- "Clash.Sized.Internal.Signed.minBound#"- | Just (litTy,mb) <- extractKnownNat tcm tys- -> let minB = negate (2 ^ (mb - 1))- in reduce (mkSignedLit ty litTy mb minB)- "Clash.Sized.Internal.Signed.maxBound#"- | Just (litTy,mb) <- extractKnownNat tcm tys- -> let maxB = (2 ^ (mb - 1)) - 1- in reduce (mkSignedLit ty litTy mb maxB)---- Num- "Clash.Sized.Internal.Signed.+#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftSigned2 (Signed.+#) ty tcm tys args)- -> reduce (val)- "Clash.Sized.Internal.Signed.-#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftSigned2 (Signed.-#) ty tcm tys args)- -> reduce (val)- "Clash.Sized.Internal.Signed.*#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftSigned2 (Signed.*#) ty tcm tys args)- -> reduce (val)- "Clash.Sized.Internal.Signed.negate#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i] <- signedLiterals' args- -> let val = reifyNat kn (op (fromInteger i))- in reduce (mkSignedLit ty nTy kn val)- where- op :: KnownNat n => Signed n -> Proxy n -> Integer- op s _ = toInteger (Signed.negate# s)- "Clash.Sized.Internal.Signed.abs#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i] <- signedLiterals' args- -> let val = reifyNat kn (op (fromInteger i))- in reduce (mkSignedLit ty nTy kn val)- where- op :: KnownNat n => Signed n -> Proxy n -> Integer- op s _ = toInteger (Signed.abs# s)---- ExtendingNum- "Clash.Sized.Internal.Signed.plus#"- | Just (i,j) <- signedLiterals args- -> let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- in reduce (mkSignedLit resTy resSizeTy resSizeInt (i+j))-- "Clash.Sized.Internal.Signed.minus#"- | Just (i,j) <- signedLiterals args- -> let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- in reduce (mkSignedLit resTy resSizeTy resSizeInt (i-j))-- "Clash.Sized.Internal.Signed.times#"- | Just (i,j) <- signedLiterals args- -> let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- in reduce (mkSignedLit resTy resSizeTy resSizeInt (i*j))---- Integral- "Clash.Sized.Internal.Signed.quot#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftSigned2 (Signed.quot#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.Signed.rem#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftSigned2 (Signed.rem#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.Signed.div#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftSigned2 (Signed.div#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.Signed.mod#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftSigned2 (Signed.mod#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.Signed.toInteger#"- | [PrimVal nm' _ _ [_, Lit (IntegerLiteral i)]] <- args- , nm' == "Clash.Sized.Internal.Signed.fromInteger#"- -> reduce (integerToIntegerLiteral i)---- Bits- "Clash.Sized.Internal.Signed.and#"- | [i,j] <- signedLiterals' args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> reduce (mkSignedLit ty nTy kn (i .&. j))- "Clash.Sized.Internal.Signed.or#"- | [i,j] <- signedLiterals' args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> reduce (mkSignedLit ty nTy kn (i .|. j))- "Clash.Sized.Internal.Signed.xor#"- | [i,j] <- signedLiterals' args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> reduce (mkSignedLit ty nTy kn (i `xor` j))-- "Clash.Sized.Internal.Signed.complement#"- | [i] <- signedLiterals' args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> let val = reifyNat kn (op (fromInteger i))- in reduce (mkSignedLit ty nTy kn val)- where- op :: KnownNat n => Signed n -> Proxy n -> Integer- op u _ = toInteger (Signed.complement# u)-- "Clash.Sized.Internal.Signed.shiftL#"- | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args- -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkSignedLit ty nTy kn val)- where- op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Signed.shiftL# u i)- "Clash.Sized.Internal.Signed.shiftR#"- | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args- -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkSignedLit ty nTy kn val)- where- op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Signed.shiftR# u i)- "Clash.Sized.Internal.Signed.rotateL#"- | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args- -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkSignedLit ty nTy kn val)- where- op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Signed.rotateL# u i)- "Clash.Sized.Internal.Signed.rotateR#"- | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args- -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkSignedLit ty nTy kn val)- where- op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Signed.rotateR# u i)---- Resize- "Clash.Sized.Internal.Signed.resize#" -- forall m n. (KnownNat n, KnownNat m) => Signed n -> Signed m- | mTy : nTy : _ <- tys- , Right mInt <- runExcept (tyNatSize tcm mTy)- , Right nInt <- runExcept (tyNatSize tcm nTy)- , [i] <- signedLiterals' args- -> let val | nInt <= mInt = extended- | otherwise = truncated- extended = i- mask = 1 `shiftL` fromInteger (mInt - 1)- i' = i `mod` mask- truncated = if testBit i (fromInteger nInt - 1)- then (i' - mask)- else i'- in reduce (mkSignedLit ty mTy mInt val)- "Clash.Sized.Internal.Signed.truncateB#" -- KnownNat m => Signed (m + n) -> Signed m- | Just (mTy, km) <- extractKnownNat tcm tys- , [i] <- signedLiterals' args- -> let bitsKeep = (bit (fromInteger km)) - 1- val = i .&. bitsKeep- in reduce (mkSignedLit ty mTy km val)---- SaturatingNum--- No need to manually evaluate Clash.Sized.Internal.Signed.minBoundSym#--- It is just implemented in terms of other primitives.----------------- Unsigned------------- "Clash.Sized.Internal.Unsigned.size#"- | Just (_, kn) <- extractKnownNat tcm tys- -> let (_,ty') = splitFunForallTy ty- (TyConApp intTcNm _) = tyView ty'- (Just intTc) = HashMap.lookup (nameOcc intTcNm) tcm- [intCon] = tyConDataCons intTc- in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral kn))])---- BitPack- "Clash.Sized.Internal.Unsigned.pack#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i] <- unsignedLiterals' args- -> reduce (mkBitVectorLit ty nTy kn i)- "Clash.Sized.Internal.Unsigned.unpack#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i] <- bitVectorLiterals' args- -> reduce (mkUnsignedLit ty nTy kn i)---- Eq- "Clash.Sized.Internal.Unsigned.eq#" | Just (i,j) <- unsignedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i == j))- "Clash.Sized.Internal.Unsigned.neq#" | Just (i,j) <- unsignedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i /= j))---- Ord- "Clash.Sized.Internal.Unsigned.lt#" | Just (i,j) <- unsignedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i < j))- "Clash.Sized.Internal.Unsigned.ge#" | Just (i,j) <- unsignedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i >= j))- "Clash.Sized.Internal.Unsigned.gt#" | Just (i,j) <- unsignedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i > j))- "Clash.Sized.Internal.Unsigned.le#" | Just (i,j) <- unsignedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i <= j))---- Bounded- "Clash.Sized.Internal.Unsigned.minBound#"- | Just (nTy,len) <- extractKnownNat tcm tys- -> reduce (mkUnsignedLit ty nTy len 0)- "Clash.Sized.Internal.Unsigned.maxBound#"- | Just (litTy,mb) <- extractKnownNat tcm tys- -> let maxB = (2 ^ mb) - 1- in reduce (mkUnsignedLit ty litTy mb maxB)---- Num- "Clash.Sized.Internal.Unsigned.+#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.+#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.Unsigned.-#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.-#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.Unsigned.*#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.*#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.Unsigned.negate#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i] <- unsignedLiterals' args- -> let val = reifyNat kn (op (fromInteger i))- in reduce (mkUnsignedLit ty nTy kn val)- where- op :: KnownNat n => Unsigned n -> Proxy n -> Integer- op u _ = toInteger (Unsigned.negate# u)---- ExtendingNum- "Clash.Sized.Internal.Unsigned.plus#" -- :: Unsigned m -> Unsigned n -> Unsigned (Max m n + 1)- | Just (i,j) <- unsignedLiterals args- -> let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- in reduce (mkUnsignedLit resTy resSizeTy resSizeInt (i+j))-- "Clash.Sized.Internal.Unsigned.minus#"- | [i,j] <- unsignedLiterals' args- -> let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- val = reifyNat resSizeInt (runSizedF (Unsigned.-#) i j)- in reduce (mkUnsignedLit resTy resSizeTy resSizeInt val)-- "Clash.Sized.Internal.Unsigned.times#"- | Just (i,j) <- unsignedLiterals args- -> let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- in reduce (mkUnsignedLit resTy resSizeTy resSizeInt (i*j))---- Integral- "Clash.Sized.Internal.Unsigned.quot#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.quot#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.Unsigned.rem#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.rem#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.Unsigned.toInteger#"- | [PrimVal nm' _ _ [_, Lit (IntegerLiteral i)]] <- args- , nm' == "Clash.Sized.Internal.Unsigned.fromInteger#"- -> reduce (integerToIntegerLiteral i)---- Bits- "Clash.Sized.Internal.Unsigned.and#"- | Just (i,j) <- unsignedLiterals args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> reduce (mkUnsignedLit ty nTy kn (i .&. j))- "Clash.Sized.Internal.Unsigned.or#"- | Just (i,j) <- unsignedLiterals args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> reduce (mkUnsignedLit ty nTy kn (i .|. j))- "Clash.Sized.Internal.Unsigned.xor#"- | Just (i,j) <- unsignedLiterals args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> reduce (mkUnsignedLit ty nTy kn (i `xor` j))-- "Clash.Sized.Internal.Unsigned.complement#"- | [i] <- unsignedLiterals' args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> let val = reifyNat kn (op (fromInteger i))- in reduce (mkUnsignedLit ty nTy kn val)- where- op :: KnownNat n => Unsigned n -> Proxy n -> Integer- op u _ = toInteger (Unsigned.complement# u)-- "Clash.Sized.Internal.Unsigned.shiftL#" -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n- | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args- -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkUnsignedLit ty nTy kn val)- where- op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Unsigned.shiftL# u i)- "Clash.Sized.Internal.Unsigned.shiftR#" -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n- | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args- -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkUnsignedLit ty nTy kn val)- where- op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Unsigned.shiftR# u i)- "Clash.Sized.Internal.Unsigned.rotateL#" -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n- | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args- -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkUnsignedLit ty nTy kn val)- where- op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Unsigned.rotateL# u i)- "Clash.Sized.Internal.Unsigned.rotateR#" -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n- | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args- -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkUnsignedLit ty nTy kn val)- where- op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Unsigned.rotateR# u i)---- Resize- "Clash.Sized.Internal.Unsigned.resize#" -- forall n m . KnownNat m => Unsigned n -> Unsigned m- | _ : mTy : _ <- tys- , Right km <- runExcept (tyNatSize tcm mTy)- , [i] <- unsignedLiterals' args- -> let bitsKeep = (bit (fromInteger km)) - 1- val = i .&. bitsKeep- in reduce (mkUnsignedLit ty mTy km val)------------- RTree---------- "Clash.Sized.RTree.textract"- | isSubj- , [DC _ tArgs] <- args- -> reduceWHNF (Either.lefts tArgs !! 1)-- "Clash.Sized.RTree.tsplit"- | isSubj- , dTy : aTy : _ <- tys- , [DC _ tArgs] <- args- , (tyArgs,tyView -> TyConApp tupTcNm _) <- splitFunForallTy ty- , TyConApp treeTcNm _ <- tyView (Either.rights tyArgs !! 0)- -> let (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- in reduce $- mkApps (Data tupDc)- [Right (mkTyConApp treeTcNm [dTy,aTy])- ,Right (mkTyConApp treeTcNm [dTy,aTy])- ,Left (Either.lefts tArgs !! 1)- ,Left (Either.lefts tArgs !! 2)- ]-- "Clash.Sized.RTree.tdfold"- | isSubj- , pTy : kTy : aTy : _ <- tys- , _ : p : f : g : ts : _ <- args- , DC _ tArgs <- ts- , Right k' <- runExcept (tyNatSize tcm kTy)- -> case k' of- 0 -> reduceWHNF (mkApps (valToTerm f) [Left (Either.lefts tArgs !! 1)])- _ -> let k'ty = LitTy (NumTy (k'-1))- (tyArgs,_) = splitFunForallTy ty- (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 3)- TyConApp snatTcNm _ = tyView (Either.rights tyArgs' !! 0)- Just snatTc = HashMap.lookup (nameOcc snatTcNm) tcm- [snatDc] = tyConDataCons snatTc- in reduceWHNF $- mkApps (valToTerm g)- [Right k'ty- ,Left (mkApps (Data snatDc)- [Right k'ty- ,Left (Literal (NaturalLiteral (k'-1)))])- ,Left (mkApps (Prim nm ty)- [Right pTy- ,Right k'ty- ,Right aTy- ,Left (Literal (NaturalLiteral (k'-1)))- ,Left (valToTerm p)- ,Left (valToTerm f)- ,Left (valToTerm g)- ,Left (Either.lefts tArgs !! 1)- ])- ,Left (mkApps (Prim nm ty)- [Right pTy- ,Right k'ty- ,Right aTy- ,Left (Literal (NaturalLiteral (k'-1)))- ,Left (valToTerm p)- ,Left (valToTerm f)- ,Left (valToTerm g)- ,Left (Either.lefts tArgs !! 2)- ])- ]-- "Clash.Sized.RTree.treplicate"- | isSubj- , let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys- , (_,tyView -> TyConApp treeTcNm [lenTy,argTy]) <- splitFunForallTy ty'- , Right len <- runExcept (tyNatSize tcm lenTy)- -> let (Just treeTc) = HashMap.lookup (nameOcc treeTcNm) tcm- [lrCon,brCon] = tyConDataCons treeTc- in reduce (mkRTree lrCon brCon argTy len (replicate (2^len) (valToTerm (last args))))-------------- Vector----------- "Clash.Sized.Vector.length"- | isSubj- , [nTy, _] <- tys- , Right n <-runExcept (tyNatSize tcm nTy)- -> let (_, tyView -> TyConApp intTcNm _) = splitFunForallTy ty- (Just intTc) = HashMap.lookup (nameOcc intTcNm) tcm- [intCon] = tyConDataCons intTc- in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral (toInteger n)))])-- "Clash.Sized.Vector.maxIndex"- | isSubj- , [nTy, _] <- tys- , Right n <- runExcept (tyNatSize tcm nTy)- -> let (_, tyView -> TyConApp intTcNm _) = splitFunForallTy ty- (Just intTc) = HashMap.lookup (nameOcc intTcNm) tcm- [intCon] = tyConDataCons intTc- in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral (toInteger (n - 1))))])---- Indexing- "Clash.Sized.Vector.index_int"- | isSubj- , nTy : aTy : _ <- tys- , _ : xs : i : _ <- args- , DC intDc [Left (Literal (IntLiteral i'))] <- i- -> if i' < 0- then Nothing- else case xs of- DC _ vArgs -> case runExcept (tyNatSize tcm nTy) of- Right 0 -> Nothing- Right n' ->- if i' == 0- then reduceWHNF (Either.lefts vArgs !! 1)- else reduceWHNF $- mkApps (Prim nm ty)- [Right (LitTy (NumTy (n'-1)))- ,Right aTy- ,Left (Literal (NaturalLiteral (n'-1)))- ,Left (Either.lefts vArgs !! 2)- ,Left (mkApps (Data intDc)- [Left (Literal (IntLiteral (i'-1)))])- ]- _ -> Nothing- _ -> Nothing- "Clash.Sized.Vector.head"- | isSubj- , [DC _ vArgs] <- args- -> reduceWHNF (Either.lefts vArgs !! 1)- "Clash.Sized.Vector.last"- | isSubj- , [DC _ vArgs] <- args- , (Right _ : Right aTy : Right nTy : _) <- vArgs- , Right n <- runExcept (tyNatSize tcm nTy)- -> if n == 0- then reduceWHNF (Either.lefts vArgs !! 1)- else reduceWHNF- (mkApps (Prim nm ty) [Right (LitTy (NumTy (n-1)))- ,Right aTy- ,Left (Either.lefts vArgs !! 2)- ])--- - Sub-vectors- "Clash.Sized.Vector.tail"- | isSubj- , [DC _ vArgs] <- args- -> reduceWHNF (Either.lefts vArgs !! 2)- "Clash.Sized.Vector.init"- | isSubj- , [DC consCon vArgs] <- args- , (Right _ : Right aTy : Right nTy : _) <- vArgs- , Right n <- runExcept (tyNatSize tcm nTy)- -> if n == 0- then reduceWHNF (Either.lefts vArgs !! 2)- else reduce $- mkVecCons consCon aTy n- (Either.lefts vArgs !! 1)- (mkApps (Prim nm ty) [Right (LitTy (NumTy (n-1)))- ,Right aTy- ,Left (Either.lefts vArgs !! 2)])- "Clash.Sized.Vector.select"- | isSubj- , iTy : sTy : nTy : fTy : aTy : _ <- tys- , eq : f : s : n : xs : _ <- args- , Right n' <- runExcept (tyNatSize tcm nTy)- , Right f' <- runExcept (tyNatSize tcm fTy)- , Right i' <- runExcept (tyNatSize tcm iTy)- , Right s' <- runExcept (tyNatSize tcm sTy)- , DC _ vArgs <- xs- -> case n' of- 0 -> reduce (mkVecNil nilCon aTy)- _ -> case f' of- 0 -> let splitAtCall =- mkApps (Prim "Clash.Sized.Vector.splitAt" (splitAtTy snatTcNm vecTcNm))- [Right sTy- ,Right (LitTy (NumTy (i'-s')))- ,Right aTy- ,Left (valToTerm s)- ,Left (valToTerm xs)- ]- fVecTy = mkTyConApp vecTcNm [sTy,aTy]- iVecTy = mkTyConApp vecTcNm [LitTy (NumTy (i'-s')),aTy]- fNm = string2SystemName "fxs"- iNm = string2SystemName "ixs"- fId = Id fNm (embed fVecTy)- iId = Id iNm (embed iVecTy)- tupPat = (DataPat (embed tupDc) (rebind [] [fId,iId]))- iAlt = bind tupPat (Var iVecTy iNm)- in reduce $- mkVecCons consCon aTy n' (Either.lefts vArgs !! 1) $- mkApps (Prim nm ty)- [Right (LitTy (NumTy (i'-s')))- ,Right sTy- ,Right (LitTy (NumTy (n'-1)))- ,Right (LitTy (NumTy 0))- ,Right aTy- ,Left (valToTerm eq)- ,Left (Literal (NaturalLiteral 0))- ,Left (valToTerm s)- ,Left (Literal (NaturalLiteral (n'-1)))- ,Left (Case splitAtCall iVecTy [iAlt])- ]- _ -> let splitAtCall =- mkApps (Prim "Clash.Sized.Vector.splitAt" (splitAtTy snatTcNm vecTcNm))- [Right fTy- ,Right iTy- ,Right aTy- ,Left (valToTerm f)- ,Left (valToTerm xs)- ]- fVecTy = mkTyConApp vecTcNm [fTy,aTy]- iVecTy = mkTyConApp vecTcNm [iTy,aTy]- fNm = string2SystemName "fxs"- iNm = string2SystemName "ixs"- fId = Id fNm (embed fVecTy)- iId = Id iNm (embed iVecTy)- tupPat = (DataPat (embed tupDc) (rebind [] [fId,iId]))- iAlt = bind tupPat (Var iVecTy iNm)- in reduceWHNF $- mkApps (Prim nm ty)- [Right iTy- ,Right sTy- ,Right nTy- ,Right (LitTy (NumTy 0))- ,Right aTy- ,Left (valToTerm eq)- ,Left (Literal (NaturalLiteral 0))- ,Left (valToTerm s)- ,Left (valToTerm n)- ,Left (Case splitAtCall iVecTy [iAlt])- ]- where- (tyArgs,tyView -> TyConApp vecTcNm _) = splitFunForallTy ty- Just vecTc = HashMap.lookup (nameOcc vecTcNm) tcm- [nilCon,consCon] = tyConDataCons vecTc- TyConApp snatTcNm _ = tyView (Either.rights tyArgs !! 1)- tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc--- - Splitting- "Clash.Sized.Vector.splitAt"- | isSubj- , DC snatDc (Right mTy:_) <- head args- , Right m <- runExcept (tyNatSize tcm mTy)- -> let _:nTy:aTy:_ = tys- -- Get the tuple data-constructor- (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- -- Get the vector data-constructors- TyConApp vecTcNm _ = tyView (head tyArgs)- Just vecTc = HashMap.lookup (nameOcc vecTcNm) tcm- [nilCon,consCon] = tyConDataCons vecTc- -- Recursive call to @splitAt@- splitAtRec v =- mkApps (Prim nm ty)- [Right (LitTy (NumTy (m-1)))- ,Right nTy- ,Right aTy- ,Left (mkApps (Data snatDc)- [ Right (LitTy (NumTy (m-1)))- , Left (Literal (NaturalLiteral (m-1)))])- ,Left v- ]- -- Projection either the first or second field of the recursive- -- call to @splitAt@- splitAtSelR v = Case (splitAtRec v) (last tyArgs)- m1VecTy = mkTyConApp vecTcNm [LitTy (NumTy (m-1)),aTy]- nVecTy = mkTyConApp vecTcNm [nTy,aTy]- lNm = string2SystemName "l"- rNm = string2SystemName "r"- lId = Id lNm (embed m1VecTy)- rId = Id rNm (embed nVecTy)- tupPat = (DataPat (embed tupDc) (rebind [] [lId,rId]))- lAlt = bind tupPat (Var m1VecTy lNm)- rAlt = bind tupPat (Var nVecTy rNm)-- in case m of- -- (Nil,v)- 0 -> reduce $- mkApps (Data tupDc) $ (map Right tyArgs) ++- [ Left (mkVecNil nilCon aTy)- , Left (valToTerm (last args))- ]- -- (x:xs) <- v- m' | DC _ vArgs <- last args- -- (x:fst (splitAt (m-1) xs),snd (splitAt (m-1) xs))- -> reduce $- mkApps (Data tupDc) $ (map Right tyArgs) ++- [ Left (mkVecCons consCon aTy m' (Either.lefts vArgs !! 1)- (splitAtSelR (Either.lefts vArgs !! 2) [lAlt]))- , Left (splitAtSelR (Either.lefts vArgs !! 2) [rAlt])- ]- -- v doesn't reduce to a data-constructor- _ -> Nothing-- "Clash.Sized.Vector.unconcat"- | isSubj- , kn : snat : v : _ <- args- , nTy : mTy : aTy :_ <- tys- , Lit (NaturalLiteral n) <- kn- -> let ( Either.rights -> argTys, tyView -> TyConApp vecTcNm _) =- splitFunForallTy ty- Just vecTc = HashMap.lookup (nameOcc vecTcNm) tcm- [nilCon,consCon] = tyConDataCons vecTc- tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- TyConApp snatTcNm _ = tyView (argTys !! 1)- n1mTy = mkTyConApp typeNatMul- [mkTyConApp typeNatSub [nTy,LitTy (NumTy 1)]- ,mTy]- splitAtCall =- mkApps (Prim "Clash.Sized.Vector.splitAt" (splitAtTy snatTcNm vecTcNm))- [Right mTy- ,Right n1mTy- ,Right aTy- ,Left (valToTerm snat)- ,Left (valToTerm v)- ]- mVecTy = mkTyConApp vecTcNm [mTy,aTy]- n1mVecTy = mkTyConApp vecTcNm [n1mTy,aTy]- asNm = string2SystemName "as"- bsNm = string2SystemName "bs"- asId = Id asNm (embed mVecTy)- bsId = Id bsNm (embed n1mVecTy)- tupPat = (DataPat (embed tupDc) (rebind [] [asId,bsId]))- asAlt = bind tupPat (Var mVecTy asNm)- bsAlt = bind tupPat (Var n1mVecTy bsNm)-- in case n of- 0 -> reduce (mkVecNil nilCon mVecTy)- _ -> reduce $- mkVecCons consCon mVecTy n- (Case splitAtCall mVecTy [asAlt])- (mkApps (Prim nm ty)- [Right (LitTy (NumTy (n-1)))- ,Right mTy- ,Right aTy- ,Left (Literal (NaturalLiteral (n-1)))- ,Left (valToTerm snat)- ,Left (Case splitAtCall n1mVecTy [bsAlt])])--- Construction--- - initialisation- "Clash.Sized.Vector.replicate"- | isSubj- , let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys- , let (_,resTy) = splitFunForallTy ty'- , (TyConApp vecTcNm [lenTy,argTy]) <- tyView resTy- , Right len <- runExcept (tyNatSize tcm lenTy)- -> let (Just vecTc) = HashMap.lookup (nameOcc vecTcNm) tcm- [nilCon,consCon] = tyConDataCons vecTc- in reduce $- mkVec nilCon consCon argTy len- (replicate (fromInteger len) (valToTerm (last args)))--- - Concatenation- "Clash.Sized.Vector.++"- | isSubj- , DC dc vArgs <- head args- , Right nTy : Right aTy : _ <- vArgs- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduce (valToTerm (last args))- n' | (_ : _ : mTy : _) <- tys- , Right m <- runExcept (tyNatSize tcm mTy)- -> -- x : (xs ++ ys)- reduce $- mkVecCons dc aTy (n' + m) (Either.lefts vArgs !! 1)- (mkApps (Prim nm ty) [Right (LitTy (NumTy (n'-1)))- ,Right aTy- ,Right mTy- ,Left (Either.lefts vArgs !! 2)- ,Left (valToTerm (last args))- ])- _ -> Nothing- "Clash.Sized.Vector.concat"- | isSubj- , (nTy : mTy : aTy : _) <- tys- , (xs : _) <- args- , DC dc vArgs <- xs- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduce (mkVecNil dc aTy)- _ | _ : h' : t : _ <- Either.lefts vArgs- , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty- -> reduceWHNF $- mkApps (Prim "Clash.Sized.Vector.++" (vecAppendTy vecTcNm))- [Right mTy- ,Right aTy- ,Right $ mkTyConApp typeNatMul- [mkTyConApp typeNatSub [nTy,LitTy (NumTy 1)], mTy]- ,Left h'- ,Left $ mkApps (Prim nm ty)- [ Right (LitTy (NumTy (n-1)))- , Right mTy- , Right aTy- , Left t- ]- ]- _ -> Nothing---- Modifying vectors- "Clash.Sized.Vector.replace_int"- | isSubj- , nTy : aTy : _ <- tys- , _ : xs : i : a : _ <- args- , DC intDc [Left (Literal (IntLiteral i'))] <- i- -> if i' < 0- then Nothing- else case xs of- DC vecTcNm vArgs -> case runExcept (tyNatSize tcm nTy) of- Right 0 -> Nothing- Right n' ->- if i' == 0- then reduce (mkVecCons vecTcNm aTy n' (valToTerm a) (Either.lefts vArgs !! 2))- else reduce $- mkVecCons vecTcNm aTy n' (Either.lefts vArgs !! 1)- (mkApps (Prim nm ty)- [Right (LitTy (NumTy (n'-1)))- ,Right aTy- ,Left (Literal (NaturalLiteral (n'-1)))- ,Left (Either.lefts vArgs !! 2)- ,Left (mkApps (Data intDc)- [Left (Literal (IntLiteral (i'-1)))])- ,Left (valToTerm a)- ])- _ -> Nothing- _ -> Nothing---- - specialised permutations- "Clash.Sized.Vector.reverse"- | isSubj- , nTy : aTy : _ <- tys- , [DC vecDc vArgs] <- args- -> case runExcept (tyNatSize tcm nTy) of- Right 0 -> reduce (mkVecNil vecDc aTy)- Right n- | (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty- , let (Just vecTc) = HashMap.lookup (nameOcc vecTcNm) tcm- , let [nilCon,consCon] = tyConDataCons vecTc- -> reduceWHNF $- mkApps (Prim "Clash.Sized.Vector.++" (vecAppendTy vecTcNm))- [Right (LitTy (NumTy (n-1)))- ,Right aTy- ,Right (LitTy (NumTy 1))- ,Left (mkApps (Prim nm ty)- [Right (LitTy (NumTy (n-1)))- ,Right aTy- ,Left (Either.lefts vArgs !! 2)- ])- ,Left (mkVec nilCon consCon aTy 1 [Either.lefts vArgs !! 1])- ]- _ -> Nothing- "Clash.Sized.Vector.transpose" -- :: KnownNat n => Vec m (Vec n a) -> Vec n (Vec m a)- | isSubj- , nTy : mTy : aTy : _ <- tys- , kn : xss : _ <- args- , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty- , DC _ vArgs <- xss- , Right n <- runExcept (tyNatSize tcm nTy)- , Right m <- runExcept (tyNatSize tcm mTy)- -> case m of- 0 -> let (Just vecTc) = HashMap.lookup (nameOcc vecTcNm) tcm- [nilCon,consCon] = tyConDataCons vecTc- in reduce $- mkVec nilCon consCon (mkTyConApp vecTcNm [mTy,aTy]) n- (replicate (fromInteger n) (mkVec nilCon consCon aTy 0 []))- m' -> let (Just vecTc) = HashMap.lookup (nameOcc vecTcNm) tcm- [_,consCon] = tyConDataCons vecTc- Just (consCoTy : _) = dataConInstArgTys consCon- [mTy,aTy,LitTy (NumTy (m'-1))]- in reduceWHNF $- mkApps (Prim "Clash.Sized.Vector.zipWith" (vecZipWithTy vecTcNm))- [ Right aTy- , Right (mkTyConApp vecTcNm [LitTy (NumTy (m'-1)),aTy])- , Right (mkTyConApp vecTcNm [mTy,aTy])- , Right nTy- , Left (mkApps (Data consCon)- [Right mTy- ,Right aTy- ,Right (LitTy (NumTy (m'-1)))- ,Left (Prim "_CO_" consCoTy)- ])- , Left (Either.lefts vArgs !! 1)- , Left (mkApps (Prim nm ty)- [ Right nTy- , Right (LitTy (NumTy (m'-1)))- , Right aTy- , Left (valToTerm kn)- , Left (Either.lefts vArgs !! 2)- ])- ]- "Clash.Sized.Vector.rotateLeftS"- | isSubj- , nTy : aTy : _ : _ <- tys- , kn : xs : d : _ <- args- , DC dc vArgs <- xs- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduce (mkVecNil dc aTy)- n' | DC snatDc [_,Left d'] <- d- , (h2,[],Literal (NaturalLiteral d2)) <- whnf reduceConstant gbl tcm isSubj (h,[],d')- -> case (d2 `mod` n) of- 0 -> reduce (valToTerm xs)- d3 -> let (_,tyView -> TyConApp vecTcNm _) = splitFunForallTy ty- (Just vecTc) = HashMap.lookup (nameOcc vecTcNm) tcm- [nilCon,consCon] = tyConDataCons vecTc- in reduceWHNF' h2 $- mkApps (Prim nm ty)- [Right nTy- ,Right aTy- ,Right (LitTy (NumTy (d3-1)))- ,Left (valToTerm kn)- ,Left (mkApps (Prim "Clash.Sized.Vector.++" (vecAppendTy vecTcNm))- [Right (LitTy (NumTy (n'-1)))- ,Right aTy- ,Right (LitTy (NumTy 1))- ,Left (Either.lefts vArgs !! 2)- ,Left (mkVec nilCon consCon aTy 1 [Either.lefts vArgs !! 1])])- ,Left (mkApps (Data snatDc)- [Right (LitTy (NumTy (d3-1)))- ,Left (Literal (NaturalLiteral (d3-1)))])- ]- _ -> Nothing- "Clash.Sized.Vector.rotateRightS"- | isSubj- , nTy : aTy : _ : _ <- tys- , kn : xs : d : _ <- args- , DC dc _ <- xs- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduce (mkVecNil dc aTy)- n' | DC snatDc [_,Left d'] <- d- , (h2,[],Literal (NaturalLiteral d2)) <- whnf reduceConstant gbl tcm isSubj (h,[],d')- -> case (d2 `mod` n) of- 0 -> reduce (valToTerm xs)- d3 -> let (_,tyView -> TyConApp vecTcNm _) = splitFunForallTy ty- in reduceWHNF' h2 $- mkApps (Prim nm ty)- [Right nTy- ,Right aTy- ,Right (LitTy (NumTy (d3-1)))- ,Left (valToTerm kn)- ,Left (mkVecCons dc aTy n- (mkApps (Prim "Clash.Sized.Vector.last" (vecHeadTy vecTcNm))- [Right (LitTy (NumTy (n'-1)))- ,Right aTy- ,Left (valToTerm xs)])- (mkApps (Prim "Clash.Sized.Vector.init" (vecTailTy vecTcNm))- [Right (LitTy (NumTy (n'-1)))- ,Right aTy- ,Left (valToTerm xs)]))- ,Left (mkApps (Data snatDc)- [Right (LitTy (NumTy (d3-1)))- ,Left (Literal (NaturalLiteral (d3-1)))])- ]- _ -> Nothing--- Element-wise operations--- - mapping- "Clash.Sized.Vector.map"- | isSubj- , DC dc vArgs <- args !! 1- , aTy : bTy : nTy : _ <- tys- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduce (mkVecNil dc bTy)- n' -> reduce $- mkVecCons dc bTy n'- (mkApps (valToTerm (args !! 0)) [Left (Either.lefts vArgs !! 1)])- (mkApps (Prim nm ty) [Right aTy- ,Right bTy- ,Right (LitTy (NumTy (n' - 1)))- ,Left (valToTerm (args !! 0))- ,Left (Either.lefts vArgs !! 2)])- "Clash.Sized.Vector.imap"- | isSubj- , nTy : aTy : bTy : _ <- tys- , (tyArgs,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty- , let (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 1)- , TyConApp indexTcNm _ <- tyView (Either.rights tyArgs' !! 0)- , Right n <- runExcept (tyNatSize tcm nTy)- , Just iLit <- mkIndexLit (Either.rights tyArgs' !! 0) nTy n 0- -> reduceWHNF $- mkApps (Prim "Clash.Sized.Vector.imap_go" (vecImapGoTy vecTcNm indexTcNm))- [Right nTy- ,Right nTy- ,Right aTy- ,Right bTy- ,Left iLit- ,Left (valToTerm (args !! 1))- ,Left (valToTerm (args !! 2))- ]-- "Clash.Sized.Vector.imap_go"- | isSubj- , nTy : mTy : aTy : bTy : _ <- tys- , n : f : xs : _ <- args- , DC dc vArgs <- xs- , Right n' <- runExcept (tyNatSize tcm nTy)- , Right m <- runExcept (tyNatSize tcm mTy)- -> case m of- 0 -> reduce (mkVecNil dc bTy)- m' -> let (tyArgs,_) = splitFunForallTy ty- TyConApp indexTcNm _ = tyView (Either.rights tyArgs !! 0)- Just iLit = mkIndexLit (Either.rights tyArgs !! 0) nTy n' 1- in reduce $ mkVecCons dc bTy m'- (mkApps (valToTerm f) [Left (valToTerm n),Left (Either.lefts vArgs !! 1)])- (mkApps (Prim nm ty)- [Right nTy- ,Right (LitTy (NumTy (m'-1)))- ,Right aTy- ,Right bTy- ,Left (mkApps (Prim "Clash.Sized.Internal.Index.+#" (indexAddTy indexTcNm))- [Right nTy- ,Left (Literal (NaturalLiteral n'))- ,Left (valToTerm n)- ,Left iLit- ])- ,Left (valToTerm f)- ,Left (Either.lefts vArgs !! 2)- ])---- - Zipping- "Clash.Sized.Vector.zipWith"- | isSubj- , aTy : bTy : cTy : nTy : _ <- tys- , f : xs : ys : _ <- args- , DC dc vArgs <- xs- , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduce (mkVecNil dc cTy)- n' -> reduce $ mkVecCons dc cTy n'- (mkApps (valToTerm f)- [Left (Either.lefts vArgs !! 1)- ,Left (mkApps (Prim "Clash.Sized.Vector.head" (vecHeadTy vecTcNm))- [Right (LitTy (NumTy (n'-1)))- ,Right bTy- ,Left (valToTerm ys)- ])- ])- (mkApps (Prim nm ty) [Right aTy- ,Right bTy- ,Right cTy- ,Right (LitTy (NumTy (n' - 1)))- ,Left (valToTerm f)- ,Left (Either.lefts vArgs !! 2)- ,Left (mkApps (Prim "Clash.Sized.Vector.tail" (vecTailTy vecTcNm))- [Right (LitTy (NumTy (n'-1)))- ,Right bTy- ,Left (valToTerm ys)- ])])---- Folding- "Clash.Sized.Vector.foldr"- | isSubj- , aTy : bTy : nTy : _ <- tys- , f : z : xs : _ <- args- , DC _ vArgs <- xs- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduce (valToTerm z)- _ -> reduceWHNF $- mkApps (valToTerm f)- [Left (Either.lefts vArgs !! 1)- ,Left (mkApps (Prim nm ty)- [Right aTy- ,Right bTy- ,Right (LitTy (NumTy (n-1)))- ,Left (valToTerm f)- ,Left (valToTerm z)- ,Left (Either.lefts vArgs !! 2)- ])- ]- "Clash.Sized.Vector.fold"- | isSubj- , aTy : nTy : _ <- tys- , f : vs : _ <- args- , DC _ vArgs <- vs- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduceWHNF (Either.lefts vArgs !! 1)- _ -> let (tyArgs,_) = splitFunForallTy ty- TyConApp vecTcNm _ = tyView (Either.rights tyArgs !! 1)- tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- n' = n+1- m = n' `div` 2- n1 = n' - m- mTy = LitTy (NumTy m)- m'ty = LitTy (NumTy (m-1))- n1mTy = LitTy (NumTy n1)- n1m'ty = LitTy (NumTy (n1-1))- splitAtCall =- mkApps (Prim "Clash.Sized.Vector.fold_split" (foldSplitAtTy vecTcNm))- [Right mTy- ,Right n1mTy- ,Right aTy- ,Left (Literal (NaturalLiteral m))- ,Left (valToTerm vs)- ]- mVecTy = mkTyConApp vecTcNm [mTy,aTy]- n1mVecTy = mkTyConApp vecTcNm [n1mTy,aTy]- asNm = string2SystemName "as"- bsNm = string2SystemName "bs"- asId = Id asNm (embed mVecTy)- bsId = Id bsNm (embed n1mVecTy)- tupPat = (DataPat (embed tupDc) (rebind [] [asId,bsId]))- asAlt = bind tupPat (Var mVecTy asNm)- bsAlt = bind tupPat (Var n1mVecTy bsNm)- in reduceWHNF $- mkApps (valToTerm f)- [Left (mkApps (Prim nm ty)- [Right aTy- ,Right m'ty- ,Left (valToTerm f)- ,Left (Case splitAtCall mVecTy [asAlt])- ])- ,Left (mkApps (Prim nm ty)- [Right aTy- ,Right n1m'ty- ,Left (valToTerm f)- ,Left (Case splitAtCall n1mVecTy [bsAlt])- ])- ]--- "Clash.Sized.Vector.fold_split"- | isSubj- , mTy : nTy : aTy : _ <- tys- , Right m <- runExcept (tyNatSize tcm mTy)- -> let -- Get the tuple data-constructor- (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- -- Get the vector data-constructors- TyConApp vecTcNm _ = tyView (head tyArgs)- Just vecTc = HashMap.lookup (nameOcc vecTcNm) tcm- [nilCon,consCon] = tyConDataCons vecTc- -- Recursive call to @splitAt@- splitAtRec v =- mkApps (Prim nm ty)- [Right (LitTy (NumTy (m-1)))- ,Right nTy- ,Right aTy- ,Left (Literal (NaturalLiteral (m-1)))- ,Left v- ]- -- Projection either the first or second field of the recursive- -- call to @splitAt@- splitAtSelR v = Case (splitAtRec v) (last tyArgs)- m1VecTy = mkTyConApp vecTcNm [LitTy (NumTy (m-1)),aTy]- nVecTy = mkTyConApp vecTcNm [nTy,aTy]- lNm = string2SystemName "l"- rNm = string2SystemName "r"- lId = Id lNm (embed m1VecTy)- rId = Id rNm (embed nVecTy)- tupPat = (DataPat (embed tupDc) (rebind [] [lId,rId]))- lAlt = bind tupPat (Var m1VecTy lNm)- rAlt = bind tupPat (Var nVecTy rNm)- in case m of- -- (Nil,v)- 0 -> reduce $- mkApps (Data tupDc) $ (map Right tyArgs) ++- [ Left (mkVecNil nilCon aTy)- , Left (valToTerm (last args))- ]- -- (x:xs) <- v- m' | DC _ vArgs <- last args- -- (x:fst (splitAt (m-1) xs),snd (splitAt (m-1) xs))- -> reduce $- mkApps (Data tupDc) $ (map Right tyArgs) ++- [ Left (mkVecCons consCon aTy m' (Either.lefts vArgs !! 1)- (splitAtSelR (Either.lefts vArgs !! 2) [lAlt]))- , Left (splitAtSelR (Either.lefts vArgs !! 2) [rAlt])- ]- -- v doesn't reduce to a data-constructor- _ -> Nothing--- - Specialised folds- "Clash.Sized.Vector.dfold"- | isSubj- , pTy : kTy : aTy : _ <- tys- , _ : p : f : z : xs : _ <- args- , DC _ vArgs <- xs- , Right k' <- runExcept (tyNatSize tcm kTy)- -> case k' of- 0 -> reduce (valToTerm z)- _ -> let (tyArgs,_) = splitFunForallTy ty- (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 2)- TyConApp snatTcNm _ = tyView (Either.rights tyArgs' !! 0)- Just snatTc = HashMap.lookup (nameOcc snatTcNm) tcm- [snatDc] = tyConDataCons snatTc- k'ty = LitTy (NumTy (k'-1))- in reduceWHNF $- mkApps (valToTerm f)- [Right k'ty- ,Left (mkApps (Data snatDc)- [Right k'ty- ,Left (Literal (NaturalLiteral (k'-1)))])- ,Left (Either.lefts vArgs !! 1)- ,Left (mkApps (Prim nm ty)- [Right pTy- ,Right k'ty- ,Right aTy- ,Left (Literal (NaturalLiteral (k'-1)))- ,Left (valToTerm p)- ,Left (valToTerm f)- ,Left (valToTerm z)- ,Left (Either.lefts vArgs !! 2)- ])- ]- "Clash.Sized.Vector.dtfold"- | isSubj- , pTy : kTy : aTy : _ <- tys- , _ : p : f : g : xs : _ <- args- , DC _ vArgs <- xs- , Right k' <- runExcept (tyNatSize tcm kTy)- -> case k' of- 0 -> reduceWHNF (mkApps (valToTerm f) [Left (Either.lefts vArgs !! 1)])- _ -> let (tyArgs,_) = splitFunForallTy ty- TyConApp vecTcNm _ = tyView (Either.rights tyArgs !! 4)- (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 3)- TyConApp snatTcNm _ = tyView (Either.rights tyArgs' !! 0)- Just snatTc = HashMap.lookup (nameOcc snatTcNm) tcm- [snatDc] = tyConDataCons snatTc- tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)- (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- k'ty = LitTy (NumTy (k'-1))- k2ty = LitTy (NumTy (2^(k'-1)))- splitAtCall =- mkApps (Prim "Clash.Sized.Vector.splitAt" (splitAtTy snatTcNm vecTcNm))- [Right k2ty- ,Right k2ty- ,Right aTy- ,Left (mkApps (Data snatDc)- [Right k2ty- ,Left (Literal (NaturalLiteral (2^(k'-1))))])- ,Left (valToTerm xs)- ]- xsSVecTy = mkTyConApp vecTcNm [k2ty,aTy]- xsLNm = string2SystemName "xsL"- xsRNm = string2SystemName "xsR"- xsLId = Id xsLNm (embed k2ty)- xsRId = Id xsRNm (embed k2ty)- tupPat = (DataPat (embed tupDc) (rebind [] [xsLId,xsRId]))- asAlt = bind tupPat (Var k2ty xsLNm)- bsAlt = bind tupPat (Var k2ty xsRNm)- in reduceWHNF $- mkApps (valToTerm g)- [Right k'ty- ,Left (mkApps (Data snatDc)- [Right k'ty- ,Left (Literal (NaturalLiteral (k'-1)))])- ,Left (mkApps (Prim nm ty)- [Right pTy- ,Right k'ty- ,Right aTy- ,Left (Literal (NaturalLiteral (k'-1)))- ,Left (valToTerm p)- ,Left (valToTerm f)- ,Left (valToTerm g)- ,Left (Case splitAtCall xsSVecTy [asAlt])])- ,Left (mkApps (Prim nm ty)- [Right pTy- ,Right k'ty- ,Right aTy- ,Left (Literal (NaturalLiteral (k'-1)))- ,Left (valToTerm p)- ,Left (valToTerm f)- ,Left (valToTerm g)- ,Left (Case splitAtCall xsSVecTy [bsAlt])])- ]--- Misc- "Clash.Sized.Vector.lazyV"- | isSubj- , nTy : aTy : _ <- tys- , _ : xs : _ <- args- , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> let (Just vecTc) = HashMap.lookup (nameOcc vecTcNm) tcm- [nilCon,_] = tyConDataCons vecTc- in reduce (mkVecNil nilCon aTy)- n' -> let (Just vecTc) = HashMap.lookup (nameOcc vecTcNm) tcm- [_,consCon] = tyConDataCons vecTc- in reduce $ mkVecCons consCon aTy n'- (mkApps (Prim "Clash.Sized.Vector.head" (vecHeadTy vecTcNm))- [ Right (LitTy (NumTy (n' - 1)))- , Right aTy- , Left (valToTerm xs)- ])- (mkApps (Prim nm ty)- [ Right (LitTy (NumTy (n' - 1)))- , Right aTy- , Left (Literal (NaturalLiteral (n'-1)))- , Left (mkApps (Prim "Clash.Sized.Vector.tail" (vecTailTy vecTcNm))- [ Right (LitTy (NumTy (n'-1)))- , Right aTy- , Left (valToTerm xs)- ])- ])--- Traversable- "Clash.Sized.Vector.traverse#"- | isSubj- , aTy : fTy : bTy : nTy : _ <- tys- , apDict : f : xs : _ <- args- , DC dc vArgs <- xs- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> let (pureF,ids') = runPEM (mkSelectorCase $(curLoc) tcm (valToTerm apDict) 1 1) ids- in reduceWHNF' (Heap gh h' ids') $- mkApps pureF- [Right (mkTyConApp (vecTcNm) [nTy,bTy])- ,Left (mkVecNil dc bTy)]- _ -> let ((fmapF,apF),ids') = flip runPEM ids $ do- fDict <- mkSelectorCase $(curLoc) tcm (valToTerm apDict) 1 0- fmapF' <- mkSelectorCase $(curLoc) tcm fDict 1 0- apF' <- mkSelectorCase $(curLoc) tcm (valToTerm apDict) 1 2- return (fmapF',apF')- n'ty = LitTy (NumTy (n-1))- Just (consCoTy : _) = dataConInstArgTys dc [nTy,bTy,n'ty]- in reduceWHNF' (Heap gh h' ids') $- mkApps apF- [Right (mkTyConApp vecTcNm [n'ty,bTy])- ,Right (mkTyConApp vecTcNm [nTy,bTy])- ,Left (mkApps fmapF- [Right bTy- ,Right (mkFunTy (mkTyConApp vecTcNm [n'ty,bTy])- (mkTyConApp vecTcNm [nTy,bTy]))- ,Left (mkApps (Data dc)- [Right nTy- ,Right bTy- ,Right n'ty- ,Left (Prim "_CO_" consCoTy)])- ,Left (mkApps (valToTerm f)- [Left (Either.lefts vArgs !! 1)])- ])- ,Left (mkApps (Prim nm ty)- [Right aTy- ,Right fTy- ,Right bTy- ,Right n'ty- ,Left (valToTerm apDict)- ,Left (valToTerm f)- ,Left (Either.lefts vArgs !! 2)- ])- ]- where- (tyArgs,_) = splitFunForallTy ty- TyConApp vecTcNm _ = tyView (Either.rights tyArgs !! 2)- Heap gh h' ids = h---- BitPack- "Clash.Sized.Vector.concatBitVector#"- | isSubj- , nTy : mTy : _ <- tys- , _ : km : v : _ <- args- , DC _ vArgs <- v- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> let resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkBitVectorLit' resTyInfo 0)- n' | Right m <- runExcept (tyNatSize tcm mTy)- , (_,tyView -> TyConApp bvTcNm _) <- splitFunForallTy ty- -> reduceWHNF $- mkApps (Prim "Clash.Sized.Internal.BitVector.++#" (bvAppendTy bvTcNm))- [ Right (mkTyConApp typeNatMul [LitTy (NumTy (n'-1)),mTy])- , Right mTy- , Left (Literal (NaturalLiteral ((n'-1)*m)))- , Left (Either.lefts vArgs !! 1)- , Left (mkApps (Prim nm ty)- [ Right (LitTy (NumTy (n'-1)))- , Right mTy- , Left (Literal (NaturalLiteral (n'-1)))- , Left (valToTerm km)- , Left (Either.lefts vArgs !! 2)- ])- ]- _ -> Nothing- "Clash.Sized.Vector.unconcatBitVector#"- | isSubj- , nTy : mTy : _ <- tys- , _ : km : bv : _ <- args- , (_,tyView -> TyConApp vecTcNm [_,bvMTy]) <- splitFunForallTy ty- , TyConApp bvTcNm _ <- tyView bvMTy- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 ->- let (Just vecTc) = HashMap.lookup (nameOcc vecTcNm) tcm- [nilCon,_] = tyConDataCons vecTc- in reduce (mkVecNil nilCon (mkTyConApp bvTcNm [mTy]))- n' | Right m <- runExcept (tyNatSize tcm mTy) ->- let Just vecTc = HashMap.lookup (nameOcc vecTcNm) tcm- [_,consCon] = tyConDataCons vecTc- tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)- Just tupTc = HashMap.lookup (nameOcc tupTcNm) tcm- [tupDc] = tyConDataCons tupTc- splitCall =- mkApps (Prim "Clash.Sized.Internal.BitVector.split#"- (bvSplitTy bvTcNm))- [ Right (mkTyConApp typeNatMul [LitTy (NumTy (n'-1)),mTy])- , Right mTy- , Left (Literal (NaturalLiteral ((n'-1)*m)))- , Left (valToTerm bv)- ]- mBVTy = mkTyConApp bvTcNm [mTy]- n1BVTy = mkTyConApp bvTcNm- [mkTyConApp typeNatMul- [LitTy (NumTy (n'-1))- ,mTy]]- xNm = string2SystemName "x"- bvNm = string2SystemName "bv'"- xId = Id xNm (embed mBVTy)- bvId = Id bvNm (embed n1BVTy)- tupPat = DataPat (embed tupDc) (rebind [] [xId,bvId])- xAlt = bind tupPat (Var mBVTy xNm)- bvAlt = bind tupPat (Var n1BVTy bvNm)-- in reduce $ mkVecCons consCon (mkTyConApp bvTcNm [mTy]) n'- (Case splitCall mBVTy [xAlt])- (mkApps (Prim nm ty)- [ Right (LitTy (NumTy (n'-1)))- , Right mTy- , Left (Literal (NaturalLiteral (n'-1)))- , Left (valToTerm km)- , Left (Case splitCall n1BVTy [bvAlt])- ])- _ -> Nothing- _ -> Nothing- where- reduce = Just . (h,k,)- reduceWHNF e = let (h2,[],e') = whnf reduceConstant gbl tcm isSubj (h,[],e)- in Just (h2,k,e')- reduceWHNF' h' e = let (h2,[],e') = whnf reduceConstant gbl tcm isSubj (h',[],e)- in Just (h2,k,e')--typedLiterals' :: (Value -> Maybe a) -> [Value] -> [a]-typedLiterals' typedLiteral = mapMaybe typedLiteral--doubleLiterals' :: [Value] -> [Rational]-doubleLiterals' = typedLiterals' doubleLiteral- where- doubleLiteral x = case x of- Lit (DoubleLiteral i) -> Just i- _ -> Nothing--floatLiterals' :: [Value] -> [Rational]-floatLiterals' = typedLiterals' floatLiteral- where- floatLiteral x = case x of- Lit (FloatLiteral i) -> Just i- _ -> Nothing--integerLiterals :: [Value] -> Maybe (Integer,Integer)-integerLiterals args = case integerLiterals' args of- [i,j] -> Just (i,j)- _ -> Nothing--integerLiterals' :: [Value] -> [Integer]-integerLiterals' = typedLiterals' integerLiteral- where- integerLiteral x = case x of- Lit (IntegerLiteral i) -> Just i- DC dc [Left (Literal (IntLiteral i))]- | dcTag dc == 1- -> Just i- DC dc [Left (Literal (ByteArrayLiteral (Vector.Vector _ _ (ByteArray.ByteArray ba))))]- | dcTag dc == 2- -> Just (Jp# (BN# ba))- | dcTag dc == 3- -> Just (Jn# (BN# ba))- _ -> Nothing--intLiterals :: [Value] -> Maybe (Integer,Integer)-intLiterals args = case args of- [Lit (IntLiteral i), Lit (IntLiteral j)] -> Just (i,j)- _ -> Nothing--intLiterals' :: [Value] -> [Integer]-intLiterals' = typedLiterals' intLiteral- where- intLiteral x = case x of- Lit (IntLiteral i) -> Just i- _ -> Nothing--intCLiterals :: [Value] -> Maybe (Integer,Integer)-intCLiterals args = case args of- ([DC _ [Left (Literal (IntLiteral i))]- ,DC _ [Left (Literal (IntLiteral j))]])- -> Just (i,j)- _ -> Nothing--wordLiterals :: [Value] -> Maybe (Integer,Integer)-wordLiterals args = case args of- [Lit (WordLiteral i), Lit (WordLiteral j)] -> Just (i,j)- _ -> Nothing-wordLiterals' :: [Value] -> [Integer]-wordLiterals' = typedLiterals' wordLiteral- where- wordLiteral x = case x of- Lit (WordLiteral i) -> Just i- _ -> Nothing--charLiterals :: [Value] -> Maybe (Char,Char)-charLiterals args = case args of- [Lit (CharLiteral i), Lit (CharLiteral j)] -> Just (i,j)- _ -> Nothing--charLiterals' :: [Value] -> [Char]-charLiterals' = typedLiterals' charLiteral- where- charLiteral x = case x of- Lit (CharLiteral c) -> Just c- _ -> Nothing--sizedLiterals :: Text -> [Value] -> Maybe (Integer,Integer)-sizedLiterals szCon args- = case args of- ([ PrimVal nm _ _ [_, Lit (IntegerLiteral i)]- , PrimVal nm' _ _ [_, Lit (IntegerLiteral j)]])- | nm == szCon- , nm' == szCon -> Just (i,j)- _ -> Nothing--sizedLiterals' :: Text -> [Value] -> [Integer]-sizedLiterals' szCon = typedLiterals' (sizedLiteral szCon)--sizedLiteral :: Text -> Value -> Maybe Integer-sizedLiteral szCon val = case val of- PrimVal nm _ _ [_, Lit (IntegerLiteral i)] | nm == szCon -> Just i- _ -> Nothing--bitLiterals- :: [Value]- -> [Integer]-bitLiterals = typedLiterals' go- where- go val = case val of- PrimVal nm _ _ [Lit (IntegerLiteral i)]- | nm == "Clash.Sized.Internal.BitVector.fromInteger##"- -> Just i- _ -> Nothing--bitVectorLiterals, indexLiterals, signedLiterals, unsignedLiterals- :: [Value] -> Maybe (Integer,Integer)-bitVectorLiterals = sizedLiterals "Clash.Sized.Internal.BitVector.fromInteger#"-indexLiterals = sizedLiterals "Clash.Sized.Internal.Index.fromInteger#"-signedLiterals = sizedLiterals "Clash.Sized.Internal.Signed.fromInteger#"-unsignedLiterals = sizedLiterals "Clash.Sized.Internal.Unsigned.fromInteger#"--bitVectorLiterals', indexLiterals', signedLiterals', unsignedLiterals'- :: [Value] -> [Integer]-bitVectorLiterals' = sizedLiterals' "Clash.Sized.Internal.BitVector.fromInteger#"-indexLiterals' = sizedLiterals' "Clash.Sized.Internal.Index.fromInteger#"-signedLiterals' = sizedLiterals' "Clash.Sized.Internal.Signed.fromInteger#"-unsignedLiterals' = sizedLiterals' "Clash.Sized.Internal.Unsigned.fromInteger#"--valArgs- :: Value- -> Maybe [Term]-valArgs (PrimVal _ _ _ vs) = Just (map valToTerm vs)-valArgs (DC _ args) = Just (Either.lefts args)-valArgs _ = Nothing----- Tries to match literal arguments to a function like--- (Unsigned.shiftL# :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n)-sizedLitIntLit- :: Text -> TyConMap -> [Type] -> [Value]- -> Maybe (Type,Integer,Integer,Integer)-sizedLitIntLit szCon tcm tys args- | Just (nTy,kn) <- extractKnownNat tcm tys- , [_- ,PrimVal nm _ _ [_,Lit (IntegerLiteral i)]- ,valArgs -> Just [Literal (IntLiteral j)]- ] <- args- , nm == szCon- = Just (nTy,kn,i,j)- | otherwise- = Nothing--bitVectorLitIntLit, signedLitIntLit, unsignedLitIntLit- :: TyConMap -> [Type] -> [Value]- -> Maybe (Type,Integer,Integer,Integer)-bitVectorLitIntLit = sizedLitIntLit "Clash.Sized.Internal.BitVector.fromInteger#"-signedLitIntLit = sizedLitIntLit "Clash.Sized.Internal.Signed.fromInteger#"-unsignedLitIntLit = sizedLitIntLit "Clash.Sized.Internal.Unsigned.fromInteger#"---- From an argument list to function of type--- forall n. KnownNat n => ...--- extract (nTy,nInt)--- where nTy is the Type of n--- and nInt is its value as an Integer-extractKnownNat :: HashMap.HashMap TyConOccName TyCon -> [Type] -> Maybe (Type, Integer)-extractKnownNat tcm tys = case tys of- nTy : _ | Right nInt <- runExcept (tyNatSize tcm nTy)- -> Just (nTy, nInt)- _ -> Nothing---- Construct a constant term of a sized type-mkSizedLit- :: (Type -> Term) -- type constructor?- -> Type -- result type- -> Type -- forall n.- -> Integer -- KnownNat n- -> Integer -- value- -> Term-mkSizedLit conPrim ty nTy kn val- = mkApps (conPrim sTy) [Right nTy,Left (Literal (NaturalLiteral kn)),Left (Literal (IntegerLiteral ( val)))]- where- (_,sTy) = splitFunForallTy ty--mkBitLit- :: Type- -- ^ Result type- -> Integer- -- ^ Value- -> Term-mkBitLit ty val =- mkApps (bConPrim sTy) [Left (Literal (IntegerLiteral val))]- where- (_,sTy) = splitFunForallTy ty--mkBitVectorLit, mkSignedLit, mkUnsignedLit- :: Type -- result type- -> Type -- forall n.- -> Integer -- KnownNat n- -> Integer -- value- -> Term-mkBitVectorLit = mkSizedLit bvConPrim-mkSignedLit = mkSizedLit signedConPrim-mkUnsignedLit = mkSizedLit unsignedConPrim--mkIndexLit- :: Type -- result type- -> Type -- forall n.- -> Integer -- KnownNat n- -> Integer -- value- -> Maybe Term-mkIndexLit rTy nTy kn val- | val >= 0- , val < kn- = Just (mkSizedLit indexConPrim rTy nTy kn val)- | otherwise- = Nothing---- Construct a constant term of a sized type-mkSizedLit'- :: (Type -> Term) -- type constructor?- -> (Type -- result type- ,Type -- forall n.- ,Integer) -- KnownNat n- -> Integer -- value- -> Term-mkSizedLit' conPrim (ty,nTy,kn) val- = mkApps (conPrim sTy) [Right nTy,Left (Literal (NaturalLiteral kn)),Left (Literal (IntegerLiteral ( val)))]- where- (_,sTy) = splitFunForallTy ty--mkBitVectorLit', mkSignedLit', mkUnsignedLit'- :: (Type -- result type- ,Type -- forall n.- ,Integer) -- KnownNat n- -> Integer -- value- -> Term-mkBitVectorLit' = mkSizedLit' bvConPrim-mkSignedLit' = mkSizedLit' signedConPrim-mkUnsignedLit' = mkSizedLit' unsignedConPrim--mkIndexLit'- :: (Type -- result type- ,Type -- forall n.- ,Integer) -- KnownNat n- -> Integer -- value- -> Maybe Term-mkIndexLit' res@(_,_,kn) val- | val >= 0- , val < kn- = Just (mkSizedLit' indexConPrim res val)- | otherwise- = Nothing----- | Create a vector of supplied elements-mkVecCons- :: DataCon -- ^ The Cons (:>) constructor- -> Type -- ^ Element type- -> Integer -- ^ Length of the vector- -> Term -- ^ head of the vector- -> Term -- ^ tail of the vector- -> Term-mkVecCons consCon resTy n h t =- mkApps (Data consCon) [Right (LitTy (NumTy n))- ,Right resTy- ,Right (LitTy (NumTy (n-1)))- ,Left (Prim "_CO_" consCoTy)- ,Left h- ,Left t]-- where- args = dataConInstArgTys consCon [LitTy (NumTy n),resTy,LitTy (NumTy (n-1))]- Just (consCoTy : _) = args---- | Create an empty vector-mkVecNil- :: DataCon- -- ^ The Nil constructor- -> Type- -- ^ The element type- -> Term-mkVecNil nilCon resTy =- mkApps (Data nilCon) [Right (LitTy (NumTy 0))- ,Right resTy- ,Left (Prim "_CO_" nilCoTy)- ]- where- args = dataConInstArgTys nilCon [LitTy (NumTy 0),resTy]- Just (nilCoTy : _ ) = args--boolToIntLiteral :: Bool -> Term-boolToIntLiteral b = if b then Literal (IntLiteral 1) else Literal (IntLiteral 0)--boolToBoolLiteral :: HashMap.HashMap TyConOccName TyCon -> Type -> Bool -> Term-boolToBoolLiteral tcm ty b =- let (_,tyView -> TyConApp boolTcNm []) = splitFunForallTy ty- (Just boolTc) = HashMap.lookup (nameOcc boolTcNm) tcm- [falseDc,trueDc] = tyConDataCons boolTc- retDc = if b then trueDc else falseDc- in Data retDc--charToCharLiteral :: Char -> Term-charToCharLiteral = Literal . CharLiteral--integerToIntLiteral :: Integer -> Term-integerToIntLiteral = Literal . IntLiteral . toInteger . (fromInteger :: Integer -> Int) -- for overflow behaviour--integerToWordLiteral :: Integer -> Term-integerToWordLiteral = Literal . WordLiteral . toInteger . (fromInteger :: Integer -> Word) -- for overflow behaviour--integerToIntegerLiteral :: Integer -> Term-integerToIntegerLiteral = Literal . IntegerLiteral--bConPrim :: Type -> Term-bConPrim (tyView -> TyConApp bTcNm _)- = Prim "Clash.Sized.Internal.BitVector.fromInteger##" funTy- where- funTy = foldr1 mkFunTy [integerPrimTy,mkTyConApp bTcNm []]-bConPrim _ = error $ $(curLoc) ++ "called with incorrect type"--bvConPrim :: Type -> Term-bvConPrim (tyView -> TyConApp bvTcNm _)- = Prim "Clash.Sized.Internal.BitVector.fromInteger#" (ForAllTy (bind nTV funTy))- where- funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp bvTcNm [nVar]]- nName = string2SystemName "n"- nVar = VarTy typeNatKind nName- nTV = TyVar nName (embed typeNatKind)-bvConPrim _ = error $ $(curLoc) ++ "called with incorrect type"--indexConPrim :: Type -> Term-indexConPrim (tyView -> TyConApp indexTcNm _)- = Prim "Clash.Sized.Internal.Index.fromInteger#" (ForAllTy (bind nTV funTy))- where- funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp indexTcNm [nVar]]- nName = string2SystemName "n"- nVar = VarTy typeNatKind nName- nTV = TyVar nName (embed typeNatKind)-indexConPrim _ = error $ $(curLoc) ++ "called with incorrect type"--signedConPrim :: Type -> Term-signedConPrim (tyView -> TyConApp signedTcNm _)- = Prim "Clash.Sized.Internal.Signed.fromInteger#" (ForAllTy (bind nTV funTy))- where- funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp signedTcNm [nVar]]- nName = string2SystemName "n"- nVar = VarTy typeNatKind nName- nTV = TyVar nName (embed typeNatKind)-signedConPrim _ = error $ $(curLoc) ++ "called with incorrect type"--unsignedConPrim :: Type -> Term-unsignedConPrim (tyView -> TyConApp unsignedTcNm _)- = Prim "Clash.Sized.Internal.Unsigned.fromInteger#" (ForAllTy (bind nTV funTy))- where- funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp unsignedTcNm [nVar]]- nName = string2SystemName "n"- nVar = VarTy typeNatKind nName- nTV = TyVar nName (embed typeNatKind)-unsignedConPrim _ = error $ $(curLoc) ++ "called with incorrect type"----- | Lift a binary function over 'Unsigned' values to be used as literal Evaluator-------liftUnsigned2 :: KnownNat n- => (Unsigned n -> Unsigned n -> Unsigned n)- -> Type- -> TyConMap- -> [Type]- -> [Value]- -> (Proxy n -> Maybe Term)-liftUnsigned2 = liftSized2 unsignedLiterals' mkUnsignedLit--liftSigned2 :: KnownNat n- => (Signed n -> Signed n -> Signed n)- -> Type- -> TyConMap- -> [Type]- -> [Value]- -> (Proxy n -> Maybe Term)-liftSigned2 = liftSized2 signedLiterals' mkSignedLit--liftBitVector2 :: KnownNat n- => (BitVector n -> BitVector n -> BitVector n)- -> Type- -> TyConMap- -> [Type]- -> [Value]- -> (Proxy n -> Maybe Term)-liftBitVector2 = liftSized2 bitVectorLiterals' mkBitVectorLit--liftSized2 :: (KnownNat n, Integral (sized n))- => ([Value] -> [Integer])- -- ^ literal argument extraction function- -> (Type -> Type -> Integer -> Integer -> Term)- -- ^ literal contruction function- -> (sized n -> sized n -> sized n)- -> Type- -> TyConMap- -> [Type]- -> [Value]- -> (Proxy n -> Maybe Term)-liftSized2 extractLitArgs mkLit f ty tcm tys args p- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i,j] <- extractLitArgs args- = let val = runSizedF f i j p- in Just $ mkLit ty nTy kn val- | otherwise = Nothing---- | Helper to run a function over sized types on integers------ This only works on function of type (sized n -> sized n -> sized n)--- The resulting function must be executed with reifyNat-runSizedF- :: (KnownNat n, Integral (sized n))- => (sized n -> sized n -> sized n) -- ^ function to run- -> Integer -- ^ first argument- -> Integer -- ^ second argument- -> (Proxy n -> Integer)-runSizedF f i j _ = toInteger $ f (fromInteger i) (fromInteger j)--extractTySizeInfo :: TyConMap -> Type -> [Type] -> (Type, Type, Integer)-extractTySizeInfo tcm ty tys = (resTy,resSizeTy,resSize)- where- ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys- (_,resTy) = splitFunForallTy ty'- TyConApp _ [resSizeTy] = tyView resTy- Right resSize = runExcept (tyNatSize tcm resSizeTy)--getResultTy- :: TyConMap- -> Type- -> [Type]- -> Type-getResultTy tcm ty tys = resTy- where- ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys- (_,resTy) = splitFunForallTy ty'--liftDDI :: (Double# -> Double# -> Int#) -> [Value] -> Maybe Term-liftDDI f args = case doubleLiterals' args of- [i,j] -> Just $ runDDI f i j- _ -> Nothing-liftDDD :: (Double# -> Double# -> Double#) -> [Value] -> Maybe Term-liftDDD f args = case doubleLiterals' args of- [i,j] -> Just $ runDDD f i j- _ -> Nothing-liftDD :: (Double# -> Double#) -> [Value] -> Maybe Term-liftDD f args = case doubleLiterals' args of- [i] -> Just $ runDD f i- _ -> Nothing-runDDI :: (Double# -> Double# -> Int#) -> Rational -> Rational -> Term-runDDI f i j- = let !(D# a) = fromRational i- !(D# b) = fromRational j- r = f a b- in Literal . IntLiteral . toInteger $ I# r-runDDD :: (Double# -> Double# -> Double#) -> Rational -> Rational -> Term-runDDD f i j- = let !(D# a) = fromRational i- !(D# b) = fromRational j- r = f a b- in Literal . DoubleLiteral . toRational $ D# r-runDD :: (Double# -> Double#) -> Rational -> Term-runDD f i- = let !(D# a) = fromRational i- r = f a- in Literal . DoubleLiteral . toRational $ D# r--liftFFI :: (Float# -> Float# -> Int#) -> [Value] -> Maybe Term-liftFFI f args = case floatLiterals' args of- [i,j] -> Just $ runFFI f i j- _ -> Nothing-liftFFF :: (Float# -> Float# -> Float#) -> [Value] -> Maybe Term-liftFFF f args = case floatLiterals' args of- [i,j] -> Just $ runFFF f i j- _ -> Nothing-liftFF :: (Float# -> Float#) -> [Value] -> Maybe Term-liftFF f args = case floatLiterals' args of- [i] -> Just $ runFF f i- _ -> Nothing-runFFI :: (Float# -> Float# -> Int#) -> Rational -> Rational -> Term-runFFI f i j- = let !(F# a) = fromRational i- !(F# b) = fromRational j- r = f a b- in Literal . IntLiteral . toInteger $ I# r-runFFF :: (Float# -> Float# -> Float#) -> Rational -> Rational -> Term-runFFF f i j- = let !(F# a) = fromRational i- !(F# b) = fromRational j- r = f a b- in Literal . FloatLiteral . toRational $ F# r-runFF :: (Float# -> Float#) -> Rational -> Term-runFF f i- = let !(F# a) = fromRational i- r = f a- in Literal . FloatLiteral . toRational $ F# r---vecHeadTy- :: TyConName- -- ^ Vec TyCon name- -> Type-vecHeadTy vecNm =- ForAllTy (bind nTV (- ForAllTy (bind aTV (- mkFunTy- (mkTyConApp vecNm [mkTyConApp typeNatAdd- [VarTy typeNatKind (string2SystemName "n")- ,LitTy (NumTy 1)]- ,VarTy liftedTypeKind (string2SystemName "a")- ])- (VarTy liftedTypeKind (string2SystemName "a"))))))- where- aTV = TyVar (string2SystemName "a") (embed liftedTypeKind)- nTV = TyVar (string2SystemName "n") (embed typeNatKind)--vecTailTy- :: TyConName- -- ^ Vec TyCon name- -> Type-vecTailTy vecNm =- ForAllTy (bind nTV (- ForAllTy (bind aTV (- mkFunTy- (mkTyConApp vecNm [mkTyConApp typeNatAdd- [VarTy typeNatKind (string2SystemName "n")- ,LitTy (NumTy 1)]- ,VarTy liftedTypeKind (string2SystemName "a")- ])- (mkTyConApp vecNm [VarTy typeNatKind (string2SystemName "n")- ,VarTy liftedTypeKind (string2SystemName "a")- ])))))- where- nTV = TyVar (string2SystemName "n") (embed typeNatKind)- aTV = TyVar (string2SystemName "a") (embed liftedTypeKind)--splitAtTy- :: TyConName- -- ^ SNat TyCon name- -> TyConName- -- ^ Vec TyCon name- -> Type-splitAtTy snatNm vecNm =- ForAllTy (bind mTV (- ForAllTy (bind nTV (- ForAllTy (bind aTV (- mkFunTy- (mkTyConApp snatNm [VarTy typeNatKind (string2SystemName "m")])- (mkFunTy- (mkTyConApp vecNm- [mkTyConApp typeNatAdd- [VarTy typeNatKind (string2SystemName "m")- ,VarTy typeNatKind (string2SystemName "n")]- ,VarTy liftedTypeKind (string2SystemName "a")])- (mkTyConApp tupNm- [mkTyConApp vecNm- [VarTy typeNatKind (string2SystemName "m")- ,VarTy liftedTypeKind (string2SystemName "a")]- ,mkTyConApp vecNm- [VarTy typeNatKind (string2SystemName "n")- ,VarTy liftedTypeKind (string2SystemName "a")]]))))))))- where- mTV = TyVar (string2SystemName "m") (embed typeNatKind)- nTV = TyVar (string2SystemName "n") (embed typeNatKind)- aTV = TyVar (string2SystemName "a") (embed liftedTypeKind)- tupNm = ghcTyconToTyConName (tupleTyCon Boxed 2)--foldSplitAtTy- :: TyConName- -- ^ Vec TyCon name- -> Type-foldSplitAtTy vecNm =- ForAllTy (bind mTV (- ForAllTy (bind nTV (- ForAllTy (bind aTV (- mkFunTy- naturalPrimTy- (mkFunTy- (mkTyConApp vecNm- [mkTyConApp typeNatAdd- [VarTy typeNatKind (string2SystemName "m")- ,VarTy typeNatKind (string2SystemName "n")]- ,VarTy liftedTypeKind (string2SystemName "a")])- (mkTyConApp tupNm- [mkTyConApp vecNm- [VarTy typeNatKind (string2SystemName "m")- ,VarTy liftedTypeKind (string2SystemName "a")]- ,mkTyConApp vecNm- [VarTy typeNatKind (string2SystemName "n")- ,VarTy liftedTypeKind (string2SystemName "a")]]))))))))- where- mTV = TyVar (string2SystemName "m") (embed typeNatKind)- nTV = TyVar (string2SystemName "n") (embed typeNatKind)- aTV = TyVar (string2SystemName "a") (embed liftedTypeKind)- tupNm = ghcTyconToTyConName (tupleTyCon Boxed 2)--vecAppendTy- :: TyConName- -- ^ Vec TyCon name- -> Type-vecAppendTy vecNm =- ForAllTy (bind nTV (- ForAllTy (bind aTV (- ForAllTy (bind mTV (- mkFunTy- (mkTyConApp vecNm [VarTy typeNatKind (string2SystemName "n")- ,VarTy liftedTypeKind (string2SystemName "a")- ])- (mkFunTy- (mkTyConApp vecNm [VarTy typeNatKind (string2SystemName "m")- ,VarTy liftedTypeKind (string2SystemName "a")- ])- (mkTyConApp vecNm [mkTyConApp typeNatAdd- [VarTy typeNatKind (string2SystemName "n")- ,VarTy typeNatKind (string2SystemName "m")]- ,VarTy liftedTypeKind (string2SystemName "a")- ]))))))))- where- nTV = TyVar (string2SystemName "n") (embed typeNatKind)- aTV = TyVar (string2SystemName "a") (embed liftedTypeKind)- mTV = TyVar (string2SystemName "m") (embed typeNatKind)--vecZipWithTy- :: TyConName- -- ^ Vec TyCon name- -> Type-vecZipWithTy vecNm =- ForAllTy (bind aTV (- ForAllTy (bind bTV (- ForAllTy (bind cTV (- ForAllTy (bind nTV (- mkFunTy- (mkFunTy aTy (mkFunTy bTy cTy))- (mkFunTy- (mkTyConApp vecNm [nTy,aTy])- (mkFunTy- (mkTyConApp vecNm [nTy,bTy])- (mkTyConApp vecNm [nTy,cTy])))))))))))- where- aTV = TyVar (string2SystemName "a") (embed liftedTypeKind)- bTV = TyVar (string2SystemName "b") (embed liftedTypeKind)- cTV = TyVar (string2SystemName "c") (embed liftedTypeKind)- nTV = TyVar (string2SystemName "n") (embed typeNatKind)- aTy = VarTy liftedTypeKind (string2SystemName "a")- bTy = VarTy liftedTypeKind (string2SystemName "b")- cTy = VarTy liftedTypeKind (string2SystemName "c")- nTy = VarTy typeNatKind (string2SystemName "n")--vecImapGoTy- :: TyConName- -- ^ Vec TyCon name- -> TyConName- -- ^ Index TyCon name- -> Type-vecImapGoTy vecTcNm indexTcNm =- ForAllTy (bind nTV (- ForAllTy (bind mTV (- ForAllTy (bind aTV (- ForAllTy (bind bTV (- mkFunTy indexTy- (mkFunTy fTy- (mkFunTy vecATy vecBTy))))))))))- where- nTV = TyVar (string2SystemName "n") (embed typeNatKind)- mTV = TyVar (string2SystemName "m") (embed typeNatKind)- aTV = TyVar (string2SystemName "a") (embed liftedTypeKind)- bTV = TyVar (string2SystemName "b") (embed liftedTypeKind)- indexTy = mkTyConApp indexTcNm [nTy]- nTy = VarTy typeNatKind (string2SystemName "n")- mTy = VarTy typeNatKind (string2SystemName "m")- fTy = mkFunTy indexTy (mkFunTy aTy bTy)- aTy = VarTy liftedTypeKind (string2SystemName "a")- bTy = VarTy liftedTypeKind (string2SystemName "b")- vecATy = mkTyConApp vecTcNm [mTy,aTy]- vecBTy = mkTyConApp vecTcNm [mTy,bTy]--indexAddTy- :: TyConName- -- ^ Index TyCon name- -> Type-indexAddTy indexTcNm =- ForAllTy (bind nTV (- mkFunTy naturalPrimTy (mkFunTy indexTy (mkFunTy indexTy indexTy))))- where- nTV = TyVar (string2SystemName "n") (embed typeNatKind)- indexTy = mkTyConApp indexTcNm [VarTy typeNatKind (string2SystemName "n")]----bvAppendTy- :: TyConName- -- ^ BitVector TyCon Name- -> Type-bvAppendTy bvNm =- ForAllTy (bind mTV (- ForAllTy (bind nTV (- mkFunTy naturalPrimTy (mkFunTy- (mkTyConApp bvNm [VarTy typeNatKind (string2SystemName "n")])- (mkFunTy- (mkTyConApp bvNm [VarTy typeNatKind (string2SystemName "m")])- (mkTyConApp bvNm [mkTyConApp typeNatAdd- [VarTy typeNatKind (string2SystemName "n")- ,VarTy typeNatKind (string2SystemName "m")]])))))))- where- mTV = TyVar (string2SystemName "m") (embed typeNatKind)- nTV = TyVar (string2SystemName "n") (embed typeNatKind)--bvSplitTy- :: TyConName- -- ^ BitVector TyCon Name- -> Type-bvSplitTy bvNm =- ForAllTy (bind nTV (- ForAllTy (bind mTV (- mkFunTy naturalPrimTy (mkFunTy- (mkTyConApp bvNm [mkTyConApp typeNatAdd- [VarTy typeNatKind (string2SystemName "m")- ,VarTy typeNatKind (string2SystemName "n")]])- (mkTyConApp tupNm [mkTyConApp bvNm [VarTy typeNatKind (string2SystemName "m")]- ,mkTyConApp bvNm [VarTy typeNatKind (string2SystemName "n")]]))))))- where- nTV = TyVar (string2SystemName "n") (embed typeNatKind)- mTV = TyVar (string2SystemName "m") (embed typeNatKind)- tupNm = ghcTyconToTyConName (tupleTyCon Boxed 2)--typeNatAdd :: TyConName-typeNatAdd = Name User- (makeName "GHC.TypeNats.+"- (toInteger (getKey typeNatAddTyFamNameKey)))- wiredInSrcSpan---typeNatMul :: TyConName-typeNatMul = Name User- (makeName "GHC.TypeNats.*"- (toInteger (getKey typeNatMulTyFamNameKey)))- wiredInSrcSpan--typeNatSub :: TyConName-typeNatSub = Name User- (makeName "GHC.TypeNats.-"- (toInteger (getKey typeNatSubTyFamNameKey)))- wiredInSrcSpan--ghcTyconToTyConName- :: TyCon.TyCon- -> TyConName-ghcTyconToTyConName tc =- Name User- (makeName n' (toInteger (getKey (TyCon.tyConUnique tc))))- (getSrcSpan n)- where- n' = fromMaybe "_INTERNAL_" (modNameM n) ++ ('.':occName)+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ViewPatterns #-}++module Clash.GHC.Evaluator where++import Control.Applicative (liftA2)+import Control.Concurrent.Supply (Supply,freshId)+import Control.DeepSeq (force)+import Control.Exception (ArithException(..), Exception, tryJust, evaluate)+import Control.Monad (ap)+import Control.Monad.Trans.Except (runExcept)+import Data.Bits+import Data.Char (chr,ord)+import qualified Data.Either as Either+import qualified Data.IntMap as IntMap+import Data.Maybe+ (fromMaybe, mapMaybe, catMaybes)+import qualified Data.List as List+import qualified Data.Primitive.ByteArray as ByteArray+import Data.Proxy (Proxy)+import Data.Reflection (reifyNat)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Vector.Primitive as Vector+import Debug.Trace (trace)+import GHC.Float+import GHC.Int+import GHC.Integer+ (decodeDoubleInteger,encodeDoubleInteger,compareInteger,orInteger,andInteger,+ xorInteger,complementInteger,absInteger,signumInteger)+import GHC.Natural+import GHC.Prim+import GHC.Real (Ratio (..))+import GHC.Stack (HasCallStack)+import GHC.TypeLits (KnownNat)+import GHC.Types (IO (..))+import GHC.Word+import System.IO.Unsafe (unsafeDupablePerformIO)++import BasicTypes (Boxity (..))+import Name (getSrcSpan, nameOccName, occNameString)+import PrelNames+ (typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatSubTyFamNameKey)+import SrcLoc (wiredInSrcSpan)+import qualified TyCon+import TysWiredIn (tupleTyCon)+import Unique (getKey)++import Clash.Class.BitPack (pack,unpack)+import Clash.Core.DataCon (DataCon (..))+import Clash.Core.Evaluator+ (Heap (..), PrimEvaluator, Stack, Value (..), valToTerm, whnf, integerLiteral,+ naturalLiteral)+import Clash.Core.Literal (Literal (..))+import Clash.Core.Name+ (Name (..), NameSort (..), mkUnsafeSystemName)+import Clash.Core.Pretty (showPpr)+import Clash.Core.Term+ (Pat (..), PrimInfo (..), Term (..), WorkInfo (..))+import Clash.Core.Type+ (Type (..), ConstTy (..), LitTy (..), TypeView (..), mkFunTy, mkTyConApp,+ splitFunForallTy, tyView)+import Clash.Core.TyCon+ (TyConMap, TyConName, tyConDataCons)+import Clash.Core.TysPrim+import Clash.Core.Util+ (mkApps,mkRTree,mkVec,piResultTys,tyNatSize,dataConInstArgTys,primCo,+ undefinedTm)+import Clash.Core.Var (mkLocalId, mkTyVar)+import Clash.GHC.GHC2Core (modNameM)+import Clash.Rewrite.Util (mkSelectorCase)+import Clash.Unique (lookupUniqMap)+import Clash.Util+ (MonadUnique (..), clogBase, flogBase, curLoc)++import Clash.Promoted.Nat.Unsafe (unsafeSNat)+import qualified Clash.Sized.Internal.BitVector as BitVector+import qualified Clash.Sized.Internal.Signed as Signed+import qualified Clash.Sized.Internal.Unsigned as Unsigned+import Clash.Sized.Internal.BitVector(BitVector(..), Bit(..))+import Clash.Sized.Internal.Signed (Signed (..))+import Clash.Sized.Internal.Unsigned (Unsigned (..))+import Clash.XException (isX)++newtype PrimEvalMonad a = PEM { runPEM :: Supply -> (a,Supply) }++instance Functor PrimEvalMonad where+ fmap f m = PEM (\s -> case runPEM m s of (a,s') -> (f a, s'))++instance Applicative PrimEvalMonad where+ pure = return+ (<*>) = ap++instance Monad PrimEvalMonad where+ return a = PEM (\s -> (a,s))+ m >>= k = PEM (\s -> case runPEM m s of (a,s') -> runPEM (k a) s')++instance MonadUnique PrimEvalMonad where+ getUniqueM = PEM (\s -> case freshId s of (!i,!s') -> (i,s'))++reduceConstant :: PrimEvaluator+reduceConstant isSubj tcm h k nm pInfo tys args = case nm of+-----------------+-- GHC.Prim.Char#+-----------------+ "GHC.Prim.gtChar#" | Just (i,j) <- charLiterals args+ -> reduce (boolToIntLiteral (i > j))+ "GHC.Prim.geChar#" | Just (i,j) <- charLiterals args+ -> reduce (boolToIntLiteral (i >= j))+ "GHC.Prim.eqChar#" | Just (i,j) <- charLiterals args+ -> reduce (boolToIntLiteral (i == j))+ "GHC.Prim.neChar#" | Just (i,j) <- charLiterals args+ -> reduce (boolToIntLiteral (i /= j))+ "GHC.Prim.ltChar#" | Just (i,j) <- charLiterals args+ -> reduce (boolToIntLiteral (i < j))+ "GHC.Prim.leChar#" | Just (i,j) <- charLiterals args+ -> reduce (boolToIntLiteral (i <= j))+ "GHC.Prim.ord#" | [i] <- charLiterals' args+ -> reduce (integerToIntLiteral (toInteger $ ord i))++----------------+-- GHC.Prim.Int#+----------------+ "GHC.Prim.+#" | Just (i,j) <- intLiterals args+ -> reduce (integerToIntLiteral (i+j))+ "GHC.Prim.-#" | Just (i,j) <- intLiterals args+ -> reduce (integerToIntLiteral (i-j))+ "GHC.Prim.*#" | Just (i,j) <- intLiterals args+ -> reduce (integerToIntLiteral (i*j))++ "GHC.Prim.mulIntMayOflo#" | Just (i,j) <- intLiterals args+ -> let !(I# a) = fromInteger i+ !(I# b) = fromInteger j+ c :: Int#+ c = mulIntMayOflo# a b+ in reduce (integerToIntLiteral (toInteger $ I# c))++ "GHC.Prim.quotInt#" | Just (i,j) <- intLiterals args+ -> reduce $ catchDivByZero (integerToIntLiteral (i `quot` j))+ "GHC.Prim.remInt#" | Just (i,j) <- intLiterals args+ -> reduce $ catchDivByZero (integerToIntLiteral (i `rem` j))+ "GHC.Prim.quotRemInt#" | Just (i,j) <- intLiterals args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ (q,r) = quotRem i j+ ret = mkApps (Data tupDc) (map Right tyArgs +++ [Left $ catchDivByZero (integerToIntLiteral q)+ ,Left $ catchDivByZero (integerToIntLiteral r)])+ in reduce ret++ "GHC.Prim.andI#" | Just (i,j) <- intLiterals args+ -> reduce (integerToIntLiteral (i .&. j))+ "GHC.Prim.orI#" | Just (i,j) <- intLiterals args+ -> reduce (integerToIntLiteral (i .|. j))+ "GHC.Prim.xorI#" | Just (i,j) <- intLiterals args+ -> reduce (integerToIntLiteral (i `xor` j))+ "GHC.Prim.notI#" | [i] <- intLiterals' args+ -> reduce (integerToIntLiteral (complement i))++ "GHC.Prim.negateInt#"+ | [Lit (IntLiteral i)] <- args+ -> reduce (integerToIntLiteral (negate i))++ "GHC.Prim.addIntC#" | Just (i,j) <- intLiterals args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(I# a) = fromInteger i+ !(I# b) = fromInteger j+ !(# d, c #) = addIntC# a b+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal . IntLiteral . toInteger $ I# d)+ , Left (Literal . IntLiteral . toInteger $ I# c)])+ "GHC.Prim.subIntC#" | Just (i,j) <- intLiterals args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(I# a) = fromInteger i+ !(I# b) = fromInteger j+ !(# d, c #) = subIntC# a b+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal . IntLiteral . toInteger $ I# d)+ , Left (Literal . IntLiteral . toInteger $ I# c)])++ "GHC.Prim.>#" | Just (i,j) <- intLiterals args+ -> reduce (boolToIntLiteral (i > j))+ "GHC.Prim.>=#" | Just (i,j) <- intLiterals args+ -> reduce (boolToIntLiteral (i >= j))+ "GHC.Prim.==#" | Just (i,j) <- intLiterals args+ -> reduce (boolToIntLiteral (i == j))+ "GHC.Prim./=#" | Just (i,j) <- intLiterals args+ -> reduce (boolToIntLiteral (i /= j))+ "GHC.Prim.<#" | Just (i,j) <- intLiterals args+ -> reduce (boolToIntLiteral (i < j))+ "GHC.Prim.<=#" | Just (i,j) <- intLiterals args+ -> reduce (boolToIntLiteral (i <= j))++ "GHC.Prim.chr#" | [i] <- intLiterals' args+ -> reduce (charToCharLiteral (chr $ fromInteger i))++ "GHC.Prim.int2Word#"+ | [Lit (IntLiteral i)] <- args+ -> reduce . Literal . WordLiteral . toInteger $ (fromInteger :: Integer -> Word) i -- for overflow behavior++ "GHC.Prim.int2Float#"+ | [Lit (IntLiteral i)] <- args+ -> reduce . Literal . FloatLiteral . toRational $ (fromInteger i :: Float)+ "GHC.Prim.int2Double#"+ | [Lit (IntLiteral i)] <- args+ -> reduce . Literal . DoubleLiteral . toRational $ (fromInteger i :: Double)++ "GHC.Prim.word2Float#"+ | [Lit (WordLiteral i)] <- args+ -> reduce . Literal . FloatLiteral . toRational $ (fromInteger i :: Float)+ "GHC.Prim.word2Double#"+ | [Lit (WordLiteral i)] <- args+ -> reduce . Literal . DoubleLiteral . toRational $ (fromInteger i :: Double)++ "GHC.Prim.uncheckedIShiftL#"+ | [ Lit (IntLiteral i)+ , Lit (IntLiteral s)+ ] <- args+ -> reduce (integerToIntLiteral (i `shiftL` fromInteger s))+ "GHC.Prim.uncheckedIShiftRA#"+ | [ Lit (IntLiteral i)+ , Lit (IntLiteral s)+ ] <- args+ -> reduce (integerToIntLiteral (i `shiftR` fromInteger s))+ "GHC.Prim.uncheckedIShiftRL#" | Just (i,j) <- intLiterals args+ -> let !(I# a) = fromInteger i+ !(I# b) = fromInteger j+ c :: Int#+ c = uncheckedIShiftRL# a b+ in reduce (integerToIntLiteral (toInteger $ I# c))++-----------------+-- GHC.Prim.Word#+-----------------+ "GHC.Prim.plusWord#" | Just (i,j) <- wordLiterals args+ -> reduce (integerToWordLiteral (i+j))++ "GHC.Prim.subWordC#" | Just (i,j) <- wordLiterals args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(W# a) = fromInteger i+ !(W# b) = fromInteger j+ !(# d, c #) = subWordC# a b+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal . WordLiteral . toInteger $ W# d)+ , Left (Literal . IntLiteral . toInteger $ I# c)])++ "GHC.Prim.plusWord2#" | Just (i,j) <- wordLiterals args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(W# a) = fromInteger i+ !(W# b) = fromInteger j+ !(# h', l #) = plusWord2# a b+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal . WordLiteral . toInteger $ W# h')+ , Left (Literal . WordLiteral . toInteger $ W# l)])++ "GHC.Prim.minusWord#" | Just (i,j) <- wordLiterals args+ -> reduce (integerToWordLiteral (i-j))+ "GHC.Prim.timesWord#" | Just (i,j) <- wordLiterals args+ -> reduce (integerToWordLiteral (i*j))++ "GHC.Prim.timesWord2#" | Just (i,j) <- wordLiterals args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(W# a) = fromInteger i+ !(W# b) = fromInteger j+ !(# h', l #) = timesWord2# a b+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal . WordLiteral . toInteger $ W# h')+ , Left (Literal . WordLiteral . toInteger $ W# l)])++ "GHC.Prim.quotWord#" | Just (i,j) <- wordLiterals args+ -> reduce $ catchDivByZero (integerToWordLiteral (i `quot` j))+ "GHC.Prim.remWord#" | Just (i,j) <- wordLiterals args+ -> reduce $ catchDivByZero (integerToWordLiteral (i `rem` j))+ "GHC.Prim.quotRemWord#" | Just (i,j) <- wordLiterals args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ (q,r) = quotRem i j+ ret = mkApps (Data tupDc) (map Right tyArgs +++ [Left $ catchDivByZero (integerToWordLiteral q)+ ,Left $ catchDivByZero (integerToWordLiteral r)])+ in reduce ret+ "GHC.Prim.quotRemWord2#" | [i,j,k'] <- wordLiterals' args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(W# a) = fromInteger i+ !(W# b) = fromInteger j+ !(W# c) = fromInteger k'+ !(# x, y #) = quotRemWord2# a b c+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left $ catchDivByZero (Literal . WordLiteral . toInteger $ W# x)+ , Left $ catchDivByZero (Literal . WordLiteral . toInteger $ W# y)])++ "GHC.Prim.and#" | Just (i,j) <- wordLiterals args+ -> reduce (integerToWordLiteral (i .&. j))+ "GHC.Prim.or#" | Just (i,j) <- wordLiterals args+ -> reduce (integerToWordLiteral (i .|. j))+ "GHC.Prim.xor#" | Just (i,j) <- wordLiterals args+ -> reduce (integerToWordLiteral (i `xor` j))+ "GHC.Prim.not#" | [i] <- wordLiterals' args+ -> reduce (integerToWordLiteral (complement i))++ "GHC.Prim.uncheckedShiftL#"+ | [ Lit (WordLiteral w)+ , Lit (IntLiteral i)+ ] <- args+ -> reduce (Literal (WordLiteral (w `shiftL` fromInteger i)))+ "GHC.Prim.uncheckedShiftRL#"+ | [ Lit (WordLiteral w)+ , Lit (IntLiteral i)+ ] <- args+ -> reduce (Literal (WordLiteral (w `shiftR` fromInteger i)))++ "GHC.Prim.word2Int#"+ | [Lit (WordLiteral i)] <- args+ -> reduce . Literal . IntLiteral . toInteger $ (fromInteger :: Integer -> Int) i -- for overflow behavior++ "GHC.Prim.gtWord#" | Just (i,j) <- wordLiterals args+ -> reduce (boolToIntLiteral (i > j))+ "GHC.Prim.geWord#" | Just (i,j) <- wordLiterals args+ -> reduce (boolToIntLiteral (i >= j))+ "GHC.Prim.eqWord#" | Just (i,j) <- wordLiterals args+ -> reduce (boolToIntLiteral (i == j))+ "GHC.Prim.neWord#" | Just (i,j) <- wordLiterals args+ -> reduce (boolToIntLiteral (i /= j))+ "GHC.Prim.ltWord#" | Just (i,j) <- wordLiterals args+ -> reduce (boolToIntLiteral (i < j))+ "GHC.Prim.leWord#" | Just (i,j) <- wordLiterals args+ -> reduce (boolToIntLiteral (i <= j))++ "GHC.Prim.popCnt8#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word8) $ i+ "GHC.Prim.popCnt16#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word16) $ i+ "GHC.Prim.popCnt32#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word32) $ i+ "GHC.Prim.popCnt64#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word64) $ i+ "GHC.Prim.popCnt#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word) $ i++ "GHC.Prim.clz8#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word8) $ i+ "GHC.Prim.clz16#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word16) $ i+ "GHC.Prim.clz32#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word32) $ i+ "GHC.Prim.clz64#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word64) $ i+ "GHC.Prim.clz#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word) $ i++ "GHC.Prim.ctz8#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i .&. (bit 8 - 1)+ "GHC.Prim.ctz16#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i .&. (bit 16 - 1)+ "GHC.Prim.ctz32#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i .&. (bit 32 - 1)+ "GHC.Prim.ctz64#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word64) $ i .&. (bit 64 - 1)+ "GHC.Prim.ctz#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i++ "GHC.Prim.byteSwap16#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . byteSwap16 . (fromInteger :: Integer -> Word16) $ i+ "GHC.Prim.byteSwap32#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . byteSwap32 . (fromInteger :: Integer -> Word32) $ i+ "GHC.Prim.byteSwap64#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . byteSwap64 . (fromInteger :: Integer -> Word64) $ i+ "GHC.Prim.byteSwap#" | [i] <- wordLiterals' args -- assume 64bits+ -> reduce . integerToWordLiteral . toInteger . byteSwap64 . (fromInteger :: Integer -> Word64) $ i++------------+-- Narrowing+------------+ "GHC.Prim.narrow8Int#" | [i] <- intLiterals' args+ -> let !(I# a) = fromInteger i+ b = narrow8Int# a+ in reduce . Literal . IntLiteral . toInteger $ I# b+ "GHC.Prim.narrow16Int#" | [i] <- intLiterals' args+ -> let !(I# a) = fromInteger i+ b = narrow16Int# a+ in reduce . Literal . IntLiteral . toInteger $ I# b+ "GHC.Prim.narrow32Int#" | [i] <- intLiterals' args+ -> let !(I# a) = fromInteger i+ b = narrow32Int# a+ in reduce . Literal . IntLiteral . toInteger $ I# b+ "GHC.Prim.narrow8Word#" | [i] <- wordLiterals' args+ -> let !(W# a) = fromInteger i+ b = narrow8Word# a+ in reduce . Literal . WordLiteral . toInteger $ W# b+ "GHC.Prim.narrow16Word#" | [i] <- wordLiterals' args+ -> let !(W# a) = fromInteger i+ b = narrow16Word# a+ in reduce . Literal . WordLiteral . toInteger $ W# b+ "GHC.Prim.narrow32Word#" | [i] <- wordLiterals' args+ -> let !(W# a) = fromInteger i+ b = narrow32Word# a+ in reduce . Literal . WordLiteral . toInteger $ W# b++----------+-- Double#+----------+ "GHC.Prim.>##" | Just r <- liftDDI (>##) args+ -> reduce r+ "GHC.Prim.>=##" | Just r <- liftDDI (>=##) args+ -> reduce r+ "GHC.Prim.==##" | Just r <- liftDDI (==##) args+ -> reduce r+ "GHC.Prim./=##" | Just r <- liftDDI (/=##) args+ -> reduce r+ "GHC.Prim.<##" | Just r <- liftDDI (<##) args+ -> reduce r+ "GHC.Prim.<=##" | Just r <- liftDDI (<=##) args+ -> reduce r+ "GHC.Prim.+##" | Just r <- liftDDD (+##) args+ -> reduce r+ "GHC.Prim.-##" | Just r <- liftDDD (-##) args+ -> reduce r+ "GHC.Prim.*##" | Just r <- liftDDD (*##) args+ -> reduce r+ "GHC.Prim./##" | Just r <- liftDDD (/##) args+ -> reduce r++ "GHC.Prim.negateDouble#" | Just r <- liftDD negateDouble# args+ -> reduce r+ "GHC.Prim.fabsDouble#" | Just r <- liftDD fabsDouble# args+ -> reduce r++ "GHC.Prim.double2Int#" | [i] <- doubleLiterals' args+ -> let !(D# a) = fromRational i+ r = double2Int# a+ in reduce . Literal . IntLiteral . toInteger $ I# r+ "GHC.Prim.double2Float#"+ | [Lit (DoubleLiteral d)] <- args+ -> reduce (Literal (FloatLiteral (toRational (fromRational d :: Float))))+++ "GHC.Prim.expDouble#" | Just r <- liftDD expDouble# args+ -> reduce r+ "GHC.Prim.logDouble#" | Just r <- liftDD logDouble# args+ -> reduce r+ "GHC.Prim.sqrtDouble#" | Just r <- liftDD sqrtDouble# args+ -> reduce r+ "GHC.Prim.sinDouble#" | Just r <- liftDD sinDouble# args+ -> reduce r+ "GHC.Prim.cosDouble#" | Just r <- liftDD cosDouble# args+ -> reduce r+ "GHC.Prim.tanDouble#" | Just r <- liftDD tanDouble# args+ -> reduce r+ "GHC.Prim.asinDouble#" | Just r <- liftDD asinDouble# args+ -> reduce r+ "GHC.Prim.acosDouble#" | Just r <- liftDD acosDouble# args+ -> reduce r+ "GHC.Prim.atanDouble#" | Just r <- liftDD atanDouble# args+ -> reduce r+ "GHC.Prim.sinhDouble#" | Just r <- liftDD sinhDouble# args+ -> reduce r+ "GHC.Prim.coshDouble#" | Just r <- liftDD coshDouble# args+ -> reduce r+ "GHC.Prim.tanhDouble#" | Just r <- liftDD tanhDouble# args+ -> reduce r++#if MIN_VERSION_ghc(8,7,0)+ "GHC.Prim.asinhDouble#" | Just r <- liftDD asinhDouble# args+ -> reduce r+ "GHC.Prim.acoshDouble#" | Just r <- liftDD acoshDouble# args+ -> reduce r+ "GHC.Prim.atanhDouble#" | Just r <- liftDD atanhDouble# args+ -> reduce r+#endif++ "GHC.Prim.**##" | Just r <- liftDDD (**##) args+ -> reduce r+-- decodeDouble_2Int# :: Double# -> (#Int#, Word#, Word#, Int##)+ "GHC.Prim.decodeDouble_2Int#" | [i] <- doubleLiterals' args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(D# a) = fromRational i+ !(# p, q, r, s #) = decodeDouble_2Int# a+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal . IntLiteral . toInteger $ I# p)+ , Left (Literal . WordLiteral . toInteger $ W# q)+ , Left (Literal . WordLiteral . toInteger $ W# r)+ , Left (Literal . IntLiteral . toInteger $ I# s)])+-- decodeDouble_Int64# :: Double# -> (# Int64#, Int# #)+ "GHC.Prim.decodeDouble_Int64#" | [i] <- doubleLiterals' args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(D# a) = fromRational i+ !(# p, q #) = decodeDouble_Int64# a+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal . IntLiteral . toInteger $ I64# p)+ , Left (Literal . IntLiteral . toInteger $ I# q)])++--------+-- Float+--------+ "GHC.Prim.gtFloat#" | Just r <- liftFFI gtFloat# args+ -> reduce r+ "GHC.Prim.geFloat#" | Just r <- liftFFI geFloat# args+ -> reduce r+ "GHC.Prim.eqFloat#" | Just r <- liftFFI eqFloat# args+ -> reduce r+ "GHC.Prim.neFloat#" | Just r <- liftFFI neFloat# args+ -> reduce r+ "GHC.Prim.ltFloat#" | Just r <- liftFFI ltFloat# args+ -> reduce r+ "GHC.Prim.leFloat#" | Just r <- liftFFI leFloat# args+ -> reduce r++ "GHC.Prim.plusFloat#" | Just r <- liftFFF plusFloat# args+ -> reduce r+ "GHC.Prim.minusFloat#" | Just r <- liftFFF minusFloat# args+ -> reduce r+ "GHC.Prim.timesFloat#" | Just r <- liftFFF timesFloat# args+ -> reduce r+ "GHC.Prim.divideFloat#" | Just r <- liftFFF divideFloat# args+ -> reduce r++ "GHC.Prim.negateFloat#" | Just r <- liftFF negateFloat# args+ -> reduce r+ "GHC.Prim.fabsFloat#" | Just r <- liftFF fabsFloat# args+ -> reduce r++ "GHC.Prim.float2Int#" | [i] <- floatLiterals' args+ -> let !(F# a) = fromRational i+ r = float2Int# a+ in reduce . Literal . IntLiteral . toInteger $ I# r++ "GHC.Prim.expFloat#" | Just r <- liftFF expFloat# args+ -> reduce r+ "GHC.Prim.logFloat#" | Just r <- liftFF logFloat# args+ -> reduce r+ "GHC.Prim.sqrtFloat#" | Just r <- liftFF sqrtFloat# args+ -> reduce r+ "GHC.Prim.sinFloat#" | Just r <- liftFF sinFloat# args+ -> reduce r+ "GHC.Prim.cosFloat#" | Just r <- liftFF cosFloat# args+ -> reduce r+ "GHC.Prim.tanFloat#" | Just r <- liftFF tanFloat# args+ -> reduce r+ "GHC.Prim.asinFloat#" | Just r <- liftFF asinFloat# args+ -> reduce r+ "GHC.Prim.acosFloat#" | Just r <- liftFF acosFloat# args+ -> reduce r+ "GHC.Prim.atanFloat#" | Just r <- liftFF atanFloat# args+ -> reduce r+ "GHC.Prim.sinhFloat#" | Just r <- liftFF sinhFloat# args+ -> reduce r+ "GHC.Prim.coshFloat#" | Just r <- liftFF coshFloat# args+ -> reduce r+ "GHC.Prim.tanhFloat#" | Just r <- liftFF tanhFloat# args+ -> reduce r+ "GHC.Prim.powerFloat#" | Just r <- liftFFF powerFloat# args+ -> reduce r++#if MIN_VERSION_base(4,12,0)+ -- GHC.Float.asinh -- XXX: Very fragile+ -- $w$casinh is the Double specialisation of asinh+ -- $w$casinh1 is the Float specialisation of asinh+ "GHC.Float.$w$casinh" | Just r <- liftDD go args+ -> reduce r+ where go f = case asinh (D# f) of+ D# f' -> f'+ "GHC.Float.$w$casinh1" | Just r <- liftFF go args+ -> reduce r+ where go f = case asinh (F# f) of+ F# f' -> f'+#endif++#if MIN_VERSION_ghc(8,7,0)+ "GHC.Prim.asinhFloat#" | Just r <- liftFF asinhFloat# args+ -> reduce r+ "GHC.Prim.acoshFloat#" | Just r <- liftFF acoshFloat# args+ -> reduce r+ "GHC.Prim.atanhFloat#" | Just r <- liftFF atanhFloat# args+ -> reduce r+#endif++ "GHC.Prim.float2Double#" | [i] <- floatLiterals' args+ -> let !(F# a) = fromRational i+ r = float2Double# a+ in reduce . Literal . DoubleLiteral . toRational $ D# r+++ "GHC.Prim.newByteArray#"+ | [iV,PrimVal rwNm rwTy _ _] <- args+ , [i] <- intLiterals' [iV]+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ Heap (gh,p) gbl ph ids is0 = h+ lit = Literal (ByteArrayLiteral (Vector.replicate (fromInteger i) 0))+ h' = Heap (IntMap.insert p lit gh,p+1) gbl ph ids is0+ mbaTy = mkFunTy intPrimTy (last tyArgs)+ newE = mkApps (Data tupDc) (map Right tyArgs +++ [Left (Prim rwNm rwTy)+ ,Left (mkApps (Prim "GHC.Prim.MutableByteArray#"+ (PrimInfo mbaTy WorkNever))+ [Left (Literal . IntLiteral $ toInteger p)])+ ])+ in Just (h',k,newE)++ "GHC.Prim.setByteArray#"+ | [PrimVal _mbaNm _mbaTy _ [baV]+ ,offV,lenV,cV+ ,PrimVal rwNm rwTy _ _+ ] <- args+ , [ba,off,len,c] <- intLiterals' [baV,offV,lenV,cV]+ -> let Heap (gh,p) gbl ph ids is0 = h+ Just (Literal (ByteArrayLiteral (Vector.Vector voff vlen ba1))) =+ IntMap.lookup (fromInteger ba) gh+ !(I# off') = fromInteger off+ !(I# len') = fromInteger len+ !(I# c') = fromInteger c+ ba2 = unsafeDupablePerformIO $ do+ ByteArray.MutableByteArray mba <- ByteArray.unsafeThawByteArray ba1+ svoid (setByteArray# mba off' len' c')+ ByteArray.unsafeFreezeByteArray (ByteArray.MutableByteArray mba)+ ba3 = Literal (ByteArrayLiteral (Vector.Vector voff vlen ba2))+ h' = Heap (IntMap.insert (fromInteger ba) ba3 gh,p) gbl ph ids is0+ in Just (h',k,Prim rwNm rwTy)++ "GHC.Prim.writeWordArray#"+ | [PrimVal _mbaNm _mbaTy _ [baV]+ ,iV,wV+ ,PrimVal rwNm rwTy _ _+ ] <- args+ , [ba,i] <- intLiterals' [baV,iV]+ , [w] <- wordLiterals' [wV]+ -> let Heap (gh,p) gbl ph ids is0 = h+ Just (Literal (ByteArrayLiteral (Vector.Vector off len ba1))) =+ IntMap.lookup (fromInteger ba) gh+ !(I# i') = fromInteger i+ !(W# w') = fromIntegral w+ ba2 = unsafeDupablePerformIO $ do+ ByteArray.MutableByteArray mba <- ByteArray.unsafeThawByteArray ba1+ svoid (writeWordArray# mba i' w')+ ByteArray.unsafeFreezeByteArray (ByteArray.MutableByteArray mba)+ ba3 = Literal (ByteArrayLiteral (Vector.Vector off len ba2))+ h' = Heap (IntMap.insert (fromInteger ba) ba3 gh,p) gbl ph ids is0+ in Just (h',k,Prim rwNm rwTy)++ "GHC.Prim.unsafeFreezeByteArray#"+ | [PrimVal _mbaNm _mbaTy _ [baV]+ ,PrimVal rwNm rwTy _ _+ ] <- args+ , [ba] <- intLiterals' [baV]+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ Heap (gh,_) _ _ _ _ = h+ Just ba' = IntMap.lookup (fromInteger ba) gh+ in reduce $ mkApps (Data tupDc) (map Right tyArgs +++ [Left (Prim rwNm rwTy)+ ,Left ba'])++ "GHC.Prim.sizeofByteArray#"+ | [Lit (ByteArrayLiteral ba)] <- args+ -> reduce (Literal (IntLiteral (toInteger (Vector.length ba))))++ "GHC.Prim.indexWordArray#"+ | [Lit (ByteArrayLiteral (Vector.Vector _ _ (ByteArray.ByteArray ba))),iV] <- args+ , [i] <- intLiterals' [iV]+ -> let !(I# i') = fromInteger i+ !w = indexWordArray# ba i'+ in reduce (Literal (WordLiteral (toInteger (W# w))))++ "GHC.Prim.getSizeofMutBigNat#"+ | [PrimVal _mbaNm _mbaTy _ [baV]+ ,PrimVal rwNm rwTy _ _+ ] <- args+ , [ba] <- intLiterals' [baV]+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ Heap (gh,_) _ _ _ _ = h+ Just (Literal (ByteArrayLiteral ba')) = IntMap.lookup (fromInteger ba) gh+ lit = Literal (IntLiteral (toInteger (Vector.length ba')))+ in reduce $ mkApps (Data tupDc) (map Right tyArgs +++ [Left (Prim rwNm rwTy)+ ,Left lit])++ "GHC.Prim.resizeMutableByteArray#"+ | [PrimVal mbaNm mbaTy _ [baV]+ ,iV+ ,PrimVal rwNm rwTy _ _+ ] <- args+ , [ba,i] <- intLiterals' [baV,iV]+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ Heap (gh,p) gbl ph ids is0 = h+ Just (Literal (ByteArrayLiteral (Vector.Vector 0 _ ba1)))+ = IntMap.lookup (fromInteger ba) gh+ !(I# i') = fromInteger i+ ba2 = unsafeDupablePerformIO $ do+ ByteArray.MutableByteArray mba <- ByteArray.unsafeThawByteArray ba1+ mba' <- IO (\s -> case resizeMutableByteArray# mba i' s of+ (# s', mba' #) -> (# s', ByteArray.MutableByteArray mba' #))+ ByteArray.unsafeFreezeByteArray mba'+ ba3 = Literal (ByteArrayLiteral (Vector.Vector 0 (I# i') ba2))+ h' = Heap (IntMap.insert p ba3 gh,p+1) gbl ph ids is0+ newE = mkApps (Data tupDc) (map Right tyArgs +++ [Left (Prim rwNm rwTy)+ ,Left (mkApps (Prim mbaNm mbaTy)+ [Left (Literal . IntLiteral $ toInteger p)])+ ])+ in Just (h',k,newE)++ "GHC.Prim.shrinkMutableByteArray#"+ | [PrimVal _mbaNm _mbaTy _ [baV]+ ,lenV+ ,PrimVal rwNm rwTy _ _+ ] <- args+ , [ba,len] <- intLiterals' [baV,lenV]+ -> let Heap (gh,p) gbl ph ids is0 = h+ Just (Literal (ByteArrayLiteral (Vector.Vector voff vlen ba1))) =+ IntMap.lookup (fromInteger ba) gh+ !(I# len') = fromInteger len+ ba2 = unsafeDupablePerformIO $ do+ ByteArray.MutableByteArray mba <- ByteArray.unsafeThawByteArray ba1+ svoid (shrinkMutableByteArray# mba len')+ ByteArray.unsafeFreezeByteArray (ByteArray.MutableByteArray mba)+ ba3 = Literal (ByteArrayLiteral (Vector.Vector voff vlen ba2))+ h' = Heap (IntMap.insert (fromInteger ba) ba3 gh,p) gbl ph ids is0+ in Just (h',k,Prim rwNm rwTy)++ "GHC.Prim.copyByteArray#"+ | [Lit (ByteArrayLiteral (Vector.Vector _ _ (ByteArray.ByteArray src_ba)))+ ,src_offV+ ,PrimVal _mbaNm _mbaTy _ [dst_mbaV]+ ,dst_offV, nV+ ,PrimVal rwNm rwTy _ _+ ] <- args+ , [src_off,dst_mba,dst_off,n] <- intLiterals' [src_offV,dst_mbaV,dst_offV,nV]+ -> let Heap (gh,p) gbl ph ids is0 = h+ Just (Literal (ByteArrayLiteral (Vector.Vector voff vlen dst_ba))) =+ IntMap.lookup (fromInteger dst_mba) gh+ !(I# src_off') = fromInteger src_off+ !(I# dst_off') = fromInteger dst_off+ !(I# n') = fromInteger n+ ba2 = unsafeDupablePerformIO $ do+ ByteArray.MutableByteArray dst_mba1 <- ByteArray.unsafeThawByteArray dst_ba+ svoid (copyByteArray# src_ba src_off' dst_mba1 dst_off' n')+ ByteArray.unsafeFreezeByteArray (ByteArray.MutableByteArray dst_mba1)+ ba3 = Literal (ByteArrayLiteral (Vector.Vector voff vlen ba2))+ h' = Heap (IntMap.insert (fromInteger dst_mba) ba3 gh,p) gbl ph ids is0+ in Just (h',k,Prim rwNm rwTy)++ "GHC.Prim.readWordArray#"+ | [PrimVal _mbaNm _mbaTy _ [baV]+ ,offV+ ,PrimVal rwNm rwTy _ _+ ] <- args+ , [ba,off] <- intLiterals' [baV,offV]+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ Heap (gh,_) _ _ _ _ = h+ Just (Literal (ByteArrayLiteral (Vector.Vector _ _ ba1))) =+ IntMap.lookup (fromInteger ba) gh+ !(I# off') = fromInteger off+ w = unsafeDupablePerformIO $ do+ ByteArray.MutableByteArray mba <- ByteArray.unsafeThawByteArray ba1+ IO (\s -> case readWordArray# mba off' s of+ (# s', w' #) -> (# s', W# w' #))+ newE = mkApps (Data tupDc) (map Right tyArgs +++ [Left (Prim rwNm rwTy)+ ,Left (Literal (WordLiteral (toInteger w)))+ ])+ in reduce newE++-- decodeFloat_Int# :: Float# -> (#Int#, Int##)+ "GHC.Prim.decodeFloat_Int#" | [i] <- floatLiterals' args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(F# a) = fromRational i+ !(# p, q #) = decodeFloat_Int# a+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal . IntLiteral . toInteger $ I# p)+ , Left (Literal . IntLiteral . toInteger $ I# q)])+++ "GHC.Prim.tagToEnum#"+ | [ConstTy (TyCon tcN)] <- tys+ , [Lit (IntLiteral i)] <- args+ -> let dc = do { tc <- lookupUniqMap tcN tcm+ ; let dcs = tyConDataCons tc+ ; List.find ((== (i+1)) . toInteger . dcTag) dcs+ }+ in ((h,k,) . Data) <$> dc+++ "GHC.Classes.geInt" | Just (i,j) <- intCLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i >= j))++ "GHC.Classes.&&"+ | [DC lCon _+ ,DC rCon _] <- args+ -> reduce $ boolToBoolLiteral tcm ty+ ((nameOcc (dcName lCon) == "GHC.Types.True") &&+ (nameOcc (dcName rCon) == "GHC.Types.True"))++ "GHC.Classes.||"+ | [DC lCon _+ ,DC rCon _] <- args+ -> reduce $ boolToBoolLiteral tcm ty+ ((nameOcc (dcName lCon) == "GHC.Types.True") ||+ (nameOcc (dcName rCon) == "GHC.Types.True"))++ "GHC.Classes.divInt#" | Just (i,j) <- intLiterals args+ -> reduce (integerToIntLiteral (i `div` j))++ -- modInt# :: Int# -> Int# -> Int#+ "GHC.Classes.modInt#"+ | [dividend, divisor] <- intLiterals' args+ ->+ if divisor == 0 then+ let iTy = snd (splitFunForallTy ty) in+ reduce (undefinedTm iTy)+ else+ reduce (Literal (IntLiteral (dividend `mod` divisor)))++ "GHC.Classes.not"+ | [DC bCon _] <- args+ -> reduce (boolToBoolLiteral tcm ty (nameOcc (dcName bCon) == "GHC.Types.False"))++ "GHC.Integer.Logarithms.integerLogBase#"+ | Just (a,b) <- integerLiterals args+ , Just c <- flogBase a b+ -> (reduce . Literal . IntLiteral . toInteger) c++ "GHC.Integer.Type.smallInteger"+ | [Lit (IntLiteral i)] <- args+ -> reduce (Literal (IntegerLiteral i))++ "GHC.Integer.Type.integerToInt"+ | [i] <- integerLiterals' args+ -> reduce (integerToIntLiteral i)++ "GHC.Integer.Type.decodeDoubleInteger" -- :: Double# -> (#Integer, Int##)+ | [Lit (DoubleLiteral i)] <- args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(D# a) = fromRational i+ !(# b, c #) = decodeDoubleInteger a+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (integerToIntegerLiteral b)+ , Left (integerToIntLiteral . toInteger $ I# c)])++ "GHC.Integer.Type.encodeDoubleInteger" -- :: Integer -> Int# -> Double#+ | [iV, Lit (IntLiteral j)] <- args+ , [i] <- integerLiterals' [iV]+ -> let !(I# k') = fromInteger j+ r = encodeDoubleInteger i k'+ in reduce . Literal . DoubleLiteral . toRational $ D# r++ "GHC.Integer.Type.quotRemInteger" -- :: Integer -> Integer -> (#Integer, Integer#)+ | [i, j] <- integerLiterals' args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ (q,r) = quotRem i j+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left $ catchDivByZero (integerToIntegerLiteral q)+ , Left $ catchDivByZero (integerToIntegerLiteral r)])++ "GHC.Integer.Type.plusInteger" | Just (i,j) <- integerLiterals args+ -> reduce (integerToIntegerLiteral (i+j))++ "GHC.Integer.Type.minusInteger" | Just (i,j) <- integerLiterals args+ -> reduce (integerToIntegerLiteral (i-j))++ "GHC.Integer.Type.timesInteger" | Just (i,j) <- integerLiterals args+ -> reduce (integerToIntegerLiteral (i*j))++ "GHC.Integer.Type.negateInteger"+ | [i] <- integerLiterals' args+ -> reduce (integerToIntegerLiteral (negate i))++ "GHC.Integer.Type.divInteger" | Just (i,j) <- integerLiterals args+ -> reduce $ catchDivByZero (integerToIntegerLiteral (i `div` j))++ "GHC.Integer.Type.modInteger" | Just (i,j) <- integerLiterals args+ -> reduce $ catchDivByZero (integerToIntegerLiteral (i `mod` j))++ "GHC.Integer.Type.quotInteger" | Just (i,j) <- integerLiterals args+ -> reduce $ catchDivByZero (integerToIntegerLiteral (i `quot` j))++ "GHC.Integer.Type.remInteger" | Just (i,j) <- integerLiterals args+ -> reduce $ catchDivByZero (integerToIntegerLiteral (i `rem` j))++ "GHC.Integer.Type.divModInteger" | Just (i,j) <- integerLiterals args+ -> let (_,tyView -> TyConApp ubTupTcNm [liftedKi,_,intTy,_]) = splitFunForallTy ty+ (Just ubTupTc) = lookupUniqMap ubTupTcNm tcm+ [ubTupDc] = tyConDataCons ubTupTc+ (d,m) = divMod i j+ in reduce $+ mkApps (Data ubTupDc) [ Right liftedKi, Right liftedKi+ , Right intTy, Right intTy+ , Left $ catchDivByZero (Literal (IntegerLiteral d))+ , Left $ catchDivByZero (Literal (IntegerLiteral m))+ ]++ "GHC.Integer.Type.gtInteger" | Just (i,j) <- integerLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i > j))++ "GHC.Integer.Type.geInteger" | Just (i,j) <- integerLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i >= j))++ "GHC.Integer.Type.eqInteger" | Just (i,j) <- integerLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i == j))++ "GHC.Integer.Type.neqInteger" | Just (i,j) <- integerLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i /= j))++ "GHC.Integer.Type.ltInteger" | Just (i,j) <- integerLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i < j))++ "GHC.Integer.Type.leInteger" | Just (i,j) <- integerLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i <= j))++ "GHC.Integer.Type.gtInteger#" | Just (i,j) <- integerLiterals args+ -> reduce (boolToIntLiteral (i > j))++ "GHC.Integer.Type.geInteger#" | Just (i,j) <- integerLiterals args+ -> reduce (boolToIntLiteral (i >= j))++ "GHC.Integer.Type.eqInteger#" | Just (i,j) <- integerLiterals args+ -> reduce (boolToIntLiteral (i == j))++ "GHC.Integer.Type.neqInteger#" | Just (i,j) <- integerLiterals args+ -> reduce (boolToIntLiteral (i /= j))++ "GHC.Integer.Type.ltInteger#" | Just (i,j) <- integerLiterals args+ -> reduce (boolToIntLiteral (i < j))++ "GHC.Integer.Type.leInteger#" | Just (i,j) <- integerLiterals args+ -> reduce (boolToIntLiteral (i <= j))++ "GHC.Integer.Type.compareInteger" -- :: Integer -> Integer -> Ordering+ | [i, j] <- integerLiterals' args+ -> let -- Get the required result type (viewed as an applied type constructor name)+ (_,tyView -> TyConApp tupTcNm []) = splitFunForallTy ty+ -- Find the type constructor from the name+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ -- Get the data constructors of that type+ -- The type is 'Ordering', so they are: 'LT', 'EQ', 'GT'+ [ltDc, eqDc, gtDc] = tyConDataCons tupTc+ -- Do the actual compile-time evaluation+ ordVal = compareInteger i j+ in reduce $ case ordVal of+ LT -> Data ltDc+ EQ -> Data eqDc+ GT -> Data gtDc++ "GHC.Integer.Type.shiftRInteger"+ | [iV, Lit (IntLiteral j)] <- args+ , [i] <- integerLiterals' [iV]+ -> reduce (integerToIntegerLiteral (i `shiftR` fromInteger j))++ "GHC.Integer.Type.shiftLInteger"+ | [iV, Lit (IntLiteral j)] <- args+ , [i] <- integerLiterals' [iV]+ -> reduce (integerToIntegerLiteral (i `shiftL` fromInteger j))++ "GHC.Integer.Type.wordToInteger"+ | [Lit (WordLiteral w)] <- args+ -> reduce (Literal (IntegerLiteral w))++ "GHC.Integer.Type.integerToWord"+ | [i] <- integerLiterals' args+ -> reduce (integerToWordLiteral i)++ "GHC.Integer.Type.testBitInteger" -- :: Integer -> Int# -> Bool+ | [Lit (IntegerLiteral i), Lit (IntLiteral j)] <- args+ -> reduce (boolToBoolLiteral tcm ty (testBit i (fromInteger j)))++ "GHC.Natural.NatS#"+ | [Lit (WordLiteral w)] <- args+ -> reduce (Literal (NaturalLiteral w))++ "GHC.Natural.naturalToInteger"+ | [i] <- naturalLiterals' args+ -> reduce (Literal (IntegerLiteral (toInteger i)))++ "GHC.Natural.naturalFromInteger"+ | [i] <- integerLiterals' args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange1 nTy i id)++ -- GHC.shiftLNatural --- XXX: Fragile worker of GHC.shiflLNatural+ "GHC.Natural.$wshiftLNatural"+ | [nV,iV] <- args+ , [n] <- naturalLiterals' [nV]+ , [i] <- fromInteger <$> intLiterals' [iV]+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange1 nTy n ((flip shiftL) i))++ "GHC.Natural.plusNatural"+ | Just (i,j) <- naturalLiterals args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange2 nTy i j (+))++ "GHC.Natural.timesNatural"+ | Just (i,j) <- naturalLiterals args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange2 nTy i j (*))++ "GHC.Natural.minusNatural"+ | Just (i,j) <- naturalLiterals args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange nTy [i, j] (\[i', j'] ->+ case minusNaturalMaybe i' j' of+ Nothing -> checkNaturalRange1 nTy (-1) id+ Just n -> naturalToNaturalLiteral n))++ "GHC.Natural.wordToNatural#"+ | [Lit (WordLiteral w)] <- args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange1 nTy w id)++ -- GHC.Real.^ -- XXX: Very fragile+ -- ^_f, $wf, $wf1 are specialisations of the internal function f in the implementation of (^) in GHC.Real+ "GHC.Real.^_f" -- :: Integer -> Integer -> Integer+ | [i,j] <- integerLiterals' args+ -> reduce (integerToIntegerLiteral $ i ^ j)+ "GHC.Real.$wf" -- :: Integer -> Int# -> Integer+ | [iV, Lit (IntLiteral j)] <- args+ , [i] <- integerLiterals' [iV]+ -> reduce (integerToIntegerLiteral $ i ^ j)+ "GHC.Real.$wf1" -- :: Int# -> Int# -> Int#+ | [Lit (IntLiteral i), Lit (IntLiteral j)] <- args+ -> reduce (integerToIntLiteral $ i ^ j)++ -- XXX: Very fragile. /$s^_f/ is a specialized version of ^_f. That means that+ -- it is type applied to some specific type.+ "Data.Singletons.TypeLits.Internal.$s^_f"+ | Just (i,j) <- naturalLiterals args+ -> reduce (Literal (NaturalLiteral (i ^ j)))++ "GHC.TypeLits.natVal"+ | [Lit (NaturalLiteral n), _] <- args+ -> reduce (integerToIntegerLiteral n)++ "GHC.TypeNats.natVal"+ | [Lit (NaturalLiteral n), _] <- args+ -> reduce (Literal (NaturalLiteral n))++ "GHC.Types.C#"+ | isSubj+ , [Lit (CharLiteral c)] <- args+ -> let (_,tyView -> TyConApp charTcNm []) = splitFunForallTy ty+ (Just charTc) = lookupUniqMap charTcNm tcm+ [charDc] = tyConDataCons charTc+ in reduce (mkApps (Data charDc) [Left (Literal (CharLiteral c))])++ "GHC.Types.I#"+ | isSubj+ , [Lit (IntLiteral i)] <- args+ -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty+ (Just intTc) = lookupUniqMap intTcNm tcm+ [intDc] = tyConDataCons intTc+ in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])+ "GHC.Int.I8#"+ | isSubj+ , [Lit (IntLiteral i)] <- args+ -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty+ (Just intTc) = lookupUniqMap intTcNm tcm+ [intDc] = tyConDataCons intTc+ in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])+ "GHC.Int.I16#"+ | isSubj+ , [Lit (IntLiteral i)] <- args+ -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty+ (Just intTc) = lookupUniqMap intTcNm tcm+ [intDc] = tyConDataCons intTc+ in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])+ "GHC.Int.I32#"+ | isSubj+ , [Lit (IntLiteral i)] <- args+ -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty+ (Just intTc) = lookupUniqMap intTcNm tcm+ [intDc] = tyConDataCons intTc+ in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])+ "GHC.Int.I64#"+ | isSubj+ , [Lit (IntLiteral i)] <- args+ -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty+ (Just intTc) = lookupUniqMap intTcNm tcm+ [intDc] = tyConDataCons intTc+ in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])++ "GHC.Types.W#"+ | isSubj+ , [Lit (WordLiteral c)] <- args+ -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = lookupUniqMap wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])+ "GHC.Word.W8#"+ | isSubj+ , [Lit (WordLiteral c)] <- args+ -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = lookupUniqMap wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])+ "GHC.Word.W16#"+ | isSubj+ , [Lit (WordLiteral c)] <- args+ -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = lookupUniqMap wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])+ "GHC.Word.W32#"+ | isSubj+ , [Lit (WordLiteral c)] <- args+ -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = lookupUniqMap wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])+ "GHC.Word.W64#"+ | [Lit (WordLiteral c)] <- args+ -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = lookupUniqMap wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])++ "GHC.Float.$w$sfromRat''" -- XXX: Very fragile+ | [Lit (IntLiteral _minEx)+ ,Lit (IntLiteral matDigs)+ ,nV+ ,dV] <- args+ , [n,d] <- integerLiterals' [nV,dV]+ -> case fromInteger matDigs of+ matDigs'+ | matDigs' == floatDigits (undefined :: Float)+ -> reduce (Literal (FloatLiteral (toRational (fromRational (n :% d) :: Float))))+ | matDigs' == floatDigits (undefined :: Double)+ -> reduce (Literal (DoubleLiteral (toRational (fromRational (n :% d) :: Double))))+ _ -> error $ $(curLoc) ++ "GHC.Float.$w$sfromRat'': Not a Float or Double"++ "GHC.Float.$w$sfromRat''1" -- XXX: Very fragile+ | [Lit (IntLiteral _minEx)+ ,Lit (IntLiteral matDigs)+ ,nV+ ,dV] <- args+ , [n,d] <- integerLiterals' [nV,dV]+ -> case fromInteger matDigs of+ matDigs'+ | matDigs' == floatDigits (undefined :: Float)+ -> reduce (Literal (FloatLiteral (toRational (fromRational (n :% d) :: Float))))+ | matDigs' == floatDigits (undefined :: Double)+ -> reduce (Literal (DoubleLiteral (toRational (fromRational (n :% d) :: Double))))+ _ -> error $ $(curLoc) ++ "GHC.Float.$w$sfromRat'': Not a Float or Double"++ "GHC.Integer.Type.$wsignumInteger" -- XXX: Not super-fragile, but still..+ | [i] <- integerLiterals' args+ -> reduce (Literal (IntLiteral (signum i)))+++ "GHC.Integer.Type.signumInteger"+ | [i] <- integerLiterals' args+ -> reduce (Literal (IntegerLiteral (signumInteger i)))++ "GHC.Integer.Type.absInteger"+ | [i] <- integerLiterals' args+ -> reduce (Literal (IntegerLiteral (absInteger i)))++ "GHC.Integer.Type.bitInteger"+ | [i] <- intLiterals' args+ -> reduce (Literal (IntegerLiteral (bit (fromInteger i))))++ "GHC.Integer.Type.complementInteger"+ | [i] <- integerLiterals' args+ -> reduce (Literal (IntegerLiteral (complementInteger i)))++ "GHC.Integer.Type.orInteger"+ | [i, j] <- integerLiterals' args+ -> reduce (Literal (IntegerLiteral (orInteger i j)))++ "GHC.Integer.Type.xorInteger"+ | [i, j] <- integerLiterals' args+ -> reduce (Literal (IntegerLiteral (xorInteger i j)))++ "GHC.Integer.Type.andInteger"+ | [i, j] <- integerLiterals' args+ -> reduce (Literal (IntegerLiteral (andInteger i j)))++ "GHC.Integer.Type.doubleFromInteger"+ | [i] <- integerLiterals' args+ -> reduce (Literal (DoubleLiteral (toRational (fromInteger i :: Double))))++ "GHC.Base.eqString"+ | [PrimVal _ _ _ [Lit (StringLiteral s1)]+ ,PrimVal _ _ _ [Lit (StringLiteral s2)]+ ] <- args+ -> reduce (boolToBoolLiteral tcm ty (s1 == s2))+ | otherwise -> error (show args)+++ "Clash.Class.BitPack.packDouble#" -- :: Double -> BitVector 64+ | [DC _ [Left arg]] <- args+ , (h2,[],Literal (DoubleLiteral i)) <- whnf reduceConstant tcm True (h,[],arg)+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in Just (h2,k,mkBitVectorLit' resTyInfo 0 (BitVector.unsafeToInteger $ (pack :: Double -> BitVector 64) $ fromRational i))++ "Clash.Class.BitPack.packFloat#" -- :: Float -> BitVector 32+ | [DC _ [Left arg]] <- args+ , (h2,[],Literal (FloatLiteral i)) <- whnf reduceConstant tcm True (h,[],arg)+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in Just (h2,k,mkBitVectorLit' resTyInfo 0 (BitVector.unsafeToInteger $ (pack :: Float -> BitVector 32) $ fromRational i))++ "Clash.Class.BitPack.unpackFloat#"+ | [i] <- bitVectorLiterals' args+ -> reduce (Literal (FloatLiteral (toRational $ (unpack :: BitVector 32 -> Float) (toBV i))))++ "Clash.Class.BitPack.unpackDouble#"+ | [i] <- bitVectorLiterals' args+ -> reduce (Literal (DoubleLiteral (toRational $ (unpack :: BitVector 64 -> Double) (toBV i))))++ -- expIndex#+ -- :: KnownNat m+ -- => Index m+ -- -> SNat n+ -- -> Index (n^m)+ "Clash.Class.Exp.expIndex#"+ | [b] <- indexLiterals' args+ , [(_mTy, km), (_, e)] <- extractKnownNats tcm tys+ -> reduce (mkIndexLit ty (LitTy (NumTy (km^e))) (km^e) (b^e))++ -- expSigned#+ -- :: KnownNat m+ -- => Signed m+ -- -> SNat n+ -- -> Signed (n*m)+ "Clash.Class.Exp.expSigned#"+ | [b] <- signedLiterals' args+ , [(_mTy, km), (_, e)] <- extractKnownNats tcm tys+ -> reduce (mkSignedLit ty (LitTy (NumTy (km*e))) (km*e) (b^e))++ -- expUnsigned#+ -- :: KnownNat m+ -- => Unsigned m+ -- -> SNat n+ -- -> Unsigned m+ "Clash.Class.Exp.expUnsigned#"+ | [b] <- unsignedLiterals' args+ , [(_mTy, km), (_, e)] <- extractKnownNats tcm tys+ -> reduce (mkUnsignedLit ty (LitTy (NumTy (km*e))) (km*e) (b^e))++ "Clash.Promoted.Nat.powSNat"+ | [Right a, Right b] <- map (runExcept . tyNatSize tcm) tys+ -> let c = case a of+ 2 -> 1 `shiftL` (fromInteger b)+ _ -> a ^ b+ (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty+ (Just snatTc) = lookupUniqMap snatTcNm tcm+ [snatDc] = tyConDataCons snatTc+ in reduce $+ mkApps (Data snatDc) [ Right (LitTy (NumTy c))+ , Left (Literal (NaturalLiteral c))]++ "Clash.Promoted.Nat.flogBaseSNat"+ | [_,_,Right a, Right b] <- map (runExcept . tyNatSize tcm) tys+ , Just c <- flogBase a b+ , let c' = toInteger c+ -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty+ (Just snatTc) = lookupUniqMap snatTcNm tcm+ [snatDc] = tyConDataCons snatTc+ in reduce $+ mkApps (Data snatDc) [ Right (LitTy (NumTy c'))+ , Left (Literal (NaturalLiteral c'))]++ "Clash.Promoted.Nat.clogBaseSNat"+ | [_,_,Right a, Right b] <- map (runExcept . tyNatSize tcm) tys+ , Just c <- clogBase a b+ , let c' = toInteger c+ -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty+ (Just snatTc) = lookupUniqMap snatTcNm tcm+ [snatDc] = tyConDataCons snatTc+ in reduce $+ mkApps (Data snatDc) [ Right (LitTy (NumTy c'))+ , Left (Literal (NaturalLiteral c'))]++ "Clash.Promoted.Nat.logBaseSNat"+ | [_,Right a, Right b] <- map (runExcept . tyNatSize tcm) tys+ , Just c <- flogBase a b+ , let c' = toInteger c+ -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty+ (Just snatTc) = lookupUniqMap snatTcNm tcm+ [snatDc] = tyConDataCons snatTc+ in reduce $+ mkApps (Data snatDc) [ Right (LitTy (NumTy c'))+ , Left (Literal (NaturalLiteral c'))]++------------+-- BitVector+------------+-- Constructor+ "Clash.Sized.Internal.BitVector.BV"+ | [Right _] <- map (runExcept . tyNatSize tcm) tys+ , Just (m,i) <- integerLiterals args+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkBitVectorLit' resTyInfo m i)++ "Clash.Sized.Internal.BitVector.Bit"+ | Just (m,i) <- integerLiterals args+ -> reduce (mkBitLit ty m i)++-- Initialisation+ "Clash.Sized.Internal.BitVector.size#"+ | Just (_, kn) <- extractKnownNat tcm tys+ -> let (_,tyView -> TyConApp intTcNm _) = splitFunForallTy ty+ (Just intTc) = lookupUniqMap intTcNm tcm+ [intCon] = tyConDataCons intTc+ in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral kn))])+ "Clash.Sized.Internal.BitVector.maxIndex#"+ | Just (_, kn) <- extractKnownNat tcm tys+ -> let (_,tyView -> TyConApp intTcNm _) = splitFunForallTy ty+ (Just intTc) = lookupUniqMap intTcNm tcm+ [intCon] = tyConDataCons intTc+ in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral (kn-1)))])++-- Construction+ "Clash.Sized.Internal.BitVector.high"+ -> reduce (mkBitLit ty 0 1)+ "Clash.Sized.Internal.BitVector.low"+ -> reduce (mkBitLit ty 0 0)++-- Eq+ "Clash.Sized.Internal.BitVector.eq##" | [(0,i),(0,j)] <- bitLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i == j))+ "Clash.Sized.Internal.BitVector.neq##" | [(0,i),(0,j)] <- bitLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i /= j))++-- Ord+ "Clash.Sized.Internal.BitVector.lt##" | [(0,i),(0,j)] <- bitLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i < j))+ "Clash.Sized.Internal.BitVector.ge##" | [(0,i),(0,j)] <- bitLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i >= j))+ "Clash.Sized.Internal.BitVector.gt##" | [(0,i),(0,j)] <- bitLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i > j))+ "Clash.Sized.Internal.BitVector.le##" | [(0,i),(0,j)] <- bitLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i <= j))++-- Bits+ "Clash.Sized.Internal.BitVector.and##"+ | [(0,i),(0,j)] <- bitLiterals args+ -> reduce (mkBitLit ty 0 (i .&. j))+ "Clash.Sized.Internal.BitVector.or##"+ | [(0,i),(0,j)] <- bitLiterals args+ -> reduce (mkBitLit ty 0 (i .|. j))+ "Clash.Sized.Internal.BitVector.xor##"+ | [(0,i),(0,j)] <- bitLiterals args+ -> reduce (mkBitLit ty 0 (i `xor` j))++ "Clash.Sized.Internal.BitVector.complement##"+ | [(0,i)] <- bitLiterals args+ -> reduce (mkBitLit ty 0 (complement i))++-- Pack+ "Clash.Sized.Internal.BitVector.pack#"+ | [(msk,i)] <- bitLiterals args+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkBitVectorLit' resTyInfo msk i)++ "Clash.Sized.Internal.BitVector.unpack#"+ | [(msk,i)] <- bitVectorLiterals' args+ -> reduce (mkBitLit ty msk i)++-- Concatenation+ "Clash.Sized.Internal.BitVector.++#" -- :: KnownNat m => BitVector n -> BitVector m -> BitVector (n + m)+ | Just (_,m) <- extractKnownNat tcm tys+ , [(mski,i),(mskj,j)] <- bitVectorLiterals' args+ -> let val = i `shiftL` fromInteger m .|. j+ msk = mski `shiftL` fromInteger m .|. mskj+ resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkBitVectorLit' resTyInfo msk val)++-- Reduction+ "Clash.Sized.Internal.BitVector.reduceAnd#" -- :: KnownNat n => BitVector n -> Bit+ | [i] <- bitVectorLiterals' args+ , Just (_, kn) <- extractKnownNat tcm tys+ -> let resTy = getResultTy tcm ty tys+ val = reifyNat kn (op (toBV i))+ in reduce (mkBitLit resTy 0 val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> Integer+ op u _ = toInteger (BitVector.reduceAnd# u)+ "Clash.Sized.Internal.BitVector.reduceOr#" -- :: KnownNat n => BitVector n -> Bit+ | [i] <- bitVectorLiterals' args+ , Just (_, kn) <- extractKnownNat tcm tys+ -> let resTy = getResultTy tcm ty tys+ val = reifyNat kn (op (toBV i))+ in reduce (mkBitLit resTy 0 val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> Integer+ op u _ = toInteger (BitVector.reduceOr# u)+ "Clash.Sized.Internal.BitVector.reduceXor#" -- :: KnownNat n => BitVector n -> Bit+ | [i] <- bitVectorLiterals' args+ , Just (_, kn) <- extractKnownNat tcm tys+ -> let resTy = getResultTy tcm ty tys+ val = reifyNat kn (op (toBV i))+ in reduce (mkBitLit resTy 0 val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> Integer+ op u _ = toInteger (BitVector.reduceXor# u)+++-- Indexing+ "Clash.Sized.Internal.BitVector.index#" -- :: KnownNat n => BitVector n -> Int -> Bit+ | Just (_,kn,i,j) <- bitVectorLitIntLit tcm tys args+ -> let resTy = getResultTy tcm ty tys+ (msk,val) = reifyNat kn (op (toBV i) (fromInteger j))+ in reduce (mkBitLit resTy msk val)+ where+ op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)+ op u i _ = (m, v)+ where Bit m v = (BitVector.index# u i)+ "Clash.Sized.Internal.BitVector.replaceBit#" -- :: :: KnownNat n => BitVector n -> Int -> Bit -> BitVector n+ | Just (_, n) <- extractKnownNat tcm tys+ , [ _+ , PrimVal bvNm _ _ [_, Lit (IntegerLiteral mskBv), Lit (IntegerLiteral bv)]+ , valArgs -> Just [Literal (IntLiteral i)]+ , PrimVal bNm _ _ [Lit (IntegerLiteral mskB), Lit (IntegerLiteral b)]+ ] <- args+ , bvNm == "Clash.Sized.Internal.BitVector.fromInteger#"+ , bNm == "Clash.Sized.Internal.BitVector.fromInteger##"+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ (mskVal,val) = reifyNat n (op (BV mskBv bv) (fromInteger i) (Bit mskB b))+ in reduce (mkBitVectorLit' resTyInfo mskVal val)+ where+ op :: KnownNat n => BitVector n -> Int -> Bit -> Proxy n -> (Integer,Integer)+ -- op bv i b _ = (BitVector.unsafeMask res, BitVector.unsafeToInteger res)+ op bv i b _ = splitBV (BitVector.replaceBit# bv i b)+ "Clash.Sized.Internal.BitVector.setSlice#"+ -- :: BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n) -> BitVector (m + 1 + i)+ | mTy : _ : nTy : _ <- tys+ , Right m <- runExcept (tyNatSize tcm mTy)+ , Right n <- runExcept (tyNatSize tcm nTy)+ , [i,j] <- bitVectorLiterals' args+ -> let BV msk val = BitVector.setSlice# (toBV i) (unsafeSNat m) (unsafeSNat n) (toBV j)+ resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkBitVectorLit' resTyInfo msk val)+ "Clash.Sized.Internal.BitVector.slice#"+ -- :: BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n)+ | mTy : _ : nTy : _ <- tys+ , Right m <- runExcept (tyNatSize tcm mTy)+ , Right n <- runExcept (tyNatSize tcm nTy)+ , [i] <- bitVectorLiterals' args+ -> let BV msk val = BitVector.slice# (toBV i) (unsafeSNat m) (unsafeSNat n)+ resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkBitVectorLit' resTyInfo msk val)+ "Clash.Sized.Internal.BitVector.split#" -- :: forall n m. KnownNat n => BitVector (m + n) -> (BitVector m, BitVector n)+ | nTy : mTy : _ <- tys+ , Right n <- runExcept (tyNatSize tcm nTy)+ , Right m <- runExcept (tyNatSize tcm mTy)+ , [(mski,i)] <- bitVectorLiterals' args+ -> let ty' = piResultTys tcm ty tys+ (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty'+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ bvTy : _ = tyArgs+ valM = i `shiftR` fromInteger n+ mskM = mski `shiftR` fromInteger n+ valN = i .&. mask+ mskN = mski .&. mask+ mask = bit (fromInteger n) - 1+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (mkBitVectorLit bvTy mTy m mskM valM)+ , Left (mkBitVectorLit bvTy nTy n mskN valN)])++ "Clash.Sized.Internal.BitVector.msb#" -- :: forall n. KnownNat n => BitVector n -> Bit+ | [i] <- bitVectorLiterals' args+ , Just (_, kn) <- extractKnownNat tcm tys+ -> let resTy = getResultTy tcm ty tys+ (msk,val) = reifyNat kn (op (toBV i))+ in reduce (mkBitLit resTy msk val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> (Integer,Integer)+ op u _ = (unsafeMask# res, BitVector.unsafeToInteger# res)+ where+ res = BitVector.msb# u+ "Clash.Sized.Internal.BitVector.lsb#" -- :: BitVector n -> Bit+ | [i] <- bitVectorLiterals' args+ -> let resTy = getResultTy tcm ty tys+ Bit msk val = BitVector.lsb# (toBV i)+ in reduce (mkBitLit resTy msk val)+++-- Eq+ -- eq#, neq# :: KnownNat n => BitVector n -> BitVector n -> Bool+ "Clash.Sized.Internal.BitVector.eq#"+ | nTy : _ <- tys+ , Right 0 <- runExcept (tyNatSize tcm nTy)+ -> reduce (boolToBoolLiteral tcm ty True)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2Bool BitVector.eq# ty tcm args)+ -> reduce val++ "Clash.Sized.Internal.BitVector.neq#"+ | nTy : _ <- tys+ , Right 0 <- runExcept (tyNatSize tcm nTy)+ -> reduce (boolToBoolLiteral tcm ty False)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2Bool BitVector.neq# ty tcm args)+ -> reduce val++-- Ord+ -- lt#,ge#,gt#,le# :: KnownNat n => BitVector n -> BitVector n -> Bool+ "Clash.Sized.Internal.BitVector.lt#"+ | nTy : _ <- tys+ , Right 0 <- runExcept (tyNatSize tcm nTy)+ -> reduce (boolToBoolLiteral tcm ty False)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2Bool BitVector.lt# ty tcm args)+ -> reduce val+ "Clash.Sized.Internal.BitVector.ge#"+ | nTy : _ <- tys+ , Right 0 <- runExcept (tyNatSize tcm nTy)+ -> reduce (boolToBoolLiteral tcm ty True)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2Bool BitVector.ge# ty tcm args)+ -> reduce val+ "Clash.Sized.Internal.BitVector.gt#"+ | nTy : _ <- tys+ , Right 0 <- runExcept (tyNatSize tcm nTy)+ -> reduce (boolToBoolLiteral tcm ty False)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2Bool BitVector.gt# ty tcm args)+ -> reduce val+ "Clash.Sized.Internal.BitVector.le#"+ | nTy : _ <- tys+ , Right 0 <- runExcept (tyNatSize tcm nTy)+ -> reduce (boolToBoolLiteral tcm ty True)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2Bool BitVector.le# ty tcm args)+ -> reduce val++-- Bounded+ "Clash.Sized.Internal.BitVector.minBound#"+ | Just (nTy,len) <- extractKnownNat tcm tys+ -> reduce (mkBitVectorLit ty nTy len 0 0)+ "Clash.Sized.Internal.BitVector.maxBound#"+ | Just (litTy,mb) <- extractKnownNat tcm tys+ -> let maxB = (2 ^ mb) - 1+ in reduce (mkBitVectorLit ty litTy mb 0 maxB)++-- Num+ "Clash.Sized.Internal.BitVector.+#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.+#) ty tcm tys args)+ -> reduce val+ "Clash.Sized.Internal.BitVector.-#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.-#) ty tcm tys args)+ -> reduce val+ "Clash.Sized.Internal.BitVector.*#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.*#) ty tcm tys args)+ -> reduce val+ "Clash.Sized.Internal.BitVector.negate#"+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i] <- bitVectorLiterals' args+ -> let (msk,val) = reifyNat kn (op (toBV i))+ in reduce (mkBitVectorLit ty nTy kn msk val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> (Integer,Integer)+ op u _ = splitBV (BitVector.negate# u)++-- ExtendingNum+ "Clash.Sized.Internal.BitVector.plus#" -- :: (KnownNat n, KnownNat m) => BitVector m -> BitVector n -> BitVector (Max m n + 1)+ | [(0,i),(0,j)] <- bitVectorLiterals' args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ in reduce (mkBitVectorLit resTy resSizeTy resSizeInt 0 (i+j))++ "Clash.Sized.Internal.BitVector.minus#"+ | [(0,i),(0,j)] <- bitVectorLiterals' args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ val = reifyNat resSizeInt (runSizedF (BitVector.-#) i j)+ in reduce (mkBitVectorLit resTy resSizeTy resSizeInt 0 val)++ "Clash.Sized.Internal.BitVector.times#"+ | [(0,i),(0,j)] <- bitVectorLiterals' args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ in reduce (mkBitVectorLit resTy resSizeTy resSizeInt 0 (i*j))++-- Integral+ "Clash.Sized.Internal.BitVector.quot#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.quot#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ "Clash.Sized.Internal.BitVector.rem#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.rem#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ "Clash.Sized.Internal.BitVector.toInteger#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , [i] <- bitVectorLiterals' args+ -> let val = reifyNat kn (op (toBV i))+ in reduce (integerToIntegerLiteral val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> Integer+ op u _ = BitVector.toInteger# u++-- Bits+ "Clash.Sized.Internal.BitVector.and#"+ | Just (i,j) <- bitVectorLiterals args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> let BV msk val = BitVector.and# (toBV i) (toBV j)+ in reduce (mkBitVectorLit ty nTy kn msk val)+ "Clash.Sized.Internal.BitVector.or#"+ | Just (i,j) <- bitVectorLiterals args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> let BV msk val = BitVector.or# (toBV i) (toBV j)+ in reduce (mkBitVectorLit ty nTy kn msk val)+ "Clash.Sized.Internal.BitVector.xor#"+ | Just (i,j) <- bitVectorLiterals args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> let BV msk val = BitVector.xor# (toBV i) (toBV j)+ in reduce (mkBitVectorLit ty nTy kn msk val)++ "Clash.Sized.Internal.BitVector.complement#"+ | [i] <- bitVectorLiterals' args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> let (msk,val) = reifyNat kn (op (toBV i))+ in reduce (mkBitVectorLit ty nTy kn msk val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> (Integer,Integer)+ op u _ = splitBV $ BitVector.complement# u++ "Clash.Sized.Internal.BitVector.shiftL#"+ | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args+ -> let (msk,val) = reifyNat kn (op (toBV i) (fromInteger j))+ in reduce (mkBitVectorLit ty nTy kn msk val)+ where+ op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)+ op u i _ = splitBV (BitVector.shiftL# u i)+ "Clash.Sized.Internal.BitVector.shiftR#"+ | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args+ -> let (msk,val) = reifyNat kn (op (toBV i) (fromInteger j))+ in reduce (mkBitVectorLit ty nTy kn msk val)+ where+ op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)+ op u i _ = splitBV (BitVector.shiftR# u i)+ "Clash.Sized.Internal.BitVector.rotateL#"+ | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args+ -> let (msk,val) = reifyNat kn (op (toBV i) (fromInteger j))+ in reduce (mkBitVectorLit ty nTy kn msk val)+ where+ op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)+ op u i _ = splitBV (BitVector.rotateL# u i)+ "Clash.Sized.Internal.BitVector.rotateR#"+ | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args+ -> let (msk,val) = reifyNat kn (op (toBV i) (fromInteger j))+ in reduce (mkBitVectorLit ty nTy kn msk val)+ where+ op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)+ op u i _ = splitBV (BitVector.rotateR# u i)++-- truncateB+ "Clash.Sized.Internal.BitVector.truncateB#" -- forall a b . KnownNat a => BitVector (a + b) -> BitVector a+ | aTy : _ <- tys+ , Right ka <- runExcept (tyNatSize tcm aTy)+ , [(mski,i)] <- bitVectorLiterals' args+ -> let bitsKeep = (bit (fromInteger ka)) - 1+ val = i .&. bitsKeep+ msk = mski .&. bitsKeep+ in reduce (mkBitVectorLit ty aTy ka msk val)++--------+-- Index+--------+-- BitPack+ "Clash.Sized.Internal.Index.pack#"+ | nTy : _ <- tys+ , Right _ <- runExcept (tyNatSize tcm nTy)+ , [i] <- indexLiterals' args+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkBitVectorLit' resTyInfo 0 i)+ "Clash.Sized.Internal.Index.unpack#"+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , [(0,i)] <- bitVectorLiterals' args+ -> reduce (mkIndexLit ty nTy kn i)++-- Eq+ "Clash.Sized.Internal.Index.eq#" | Just (i,j) <- indexLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i == j))+ "Clash.Sized.Internal.Index.neq#" | Just (i,j) <- indexLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i /= j))++-- Ord+ "Clash.Sized.Internal.Index.lt#"+ | Just (i,j) <- indexLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i < j))+ "Clash.Sized.Internal.Index.ge#"+ | Just (i,j) <- indexLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i >= j))+ "Clash.Sized.Internal.Index.gt#"+ | Just (i,j) <- indexLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i > j))+ "Clash.Sized.Internal.Index.le#"+ | Just (i,j) <- indexLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i <= j))++-- Bounded+ "Clash.Sized.Internal.Index.maxBound#"+ | Just (nTy,mb) <- extractKnownNat tcm tys+ -> reduce (mkIndexLit ty nTy mb (mb - 1))++-- Num+ "Clash.Sized.Internal.Index.+#"+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , [i,j] <- indexLiterals' args+ -> reduce (mkIndexLit ty nTy kn (i + j))+ "Clash.Sized.Internal.Index.-#"+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , [i,j] <- indexLiterals' args+ -> reduce (mkIndexLit ty nTy kn (i - j))+ "Clash.Sized.Internal.Index.*#"+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , [i,j] <- indexLiterals' args+ -> reduce (mkIndexLit ty nTy kn (i * j))++-- ExtendingNum+ "Clash.Sized.Internal.Index.plus#"+ | mTy : nTy : _ <- tys+ , Right _ <- runExcept (tyNatSize tcm mTy)+ , Right _ <- runExcept (tyNatSize tcm nTy)+ , Just (i,j) <- indexLiterals args+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkIndexLit' resTyInfo (i + j))+ "Clash.Sized.Internal.Index.minus#"+ | mTy : nTy : _ <- tys+ , Right _ <- runExcept (tyNatSize tcm mTy)+ , Right _ <- runExcept (tyNatSize tcm nTy)+ , Just (i,j) <- indexLiterals args+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkIndexLit' resTyInfo (i - j))+ "Clash.Sized.Internal.Index.times#"+ | mTy : nTy : _ <- tys+ , Right _ <- runExcept (tyNatSize tcm mTy)+ , Right _ <- runExcept (tyNatSize tcm nTy)+ , Just (i,j) <- indexLiterals args+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkIndexLit' resTyInfo (i * j))++-- Integral+ "Clash.Sized.Internal.Index.quot#"+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , Just (i,j) <- indexLiterals args+ -> reduce $ catchDivByZero (mkIndexLit ty nTy kn (i `quot` j))+ "Clash.Sized.Internal.Index.rem#"+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , Just (i,j) <- indexLiterals args+ -> reduce $ catchDivByZero (mkIndexLit ty nTy kn (i `rem` j))+ "Clash.Sized.Internal.Index.toInteger#"+ | [PrimVal nm' _ _ [_, Lit (IntegerLiteral i)]] <- args+ , nm' == "Clash.Sized.Internal.Index.fromInteger#"+ -> reduce (integerToIntegerLiteral i)++-- Resize+ "Clash.Sized.Internal.Index.resize#"+ | Just (mTy,m) <- extractKnownNat tcm tys+ , [i] <- indexLiterals' args+ -> reduce (mkIndexLit ty mTy m i)++---------+-- Signed+---------+ "Clash.Sized.Internal.Signed.size#"+ | Just (_, kn) <- extractKnownNat tcm tys+ -> let (_,tyView -> TyConApp intTcNm _) = splitFunForallTy ty+ (Just intTc) = lookupUniqMap intTcNm tcm+ [intCon] = tyConDataCons intTc+ in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral kn))])++-- BitPack+ "Clash.Sized.Internal.Signed.pack#"+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i] <- signedLiterals' args+ -> let val = reifyNat kn (op (fromInteger i))+ in reduce (mkBitVectorLit ty nTy kn 0 val)+ where+ op :: KnownNat n => Signed n -> Proxy n -> Integer+ op s _ = toInteger (Signed.pack# s)+ "Clash.Sized.Internal.Signed.unpack#"+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [(0,i)] <- bitVectorLiterals' args+ -> let val = reifyNat kn (op (fromInteger i))+ in reduce (mkSignedLit ty nTy kn val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> Integer+ op s _ = toInteger (Signed.unpack# s)++-- Eq+ "Clash.Sized.Internal.Signed.eq#" | Just (i,j) <- signedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i == j))+ "Clash.Sized.Internal.Signed.neq#" | Just (i,j) <- signedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i /= j))++-- Ord+ "Clash.Sized.Internal.Signed.lt#" | Just (i,j) <- signedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i < j))+ "Clash.Sized.Internal.Signed.ge#" | Just (i,j) <- signedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i >= j))+ "Clash.Sized.Internal.Signed.gt#" | Just (i,j) <- signedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i > j))+ "Clash.Sized.Internal.Signed.le#" | Just (i,j) <- signedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i <= j))++-- Bounded+ "Clash.Sized.Internal.Signed.minBound#"+ | Just (litTy,mb) <- extractKnownNat tcm tys+ -> let minB = negate (2 ^ (mb - 1))+ in reduce (mkSignedLit ty litTy mb minB)+ "Clash.Sized.Internal.Signed.maxBound#"+ | Just (litTy,mb) <- extractKnownNat tcm tys+ -> let maxB = (2 ^ (mb - 1)) - 1+ in reduce (mkSignedLit ty litTy mb maxB)++-- Num+ "Clash.Sized.Internal.Signed.+#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftSigned2 (Signed.+#) ty tcm tys args)+ -> reduce (val)+ "Clash.Sized.Internal.Signed.-#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftSigned2 (Signed.-#) ty tcm tys args)+ -> reduce (val)+ "Clash.Sized.Internal.Signed.*#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftSigned2 (Signed.*#) ty tcm tys args)+ -> reduce (val)+ "Clash.Sized.Internal.Signed.negate#"+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i] <- signedLiterals' args+ -> let val = reifyNat kn (op (fromInteger i))+ in reduce (mkSignedLit ty nTy kn val)+ where+ op :: KnownNat n => Signed n -> Proxy n -> Integer+ op s _ = toInteger (Signed.negate# s)+ "Clash.Sized.Internal.Signed.abs#"+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i] <- signedLiterals' args+ -> let val = reifyNat kn (op (fromInteger i))+ in reduce (mkSignedLit ty nTy kn val)+ where+ op :: KnownNat n => Signed n -> Proxy n -> Integer+ op s _ = toInteger (Signed.abs# s)++-- ExtendingNum+ "Clash.Sized.Internal.Signed.plus#"+ | Just (i,j) <- signedLiterals args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ in reduce (mkSignedLit resTy resSizeTy resSizeInt (i+j))++ "Clash.Sized.Internal.Signed.minus#"+ | Just (i,j) <- signedLiterals args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ in reduce (mkSignedLit resTy resSizeTy resSizeInt (i-j))++ "Clash.Sized.Internal.Signed.times#"+ | Just (i,j) <- signedLiterals args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ in reduce (mkSignedLit resTy resSizeTy resSizeInt (i*j))++-- Integral+ "Clash.Sized.Internal.Signed.quot#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftSigned2 (Signed.quot#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ "Clash.Sized.Internal.Signed.rem#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftSigned2 (Signed.rem#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ "Clash.Sized.Internal.Signed.div#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftSigned2 (Signed.div#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ "Clash.Sized.Internal.Signed.mod#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftSigned2 (Signed.mod#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ "Clash.Sized.Internal.Signed.toInteger#"+ | [PrimVal nm' _ _ [_, Lit (IntegerLiteral i)]] <- args+ , nm' == "Clash.Sized.Internal.Signed.fromInteger#"+ -> reduce (integerToIntegerLiteral i)++-- Bits+ "Clash.Sized.Internal.Signed.and#"+ | [i,j] <- signedLiterals' args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> reduce (mkSignedLit ty nTy kn (i .&. j))+ "Clash.Sized.Internal.Signed.or#"+ | [i,j] <- signedLiterals' args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> reduce (mkSignedLit ty nTy kn (i .|. j))+ "Clash.Sized.Internal.Signed.xor#"+ | [i,j] <- signedLiterals' args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> reduce (mkSignedLit ty nTy kn (i `xor` j))++ "Clash.Sized.Internal.Signed.complement#"+ | [i] <- signedLiterals' args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> let val = reifyNat kn (op (fromInteger i))+ in reduce (mkSignedLit ty nTy kn val)+ where+ op :: KnownNat n => Signed n -> Proxy n -> Integer+ op u _ = toInteger (Signed.complement# u)++ "Clash.Sized.Internal.Signed.shiftL#"+ | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args+ -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+ in reduce (mkSignedLit ty nTy kn val)+ where+ op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Signed.shiftL# u i)+ "Clash.Sized.Internal.Signed.shiftR#"+ | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args+ -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+ in reduce (mkSignedLit ty nTy kn val)+ where+ op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Signed.shiftR# u i)+ "Clash.Sized.Internal.Signed.rotateL#"+ | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args+ -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+ in reduce (mkSignedLit ty nTy kn val)+ where+ op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Signed.rotateL# u i)+ "Clash.Sized.Internal.Signed.rotateR#"+ | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args+ -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+ in reduce (mkSignedLit ty nTy kn val)+ where+ op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Signed.rotateR# u i)++-- Resize+ "Clash.Sized.Internal.Signed.resize#" -- forall m n. (KnownNat n, KnownNat m) => Signed n -> Signed m+ | mTy : nTy : _ <- tys+ , Right mInt <- runExcept (tyNatSize tcm mTy)+ , Right nInt <- runExcept (tyNatSize tcm nTy)+ , [i] <- signedLiterals' args+ -> let val | nInt <= mInt = extended+ | otherwise = truncated+ extended = i+ mask = 1 `shiftL` fromInteger (mInt - 1)+ i' = i `mod` mask+ truncated = if testBit i (fromInteger nInt - 1)+ then (i' - mask)+ else i'+ in reduce (mkSignedLit ty mTy mInt val)+ "Clash.Sized.Internal.Signed.truncateB#" -- KnownNat m => Signed (m + n) -> Signed m+ | Just (mTy, km) <- extractKnownNat tcm tys+ , [i] <- signedLiterals' args+ -> let bitsKeep = (bit (fromInteger km)) - 1+ val = i .&. bitsKeep+ in reduce (mkSignedLit ty mTy km val)++-- SaturatingNum+-- No need to manually evaluate Clash.Sized.Internal.Signed.minBoundSym#+-- It is just implemented in terms of other primitives.+++-----------+-- Unsigned+-----------+ "Clash.Sized.Internal.Unsigned.size#"+ | Just (_, kn) <- extractKnownNat tcm tys+ -> let (_,ty') = splitFunForallTy ty+ (TyConApp intTcNm _) = tyView ty'+ (Just intTc) = lookupUniqMap intTcNm tcm+ [intCon] = tyConDataCons intTc+ in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral kn))])++-- BitPack+ "Clash.Sized.Internal.Unsigned.pack#"+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i] <- unsignedLiterals' args+ -> reduce (mkBitVectorLit ty nTy kn 0 i)+ "Clash.Sized.Internal.Unsigned.unpack#"+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i] <- bitVectorLiterals' args+ -> let val = reifyNat kn (op (toBV i))+ in reduce (mkUnsignedLit ty nTy kn val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> Integer+ op u _ = toInteger (Unsigned.unpack# u)++-- Eq+ "Clash.Sized.Internal.Unsigned.eq#" | Just (i,j) <- unsignedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i == j))+ "Clash.Sized.Internal.Unsigned.neq#" | Just (i,j) <- unsignedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i /= j))++-- Ord+ "Clash.Sized.Internal.Unsigned.lt#" | Just (i,j) <- unsignedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i < j))+ "Clash.Sized.Internal.Unsigned.ge#" | Just (i,j) <- unsignedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i >= j))+ "Clash.Sized.Internal.Unsigned.gt#" | Just (i,j) <- unsignedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i > j))+ "Clash.Sized.Internal.Unsigned.le#" | Just (i,j) <- unsignedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i <= j))++-- Bounded+ "Clash.Sized.Internal.Unsigned.minBound#"+ | Just (nTy,len) <- extractKnownNat tcm tys+ -> reduce (mkUnsignedLit ty nTy len 0)+ "Clash.Sized.Internal.Unsigned.maxBound#"+ | Just (litTy,mb) <- extractKnownNat tcm tys+ -> let maxB = (2 ^ mb) - 1+ in reduce (mkUnsignedLit ty litTy mb maxB)++-- Num+ "Clash.Sized.Internal.Unsigned.+#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.+#) ty tcm tys args)+ -> reduce val+ "Clash.Sized.Internal.Unsigned.-#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.-#) ty tcm tys args)+ -> reduce val+ "Clash.Sized.Internal.Unsigned.*#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.*#) ty tcm tys args)+ -> reduce val+ "Clash.Sized.Internal.Unsigned.negate#"+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i] <- unsignedLiterals' args+ -> let val = reifyNat kn (op (fromInteger i))+ in reduce (mkUnsignedLit ty nTy kn val)+ where+ op :: KnownNat n => Unsigned n -> Proxy n -> Integer+ op u _ = toInteger (Unsigned.negate# u)++-- ExtendingNum+ "Clash.Sized.Internal.Unsigned.plus#" -- :: Unsigned m -> Unsigned n -> Unsigned (Max m n + 1)+ | Just (i,j) <- unsignedLiterals args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ in reduce (mkUnsignedLit resTy resSizeTy resSizeInt (i+j))++ "Clash.Sized.Internal.Unsigned.minus#"+ | [i,j] <- unsignedLiterals' args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ val = reifyNat resSizeInt (runSizedF (Unsigned.-#) i j)+ in reduce (mkUnsignedLit resTy resSizeTy resSizeInt val)++ "Clash.Sized.Internal.Unsigned.times#"+ | Just (i,j) <- unsignedLiterals args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ in reduce (mkUnsignedLit resTy resSizeTy resSizeInt (i*j))++-- Integral+ "Clash.Sized.Internal.Unsigned.quot#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.quot#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ "Clash.Sized.Internal.Unsigned.rem#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.rem#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ "Clash.Sized.Internal.Unsigned.toInteger#"+ | [PrimVal nm' _ _ [_, Lit (IntegerLiteral i)]] <- args+ , nm' == "Clash.Sized.Internal.Unsigned.fromInteger#"+ -> reduce (integerToIntegerLiteral i)++-- Bits+ "Clash.Sized.Internal.Unsigned.and#"+ | Just (i,j) <- unsignedLiterals args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> reduce (mkUnsignedLit ty nTy kn (i .&. j))+ "Clash.Sized.Internal.Unsigned.or#"+ | Just (i,j) <- unsignedLiterals args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> reduce (mkUnsignedLit ty nTy kn (i .|. j))+ "Clash.Sized.Internal.Unsigned.xor#"+ | Just (i,j) <- unsignedLiterals args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> reduce (mkUnsignedLit ty nTy kn (i `xor` j))++ "Clash.Sized.Internal.Unsigned.complement#"+ | [i] <- unsignedLiterals' args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> let val = reifyNat kn (op (fromInteger i))+ in reduce (mkUnsignedLit ty nTy kn val)+ where+ op :: KnownNat n => Unsigned n -> Proxy n -> Integer+ op u _ = toInteger (Unsigned.complement# u)++ "Clash.Sized.Internal.Unsigned.shiftL#" -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n+ | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args+ -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+ in reduce (mkUnsignedLit ty nTy kn val)+ where+ op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Unsigned.shiftL# u i)+ "Clash.Sized.Internal.Unsigned.shiftR#" -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n+ | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args+ -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+ in reduce (mkUnsignedLit ty nTy kn val)+ where+ op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Unsigned.shiftR# u i)+ "Clash.Sized.Internal.Unsigned.rotateL#" -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n+ | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args+ -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+ in reduce (mkUnsignedLit ty nTy kn val)+ where+ op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Unsigned.rotateL# u i)+ "Clash.Sized.Internal.Unsigned.rotateR#" -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n+ | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args+ -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+ in reduce (mkUnsignedLit ty nTy kn val)+ where+ op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Unsigned.rotateR# u i)++-- Resize+ "Clash.Sized.Internal.Unsigned.resize#" -- forall n m . KnownNat m => Unsigned n -> Unsigned m+ | _ : mTy : _ <- tys+ , Right km <- runExcept (tyNatSize tcm mTy)+ , [i] <- unsignedLiterals' args+ -> let bitsKeep = (bit (fromInteger km)) - 1+ val = i .&. bitsKeep+ in reduce (mkUnsignedLit ty mTy km val)++ "Clash.Annotations.BitRepresentation.Deriving.dontApplyInHDL"+ | isSubj+ , f : a : _ <- args+ -> reduceWHNF (mkApps (valToTerm f) [Left (valToTerm a)])++--------+-- RTree+--------+ "Clash.Sized.RTree.textract"+ | isSubj+ , [DC _ tArgs] <- args+ -> reduceWHNF (Either.lefts tArgs !! 1)++ "Clash.Sized.RTree.tsplit"+ | isSubj+ , dTy : aTy : _ <- tys+ , [DC _ tArgs] <- args+ , (tyArgs,tyView -> TyConApp tupTcNm _) <- splitFunForallTy ty+ , TyConApp treeTcNm _ <- tyView (Either.rights tyArgs !! 0)+ -> let (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ in reduce $+ mkApps (Data tupDc)+ [Right (mkTyConApp treeTcNm [dTy,aTy])+ ,Right (mkTyConApp treeTcNm [dTy,aTy])+ ,Left (Either.lefts tArgs !! 1)+ ,Left (Either.lefts tArgs !! 2)+ ]++ "Clash.Sized.RTree.tdfold"+ | isSubj+ , pTy : kTy : aTy : _ <- tys+ , _ : p : f : g : ts : _ <- args+ , DC _ tArgs <- ts+ , Right k' <- runExcept (tyNatSize tcm kTy)+ -> case k' of+ 0 -> reduceWHNF (mkApps (valToTerm f) [Left (Either.lefts tArgs !! 1)])+ _ -> let k'ty = LitTy (NumTy (k'-1))+ (tyArgs,_) = splitFunForallTy ty+ (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 3)+ TyConApp snatTcNm _ = tyView (Either.rights tyArgs' !! 0)+ Just snatTc = lookupUniqMap snatTcNm tcm+ [snatDc] = tyConDataCons snatTc+ in reduceWHNF $+ mkApps (valToTerm g)+ [Right k'ty+ ,Left (mkApps (Data snatDc)+ [Right k'ty+ ,Left (Literal (NaturalLiteral (k'-1)))])+ ,Left (mkApps (Prim nm pInfo)+ [Right pTy+ ,Right k'ty+ ,Right aTy+ ,Left (Literal (NaturalLiteral (k'-1)))+ ,Left (valToTerm p)+ ,Left (valToTerm f)+ ,Left (valToTerm g)+ ,Left (Either.lefts tArgs !! 1)+ ])+ ,Left (mkApps (Prim nm pInfo)+ [Right pTy+ ,Right k'ty+ ,Right aTy+ ,Left (Literal (NaturalLiteral (k'-1)))+ ,Left (valToTerm p)+ ,Left (valToTerm f)+ ,Left (valToTerm g)+ ,Left (Either.lefts tArgs !! 2)+ ])+ ]++ "Clash.Sized.RTree.treplicate"+ | isSubj+ , let ty' = piResultTys tcm ty tys+ , (_,tyView -> TyConApp treeTcNm [lenTy,argTy]) <- splitFunForallTy ty'+ , Right len <- runExcept (tyNatSize tcm lenTy)+ -> let (Just treeTc) = lookupUniqMap treeTcNm tcm+ [lrCon,brCon] = tyConDataCons treeTc+ in reduce (mkRTree lrCon brCon argTy len (replicate (2^len) (valToTerm (last args))))++---------+-- Vector+---------+ "Clash.Sized.Vector.length" -- :: KnownNat n => Vec n a -> Int+ | isSubj+ , [nTy, _] <- tys+ , Right n <-runExcept (tyNatSize tcm nTy)+ -> let (_, tyView -> TyConApp intTcNm _) = splitFunForallTy ty+ (Just intTc) = lookupUniqMap intTcNm tcm+ [intCon] = tyConDataCons intTc+ in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral (toInteger n)))])++ "Clash.Sized.Vector.maxIndex"+ | isSubj+ , [nTy, _] <- tys+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> let (_, tyView -> TyConApp intTcNm _) = splitFunForallTy ty+ (Just intTc) = lookupUniqMap intTcNm tcm+ [intCon] = tyConDataCons intTc+ in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral (toInteger (n - 1))))])++-- Indexing+ "Clash.Sized.Vector.index_int" -- :: KnownNat n => Vec n a -> Int+ | nTy : aTy : _ <- tys+ , _ : xs : i : _ <- args+ , DC intDc [Left (Literal (IntLiteral i'))] <- i+ -> if i' < 0+ then Nothing+ else case xs of+ DC _ vArgs -> case runExcept (tyNatSize tcm nTy) of+ Right 0 -> Nothing+ Right n' ->+ if i' == 0+ then reduceWHNF (Either.lefts vArgs !! 1)+ else reduceWHNF $+ mkApps (Prim nm pInfo)+ [Right (LitTy (NumTy (n'-1)))+ ,Right aTy+ ,Left (Literal (NaturalLiteral (n'-1)))+ ,Left (Either.lefts vArgs !! 2)+ ,Left (mkApps (Data intDc)+ [Left (Literal (IntLiteral (i'-1)))])+ ]+ _ -> Nothing+ _ -> Nothing+ "Clash.Sized.Vector.head" -- :: Vec (n+1) a -> a+ | isSubj+ , [DC _ vArgs] <- args+ -> reduceWHNF (Either.lefts vArgs !! 1)+ "Clash.Sized.Vector.last" -- :: Vec (n+1) a -> a+ | isSubj+ , [DC _ vArgs] <- args+ , (Right _ : Right aTy : Right nTy : _) <- vArgs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> if n == 0+ then reduceWHNF (Either.lefts vArgs !! 1)+ else reduceWHNF+ (mkApps (Prim nm pInfo)+ [Right (LitTy (NumTy (n-1)))+ ,Right aTy+ ,Left (Either.lefts vArgs !! 2)+ ])+-- - Sub-vectors+ "Clash.Sized.Vector.tail" -- :: Vec (n+1) a -> Vec n a+ | isSubj+ , [DC _ vArgs] <- args+ -> reduceWHNF (Either.lefts vArgs !! 2)+ "Clash.Sized.Vector.init" -- :: Vec (n+1) a -> Vec n a+ | isSubj+ , [DC consCon vArgs] <- args+ , (Right _ : Right aTy : Right nTy : _) <- vArgs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> if n == 0+ then reduceWHNF (Either.lefts vArgs !! 2)+ else reduce $+ mkVecCons consCon aTy n+ (Either.lefts vArgs !! 1)+ (mkApps (Prim nm pInfo)+ [Right (LitTy (NumTy (n-1)))+ ,Right aTy+ ,Left (Either.lefts vArgs !! 2)])+ "Clash.Sized.Vector.select" -- :: (CmpNat (i+s) (s*n) ~ GT) => SNat f -> SNat s -> SNat n -> Vec (f + i) a -> Vec n a+ | isSubj+ , iTy : sTy : nTy : fTy : aTy : _ <- tys+ , eq : f : s : n : xs : _ <- args+ , Right n' <- runExcept (tyNatSize tcm nTy)+ , Right f' <- runExcept (tyNatSize tcm fTy)+ , Right i' <- runExcept (tyNatSize tcm iTy)+ , Right s' <- runExcept (tyNatSize tcm sTy)+ , DC _ vArgs <- xs+ -> case n' of+ 0 -> reduce (mkVecNil nilCon aTy)+ _ -> case f' of+ 0 -> let splitAtCall =+ mkApps (splitAtPrim snatTcNm vecTcNm)+ [Right sTy+ ,Right (LitTy (NumTy (i'-s')))+ ,Right aTy+ ,Left (valToTerm s)+ ,Left (valToTerm xs)+ ]+ fVecTy = mkTyConApp vecTcNm [sTy,aTy]+ iVecTy = mkTyConApp vecTcNm [LitTy (NumTy (i'-s')),aTy]+ -- Guaranteed no capture, so okay to use unsafe name generation+ fNm = mkUnsafeSystemName "fxs" 0+ iNm = mkUnsafeSystemName "ixs" 1+ fId = mkLocalId fVecTy fNm+ iId = mkLocalId iVecTy iNm+ tupPat = DataPat tupDc [] [fId,iId]+ iAlt = (tupPat, (Var iId))+ in reduce $+ mkVecCons consCon aTy n' (Either.lefts vArgs !! 1) $+ mkApps (Prim nm pInfo)+ [Right (LitTy (NumTy (i'-s')))+ ,Right sTy+ ,Right (LitTy (NumTy (n'-1)))+ ,Right (LitTy (NumTy 0))+ ,Right aTy+ ,Left (valToTerm eq)+ ,Left (Literal (NaturalLiteral 0))+ ,Left (valToTerm s)+ ,Left (Literal (NaturalLiteral (n'-1)))+ ,Left (Case splitAtCall iVecTy [iAlt])+ ]+ _ -> let splitAtCall =+ mkApps (splitAtPrim snatTcNm vecTcNm)+ [Right fTy+ ,Right iTy+ ,Right aTy+ ,Left (valToTerm f)+ ,Left (valToTerm xs)+ ]+ fVecTy = mkTyConApp vecTcNm [fTy,aTy]+ iVecTy = mkTyConApp vecTcNm [iTy,aTy]+ -- Guaranteed no capture, so okay to use unsafe name generation+ fNm = mkUnsafeSystemName "fxs" 0+ iNm = mkUnsafeSystemName "ixs" 1+ fId = mkLocalId fVecTy fNm+ iId = mkLocalId iVecTy iNm+ tupPat = DataPat tupDc [] [fId,iId]+ iAlt = (tupPat, (Var iId))+ in reduceWHNF $+ mkApps (Prim nm pInfo)+ [Right iTy+ ,Right sTy+ ,Right nTy+ ,Right (LitTy (NumTy 0))+ ,Right aTy+ ,Left (valToTerm eq)+ ,Left (Literal (NaturalLiteral 0))+ ,Left (valToTerm s)+ ,Left (valToTerm n)+ ,Left (Case splitAtCall iVecTy [iAlt])+ ]+ where+ (tyArgs,tyView -> TyConApp vecTcNm _) = splitFunForallTy ty+ Just vecTc = lookupUniqMap vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ TyConApp snatTcNm _ = tyView (Either.rights tyArgs !! 1)+ tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+-- - Splitting+ "Clash.Sized.Vector.splitAt" -- :: SNat m -> Vec (m + n) a -> (Vec m a, Vec n a)+ | isSubj+ , DC snatDc (Right mTy:_) <- head args+ , Right m <- runExcept (tyNatSize tcm mTy)+ -> let _:nTy:aTy:_ = tys+ -- Get the tuple data-constructor+ ty1 = piResultTys tcm ty tys+ (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty1+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ -- Get the vector data-constructors+ TyConApp vecTcNm _ = tyView (head tyArgs)+ Just vecTc = lookupUniqMap vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ -- Recursive call to @splitAt@+ splitAtRec v =+ mkApps (Prim nm pInfo)+ [Right (LitTy (NumTy (m-1)))+ ,Right nTy+ ,Right aTy+ ,Left (mkApps (Data snatDc)+ [ Right (LitTy (NumTy (m-1)))+ , Left (Literal (NaturalLiteral (m-1)))])+ ,Left v+ ]+ -- Projection either the first or second field of the recursive+ -- call to @splitAt@+ splitAtSelR v = Case (splitAtRec v)+ m1VecTy = mkTyConApp vecTcNm [LitTy (NumTy (m-1)),aTy]+ nVecTy = mkTyConApp vecTcNm [nTy,aTy]+ -- Guaranteed no capture, so okay to use unsafe name generation+ lNm = mkUnsafeSystemName "l" 0+ rNm = mkUnsafeSystemName "r" 1+ lId = mkLocalId m1VecTy lNm+ rId = mkLocalId nVecTy rNm+ tupPat = DataPat tupDc [] [lId,rId]+ lAlt = (tupPat, (Var lId))+ rAlt = (tupPat, (Var rId))++ in case m of+ -- (Nil,v)+ 0 -> reduce $+ mkApps (Data tupDc) $ (map Right tyArgs) +++ [ Left (mkVecNil nilCon aTy)+ , Left (valToTerm (last args))+ ]+ -- (x:xs) <- v+ m' | DC _ vArgs <- last args+ -- (x:fst (splitAt (m-1) xs),snd (splitAt (m-1) xs))+ -> reduce $+ mkApps (Data tupDc) $ (map Right tyArgs) +++ [ Left (mkVecCons consCon aTy m' (Either.lefts vArgs !! 1)+ (splitAtSelR (Either.lefts vArgs !! 2) m1VecTy [lAlt]))+ , Left (splitAtSelR (Either.lefts vArgs !! 2) nVecTy [rAlt])+ ]+ -- v doesn't reduce to a data-constructor+ _ -> Nothing++ "Clash.Sized.Vector.unconcat" -- :: KnownNat n => SNamt m -> Vec (n * m) a -> Vec n (Vec m a)+ | isSubj+ , kn : snat : v : _ <- args+ , nTy : mTy : aTy :_ <- tys+ , Lit (NaturalLiteral n) <- kn+ -> let ( Either.rights -> argTys, tyView -> TyConApp vecTcNm _) =+ splitFunForallTy ty+ Just vecTc = lookupUniqMap vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ TyConApp snatTcNm _ = tyView (argTys !! 1)+ n1mTy = mkTyConApp typeNatMul+ [mkTyConApp typeNatSub [nTy,LitTy (NumTy 1)]+ ,mTy]+ splitAtCall =+ mkApps (splitAtPrim snatTcNm vecTcNm)+ [Right mTy+ ,Right n1mTy+ ,Right aTy+ ,Left (valToTerm snat)+ ,Left (valToTerm v)+ ]+ mVecTy = mkTyConApp vecTcNm [mTy,aTy]+ n1mVecTy = mkTyConApp vecTcNm [n1mTy,aTy]+ -- Guaranteed no capture, so okay to use unsafe name generation+ asNm = mkUnsafeSystemName "as" 0+ bsNm = mkUnsafeSystemName "bs" 1+ asId = mkLocalId mVecTy asNm+ bsId = mkLocalId n1mVecTy bsNm+ tupPat = DataPat tupDc [] [asId,bsId]+ asAlt = (tupPat, (Var asId))+ bsAlt = (tupPat, (Var bsId))++ in case n of+ 0 -> reduce (mkVecNil nilCon mVecTy)+ _ -> reduce $+ mkVecCons consCon mVecTy n+ (Case splitAtCall mVecTy [asAlt])+ (mkApps (Prim nm pInfo)+ [Right (LitTy (NumTy (n-1)))+ ,Right mTy+ ,Right aTy+ ,Left (Literal (NaturalLiteral (n-1)))+ ,Left (valToTerm snat)+ ,Left (Case splitAtCall n1mVecTy [bsAlt])])+-- Construction+-- - initialisation+ "Clash.Sized.Vector.replicate" -- :: SNat n -> a -> Vec n a+ | isSubj+ , let ty' = piResultTys tcm ty tys+ , let (_,resTy) = splitFunForallTy ty'+ , (TyConApp vecTcNm [lenTy,argTy]) <- tyView resTy+ , Right len <- runExcept (tyNatSize tcm lenTy)+ -> let (Just vecTc) = lookupUniqMap vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ in reduce $+ mkVec nilCon consCon argTy len+ (replicate (fromInteger len) (valToTerm (last args)))+-- - Concatenation+ "Clash.Sized.Vector.++" -- :: Vec n a -> Vec m a -> Vec (n + m) a+ | isSubj+ , DC dc vArgs <- head args+ , Right nTy : Right aTy : _ <- vArgs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduce (valToTerm (last args))+ n' | (_ : _ : mTy : _) <- tys+ , Right m <- runExcept (tyNatSize tcm mTy)+ -> -- x : (xs ++ ys)+ reduce $+ mkVecCons dc aTy (n' + m) (Either.lefts vArgs !! 1)+ (mkApps (Prim nm pInfo)+ [Right (LitTy (NumTy (n'-1)))+ ,Right aTy+ ,Right mTy+ ,Left (Either.lefts vArgs !! 2)+ ,Left (valToTerm (last args))+ ])+ _ -> Nothing+ "Clash.Sized.Vector.concat" -- :: Vec n (Vec m a) -> Vec (n * m) a+ | isSubj+ , (nTy : mTy : aTy : _) <- tys+ , (xs : _) <- args+ , DC dc vArgs <- xs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduce (mkVecNil dc aTy)+ _ | _ : h' : t : _ <- Either.lefts vArgs+ , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+ -> reduceWHNF $+ mkApps (vecAppendPrim vecTcNm)+ [Right mTy+ ,Right aTy+ ,Right $ mkTyConApp typeNatMul+ [mkTyConApp typeNatSub [nTy,LitTy (NumTy 1)], mTy]+ ,Left h'+ ,Left $ mkApps (Prim nm pInfo)+ [ Right (LitTy (NumTy (n-1)))+ , Right mTy+ , Right aTy+ , Left t+ ]+ ]+ _ -> Nothing++-- Modifying vectors+ "Clash.Sized.Vector.replace_int" -- :: KnownNat n => Vec n a -> Int -> a -> Vec n a+ | nTy : aTy : _ <- tys+ , _ : xs : i : a : _ <- args+ , DC intDc [Left (Literal (IntLiteral i'))] <- i+ -> if i' < 0+ then Nothing+ else case xs of+ DC vecTcNm vArgs -> case runExcept (tyNatSize tcm nTy) of+ Right 0 -> Nothing+ Right n' ->+ if i' == 0+ then reduce (mkVecCons vecTcNm aTy n' (valToTerm a) (Either.lefts vArgs !! 2))+ else reduce $+ mkVecCons vecTcNm aTy n' (Either.lefts vArgs !! 1)+ (mkApps (Prim nm pInfo)+ [Right (LitTy (NumTy (n'-1)))+ ,Right aTy+ ,Left (Literal (NaturalLiteral (n'-1)))+ ,Left (Either.lefts vArgs !! 2)+ ,Left (mkApps (Data intDc)+ [Left (Literal (IntLiteral (i'-1)))])+ ,Left (valToTerm a)+ ])+ _ -> Nothing+ _ -> Nothing++ "Clash.Transformations.eqInt"+ | [ DC _ [Left (Literal (IntLiteral i))]+ , DC _ [Left (Literal (IntLiteral j))]+ ] <- args+ -> reduce (boolToBoolLiteral tcm ty (i == j))++-- - specialized permutations+ "Clash.Sized.Vector.reverse" -- :: Vec n a -> Vec n a+ | isSubj+ , nTy : aTy : _ <- tys+ , [DC vecDc vArgs] <- args+ -> case runExcept (tyNatSize tcm nTy) of+ Right 0 -> reduce (mkVecNil vecDc aTy)+ Right n+ | (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+ , let (Just vecTc) = lookupUniqMap vecTcNm tcm+ , let [nilCon,consCon] = tyConDataCons vecTc+ -> reduceWHNF $+ mkApps (vecAppendPrim vecTcNm)+ [Right (LitTy (NumTy (n-1)))+ ,Right aTy+ ,Right (LitTy (NumTy 1))+ ,Left (mkApps (Prim nm pInfo)+ [Right (LitTy (NumTy (n-1)))+ ,Right aTy+ ,Left (Either.lefts vArgs !! 2)+ ])+ ,Left (mkVec nilCon consCon aTy 1 [Either.lefts vArgs !! 1])+ ]+ _ -> Nothing+ "Clash.Sized.Vector.transpose" -- :: KnownNat n => Vec m (Vec n a) -> Vec n (Vec m a)+ | isSubj+ , nTy : mTy : aTy : _ <- tys+ , kn : xss : _ <- args+ , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+ , DC _ vArgs <- xss+ , Right n <- runExcept (tyNatSize tcm nTy)+ , Right m <- runExcept (tyNatSize tcm mTy)+ -> case m of+ 0 -> let (Just vecTc) = lookupUniqMap vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ in reduce $+ mkVec nilCon consCon (mkTyConApp vecTcNm [mTy,aTy]) n+ (replicate (fromInteger n) (mkVec nilCon consCon aTy 0 []))+ m' -> let (Just vecTc) = lookupUniqMap vecTcNm tcm+ [_,consCon] = tyConDataCons vecTc+ Just (consCoTy : _) = dataConInstArgTys consCon+ [mTy,aTy,LitTy (NumTy (m'-1))]+ in reduceWHNF $+ mkApps (vecZipWithPrim vecTcNm)+ [ Right aTy+ , Right (mkTyConApp vecTcNm [LitTy (NumTy (m'-1)),aTy])+ , Right (mkTyConApp vecTcNm [mTy,aTy])+ , Right nTy+ , Left (mkApps (Data consCon)+ [Right mTy+ ,Right aTy+ ,Right (LitTy (NumTy (m'-1)))+ ,Left (primCo consCoTy)+ ])+ , Left (Either.lefts vArgs !! 1)+ , Left (mkApps (Prim nm pInfo)+ [ Right nTy+ , Right (LitTy (NumTy (m'-1)))+ , Right aTy+ , Left (valToTerm kn)+ , Left (Either.lefts vArgs !! 2)+ ])+ ]+ "Clash.Sized.Vector.rotateLeftS" -- :: KnownNat n => Vec n a -> SNat d -> Vec n a+ | nTy : aTy : _ : _ <- tys+ , kn : xs : d : _ <- args+ , DC dc vArgs <- xs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduce (mkVecNil dc aTy)+ n' | DC snatDc [_,Left d'] <- d+ , (h2,[],Literal (NaturalLiteral d2)) <- whnf reduceConstant tcm isSubj (h,[],d')+ -> case (d2 `mod` n) of+ 0 -> reduce (valToTerm xs)+ d3 -> let (_,tyView -> TyConApp vecTcNm _) = splitFunForallTy ty+ (Just vecTc) = lookupUniqMap vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ in reduceWHNF' h2 $+ mkApps (Prim nm pInfo)+ [Right nTy+ ,Right aTy+ ,Right (LitTy (NumTy (d3-1)))+ ,Left (valToTerm kn)+ ,Left (mkApps (vecAppendPrim vecTcNm)+ [Right (LitTy (NumTy (n'-1)))+ ,Right aTy+ ,Right (LitTy (NumTy 1))+ ,Left (Either.lefts vArgs !! 2)+ ,Left (mkVec nilCon consCon aTy 1 [Either.lefts vArgs !! 1])])+ ,Left (mkApps (Data snatDc)+ [Right (LitTy (NumTy (d3-1)))+ ,Left (Literal (NaturalLiteral (d3-1)))])+ ]+ _ -> Nothing+ "Clash.Sized.Vector.rotateRightS" -- :: KnownNat n => Vec n a -> SNat d -> Vec n a+ | isSubj+ , nTy : aTy : _ : _ <- tys+ , kn : xs : d : _ <- args+ , DC dc _ <- xs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduce (mkVecNil dc aTy)+ n' | DC snatDc [_,Left d'] <- d+ , (h2,[],Literal (NaturalLiteral d2)) <- whnf reduceConstant tcm isSubj (h,[],d')+ -> case (d2 `mod` n) of+ 0 -> reduce (valToTerm xs)+ d3 -> let (_,tyView -> TyConApp vecTcNm _) = splitFunForallTy ty+ in reduceWHNF' h2 $+ mkApps (Prim nm pInfo)+ [Right nTy+ ,Right aTy+ ,Right (LitTy (NumTy (d3-1)))+ ,Left (valToTerm kn)+ ,Left (mkVecCons dc aTy n+ (mkApps (vecLastPrim vecTcNm)+ [Right (LitTy (NumTy (n'-1)))+ ,Right aTy+ ,Left (valToTerm xs)])+ (mkApps (vecInitPrim vecTcNm)+ [Right (LitTy (NumTy (n'-1)))+ ,Right aTy+ ,Left (valToTerm xs)]))+ ,Left (mkApps (Data snatDc)+ [Right (LitTy (NumTy (d3-1)))+ ,Left (Literal (NaturalLiteral (d3-1)))])+ ]+ _ -> Nothing+-- Element-wise operations+-- - mapping+ "Clash.Sized.Vector.map" -- :: (a -> b) -> Vec n a -> Vec n b+ | isSubj+ , DC dc vArgs <- args !! 1+ , aTy : bTy : nTy : _ <- tys+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduce (mkVecNil dc bTy)+ n' -> reduce $+ mkVecCons dc bTy n'+ (mkApps (valToTerm (args !! 0)) [Left (Either.lefts vArgs !! 1)])+ (mkApps (Prim nm pInfo)+ [Right aTy+ ,Right bTy+ ,Right (LitTy (NumTy (n' - 1)))+ ,Left (valToTerm (args !! 0))+ ,Left (Either.lefts vArgs !! 2)])+ "Clash.Sized.Vector.imap" -- :: forall n a b . KnownNat n => (Index n -> a -> b) -> Vec n a -> Vec n b+ | isSubj+ , nTy : aTy : bTy : _ <- tys+ , (tyArgs,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+ , let (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 1)+ , TyConApp indexTcNm _ <- tyView (Either.rights tyArgs' !! 0)+ , Right n <- runExcept (tyNatSize tcm nTy)+ , let iLit = mkIndexLit (Either.rights tyArgs' !! 0) nTy n 0+ -> reduceWHNF $+ mkApps (Prim "Clash.Sized.Vector.imap_go"+ (PrimInfo (vecImapGoTy vecTcNm indexTcNm) WorkNever))+ [Right nTy+ ,Right nTy+ ,Right aTy+ ,Right bTy+ ,Left iLit+ ,Left (valToTerm (args !! 1))+ ,Left (valToTerm (args !! 2))+ ]++ "Clash.Sized.Vector.imap_go"+ | isSubj+ , nTy : mTy : aTy : bTy : _ <- tys+ , n : f : xs : _ <- args+ , DC dc vArgs <- xs+ , Right n' <- runExcept (tyNatSize tcm nTy)+ , Right m <- runExcept (tyNatSize tcm mTy)+ -> case m of+ 0 -> reduce (mkVecNil dc bTy)+ m' -> let (tyArgs,_) = splitFunForallTy ty+ TyConApp indexTcNm _ = tyView (Either.rights tyArgs !! 0)+ iLit = mkIndexLit (Either.rights tyArgs !! 0) nTy n' 1+ in reduce $ mkVecCons dc bTy m'+ (mkApps (valToTerm f) [Left (valToTerm n),Left (Either.lefts vArgs !! 1)])+ (mkApps (Prim nm pInfo)+ [Right nTy+ ,Right (LitTy (NumTy (m'-1)))+ ,Right aTy+ ,Right bTy+ ,Left (mkApps (Prim "Clash.Sized.Internal.Index.+#"+ (PrimInfo (indexAddTy indexTcNm) WorkVariable))+ [Right nTy+ ,Left (Literal (NaturalLiteral n'))+ ,Left (valToTerm n)+ ,Left iLit+ ])+ ,Left (valToTerm f)+ ,Left (Either.lefts vArgs !! 2)+ ])++-- - Zipping+ "Clash.Sized.Vector.zipWith" -- :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c+ | isSubj+ , aTy : bTy : cTy : nTy : _ <- tys+ , f : xs : ys : _ <- args+ , DC dc vArgs <- xs+ , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduce (mkVecNil dc cTy)+ n' -> reduce $ mkVecCons dc cTy n'+ (mkApps (valToTerm f)+ [Left (Either.lefts vArgs !! 1)+ ,Left (mkApps (vecHeadPrim vecTcNm)+ [Right (LitTy (NumTy (n'-1)))+ ,Right bTy+ ,Left (valToTerm ys)+ ])+ ])+ (mkApps (Prim nm pInfo)+ [Right aTy+ ,Right bTy+ ,Right cTy+ ,Right (LitTy (NumTy (n' - 1)))+ ,Left (valToTerm f)+ ,Left (Either.lefts vArgs !! 2)+ ,Left (mkApps (vecTailPrim vecTcNm)+ [Right (LitTy (NumTy (n'-1)))+ ,Right bTy+ ,Left (valToTerm ys)+ ])])++-- Folding+ "Clash.Sized.Vector.foldr" -- :: (a -> b -> b) -> b -> Vec n a -> b+ | isSubj+ , aTy : bTy : nTy : _ <- tys+ , f : z : xs : _ <- args+ , DC _ vArgs <- xs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduce (valToTerm z)+ _ -> reduceWHNF $+ mkApps (valToTerm f)+ [Left (Either.lefts vArgs !! 1)+ ,Left (mkApps (Prim nm pInfo)+ [Right aTy+ ,Right bTy+ ,Right (LitTy (NumTy (n-1)))+ ,Left (valToTerm f)+ ,Left (valToTerm z)+ ,Left (Either.lefts vArgs !! 2)+ ])+ ]+ "Clash.Sized.Vector.fold" -- :: (a -> a -> a) -> Vec (n + 1) a -> a+ | isSubj+ , aTy : nTy : _ <- tys+ , f : vs : _ <- args+ , DC _ vArgs <- vs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduceWHNF (Either.lefts vArgs !! 1)+ _ -> let (tyArgs,_) = splitFunForallTy ty+ TyConApp vecTcNm _ = tyView (Either.rights tyArgs !! 1)+ tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ n' = n+1+ m = n' `div` 2+ n1 = n' - m+ mTy = LitTy (NumTy m)+ m'ty = LitTy (NumTy (m-1))+ n1mTy = LitTy (NumTy n1)+ n1m'ty = LitTy (NumTy (n1-1))+ splitAtCall =+ mkApps (Prim "Clash.Sized.Vector.fold_split"+ (PrimInfo (foldSplitAtTy vecTcNm) WorkNever))+ [Right mTy+ ,Right n1mTy+ ,Right aTy+ ,Left (Literal (NaturalLiteral m))+ ,Left (valToTerm vs)+ ]+ mVecTy = mkTyConApp vecTcNm [mTy,aTy]+ n1mVecTy = mkTyConApp vecTcNm [n1mTy,aTy]+ -- Guaranteed no capture, so okay to use unsafe name generation+ asNm = mkUnsafeSystemName "as" 0+ bsNm = mkUnsafeSystemName "bs" 1+ asId = mkLocalId mVecTy asNm+ bsId = mkLocalId n1mVecTy bsNm+ tupPat = DataPat tupDc [] [asId,bsId]+ asAlt = (tupPat, (Var asId))+ bsAlt = (tupPat, (Var bsId))+ in reduceWHNF $+ mkApps (valToTerm f)+ [Left (mkApps (Prim nm pInfo)+ [Right aTy+ ,Right m'ty+ ,Left (valToTerm f)+ ,Left (Case splitAtCall mVecTy [asAlt])+ ])+ ,Left (mkApps (Prim nm pInfo)+ [Right aTy+ ,Right n1m'ty+ ,Left (valToTerm f)+ ,Left (Case splitAtCall n1mVecTy [bsAlt])+ ])+ ]+++ "Clash.Sized.Vector.fold_split" -- :: Natural -> Vec (m + n) a -> (Vec m a, Vec n a)+ | isSubj+ , mTy : nTy : aTy : _ <- tys+ , Right m <- runExcept (tyNatSize tcm mTy)+ -> let -- Get the tuple data-constructor+ ty1 = piResultTys tcm ty tys+ (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty1+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ -- Get the vector data-constructors+ TyConApp vecTcNm _ = tyView (head tyArgs)+ Just vecTc = lookupUniqMap vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ -- Recursive call to @splitAt@+ splitAtRec v =+ mkApps (Prim nm pInfo)+ [Right (LitTy (NumTy (m-1)))+ ,Right nTy+ ,Right aTy+ ,Left (Literal (NaturalLiteral (m-1)))+ ,Left v+ ]+ -- Projection either the first or second field of the recursive+ -- call to @splitAt@+ splitAtSelR v = Case (splitAtRec v)+ m1VecTy = mkTyConApp vecTcNm [LitTy (NumTy (m-1)),aTy]+ nVecTy = mkTyConApp vecTcNm [nTy,aTy]+ -- Guaranteed no capture, so okay to use unsafe name generation+ lNm = mkUnsafeSystemName "l" 0+ rNm = mkUnsafeSystemName "r" 1+ lId = mkLocalId m1VecTy lNm+ rId = mkLocalId nVecTy rNm+ tupPat = DataPat tupDc [] [lId,rId]+ lAlt = (tupPat, (Var lId))+ rAlt = (tupPat, (Var rId))+ in case m of+ -- (Nil,v)+ 0 -> reduce $+ mkApps (Data tupDc) $ (map Right tyArgs) +++ [ Left (mkVecNil nilCon aTy)+ , Left (valToTerm (last args))+ ]+ -- (x:xs) <- v+ m' | DC _ vArgs <- last args+ -- (x:fst (splitAt (m-1) xs),snd (splitAt (m-1) xs))+ -> reduce $+ mkApps (Data tupDc) $ (map Right tyArgs) +++ [ Left (mkVecCons consCon aTy m' (Either.lefts vArgs !! 1)+ (splitAtSelR (Either.lefts vArgs !! 2) m1VecTy [lAlt]))+ , Left (splitAtSelR (Either.lefts vArgs !! 2) nVecTy [rAlt])+ ]+ -- v doesn't reduce to a data-constructor+ _ -> Nothing+-- - Specialised folds+ "Clash.Sized.Vector.dfold"+ | isSubj+ , pTy : kTy : aTy : _ <- tys+ , _ : p : f : z : xs : _ <- args+ , DC _ vArgs <- xs+ , Right k' <- runExcept (tyNatSize tcm kTy)+ -> case k' of+ 0 -> reduce (valToTerm z)+ _ -> let (tyArgs,_) = splitFunForallTy ty+ (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 2)+ TyConApp snatTcNm _ = tyView (Either.rights tyArgs' !! 0)+ Just snatTc = lookupUniqMap snatTcNm tcm+ [snatDc] = tyConDataCons snatTc+ k'ty = LitTy (NumTy (k'-1))+ in reduceWHNF $+ mkApps (valToTerm f)+ [Right k'ty+ ,Left (mkApps (Data snatDc)+ [Right k'ty+ ,Left (Literal (NaturalLiteral (k'-1)))])+ ,Left (Either.lefts vArgs !! 1)+ ,Left (mkApps (Prim nm pInfo)+ [Right pTy+ ,Right k'ty+ ,Right aTy+ ,Left (Literal (NaturalLiteral (k'-1)))+ ,Left (valToTerm p)+ ,Left (valToTerm f)+ ,Left (valToTerm z)+ ,Left (Either.lefts vArgs !! 2)+ ])+ ]+ "Clash.Sized.Vector.dtfold"+ | isSubj+ , pTy : kTy : aTy : _ <- tys+ , _ : p : f : g : xs : _ <- args+ , DC _ vArgs <- xs+ , Right k' <- runExcept (tyNatSize tcm kTy)+ -> case k' of+ 0 -> reduceWHNF (mkApps (valToTerm f) [Left (Either.lefts vArgs !! 1)])+ _ -> let (tyArgs,_) = splitFunForallTy ty+ TyConApp vecTcNm _ = tyView (Either.rights tyArgs !! 4)+ (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 3)+ TyConApp snatTcNm _ = tyView (Either.rights tyArgs' !! 0)+ Just snatTc = lookupUniqMap snatTcNm tcm+ [snatDc] = tyConDataCons snatTc+ tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ k'ty = LitTy (NumTy (k'-1))+ k2ty = LitTy (NumTy (2^(k'-1)))+ splitAtCall =+ mkApps (splitAtPrim snatTcNm vecTcNm)+ [Right k2ty+ ,Right k2ty+ ,Right aTy+ ,Left (mkApps (Data snatDc)+ [Right k2ty+ ,Left (Literal (NaturalLiteral (2^(k'-1))))])+ ,Left (valToTerm xs)+ ]+ xsSVecTy = mkTyConApp vecTcNm [k2ty,aTy]+ -- Guaranteed no capture, so okay to use unsafe name generation+ xsLNm = mkUnsafeSystemName "xsL" 0+ xsRNm = mkUnsafeSystemName "xsR" 1+ xsLId = mkLocalId k2ty xsLNm+ xsRId = mkLocalId k2ty xsRNm+ tupPat = DataPat tupDc [] [xsLId,xsRId]+ asAlt = (tupPat, (Var xsLId))+ bsAlt = (tupPat, (Var xsRId))+ in reduceWHNF $+ mkApps (valToTerm g)+ [Right k'ty+ ,Left (mkApps (Data snatDc)+ [Right k'ty+ ,Left (Literal (NaturalLiteral (k'-1)))])+ ,Left (mkApps (Prim nm pInfo)+ [Right pTy+ ,Right k'ty+ ,Right aTy+ ,Left (Literal (NaturalLiteral (k'-1)))+ ,Left (valToTerm p)+ ,Left (valToTerm f)+ ,Left (valToTerm g)+ ,Left (Case splitAtCall xsSVecTy [asAlt])])+ ,Left (mkApps (Prim nm pInfo)+ [Right pTy+ ,Right k'ty+ ,Right aTy+ ,Left (Literal (NaturalLiteral (k'-1)))+ ,Left (valToTerm p)+ ,Left (valToTerm f)+ ,Left (valToTerm g)+ ,Left (Case splitAtCall xsSVecTy [bsAlt])])+ ]+-- Misc+ "Clash.Sized.Vector.lazyV"+ | isSubj+ , nTy : aTy : _ <- tys+ , _ : xs : _ <- args+ , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> let (Just vecTc) = lookupUniqMap vecTcNm tcm+ [nilCon,_] = tyConDataCons vecTc+ in reduce (mkVecNil nilCon aTy)+ n' -> let (Just vecTc) = lookupUniqMap vecTcNm tcm+ [_,consCon] = tyConDataCons vecTc+ in reduce $ mkVecCons consCon aTy n'+ (mkApps (vecHeadPrim vecTcNm)+ [ Right (LitTy (NumTy (n' - 1)))+ , Right aTy+ , Left (valToTerm xs)+ ])+ (mkApps (Prim nm pInfo)+ [ Right (LitTy (NumTy (n' - 1)))+ , Right aTy+ , Left (Literal (NaturalLiteral (n'-1)))+ , Left (mkApps (vecTailPrim vecTcNm)+ [ Right (LitTy (NumTy (n'-1)))+ , Right aTy+ , Left (valToTerm xs)+ ])+ ])+-- Traversable+ "Clash.Sized.Vector.traverse#"+ | isSubj+ , aTy : fTy : bTy : nTy : _ <- tys+ , apDict : f : xs : _ <- args+ , DC dc vArgs <- xs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> let (pureF,ids') = runPEM (mkSelectorCase $(curLoc) is0 tcm (valToTerm apDict) 1 1) ids+ in reduceWHNF' (Heap gh gbl h' ids' is0) $+ mkApps pureF+ [Right (mkTyConApp (vecTcNm) [nTy,bTy])+ ,Left (mkVecNil dc bTy)]+ _ -> let ((fmapF,apF),ids') = flip runPEM ids $ do+ fDict <- mkSelectorCase $(curLoc) is0 tcm (valToTerm apDict) 1 0+ fmapF' <- mkSelectorCase $(curLoc) is0 tcm fDict 1 0+ apF' <- mkSelectorCase $(curLoc) is0 tcm (valToTerm apDict) 1 2+ return (fmapF',apF')+ n'ty = LitTy (NumTy (n-1))+ Just (consCoTy : _) = dataConInstArgTys dc [nTy,bTy,n'ty]+ in reduceWHNF' (Heap gh gbl h' ids' is0) $+ mkApps apF+ [Right (mkTyConApp vecTcNm [n'ty,bTy])+ ,Right (mkTyConApp vecTcNm [nTy,bTy])+ ,Left (mkApps fmapF+ [Right bTy+ ,Right (mkFunTy (mkTyConApp vecTcNm [n'ty,bTy])+ (mkTyConApp vecTcNm [nTy,bTy]))+ ,Left (mkApps (Data dc)+ [Right nTy+ ,Right bTy+ ,Right n'ty+ ,Left (primCo consCoTy)])+ ,Left (mkApps (valToTerm f)+ [Left (Either.lefts vArgs !! 1)])+ ])+ ,Left (mkApps (Prim nm pInfo)+ [Right aTy+ ,Right fTy+ ,Right bTy+ ,Right n'ty+ ,Left (valToTerm apDict)+ ,Left (valToTerm f)+ ,Left (Either.lefts vArgs !! 2)+ ])+ ]+ where+ (tyArgs,_) = splitFunForallTy ty+ TyConApp vecTcNm _ = tyView (Either.rights tyArgs !! 2)+ Heap gh gbl h' ids is0 = h++-- BitPack+ "Clash.Sized.Vector.concatBitVector#"+ | isSubj+ , nTy : mTy : _ <- tys+ , _ : km : v : _ <- args+ , DC _ vArgs <- v+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> let resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkBitVectorLit' resTyInfo 0 0)+ n' | Right m <- runExcept (tyNatSize tcm mTy)+ , (_,tyView -> TyConApp bvTcNm _) <- splitFunForallTy ty+ -> reduceWHNF $+ mkApps (bvAppendPrim bvTcNm)+ [ Right (mkTyConApp typeNatMul [LitTy (NumTy (n'-1)),mTy])+ , Right mTy+ , Left (Literal (NaturalLiteral ((n'-1)*m)))+ , Left (Either.lefts vArgs !! 1)+ , Left (mkApps (Prim nm pInfo)+ [ Right (LitTy (NumTy (n'-1)))+ , Right mTy+ , Left (Literal (NaturalLiteral (n'-1)))+ , Left (valToTerm km)+ , Left (Either.lefts vArgs !! 2)+ ])+ ]+ _ -> Nothing+ "Clash.Sized.Vector.unconcatBitVector#"+ | isSubj+ , nTy : mTy : _ <- tys+ , _ : km : bv : _ <- args+ , (_,tyView -> TyConApp vecTcNm [_,bvMTy]) <- splitFunForallTy ty+ , TyConApp bvTcNm _ <- tyView bvMTy+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 ->+ let (Just vecTc) = lookupUniqMap vecTcNm tcm+ [nilCon,_] = tyConDataCons vecTc+ in reduce (mkVecNil nilCon (mkTyConApp bvTcNm [mTy]))+ n' | Right m <- runExcept (tyNatSize tcm mTy) ->+ let Just vecTc = lookupUniqMap vecTcNm tcm+ [_,consCon] = tyConDataCons vecTc+ tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)+ Just tupTc = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ splitCall =+ mkApps (bvSplitPrim bvTcNm)+ [ Right (mkTyConApp typeNatMul [LitTy (NumTy (n'-1)),mTy])+ , Right mTy+ , Left (Literal (NaturalLiteral ((n'-1)*m)))+ , Left (valToTerm bv)+ ]+ mBVTy = mkTyConApp bvTcNm [mTy]+ n1BVTy = mkTyConApp bvTcNm+ [mkTyConApp typeNatMul+ [LitTy (NumTy (n'-1))+ ,mTy]]+ -- Guaranteed no capture, so okay to use unsafe name generation+ xNm = mkUnsafeSystemName "x" 0+ bvNm = mkUnsafeSystemName "bv'" 1+ xId = mkLocalId mBVTy xNm+ bvId = mkLocalId n1BVTy bvNm+ tupPat = DataPat tupDc [] [xId,bvId]+ xAlt = (tupPat, (Var xId))+ bvAlt = (tupPat, (Var bvId))++ in reduce $ mkVecCons consCon (mkTyConApp bvTcNm [mTy]) n'+ (Case splitCall mBVTy [xAlt])+ (mkApps (Prim nm pInfo)+ [ Right (LitTy (NumTy (n'-1)))+ , Right mTy+ , Left (Literal (NaturalLiteral (n'-1)))+ , Left (valToTerm km)+ , Left (Case splitCall n1BVTy [bvAlt])+ ])+ _ -> Nothing+ _ -> Nothing+ where+ ty = primType pInfo++ checkNaturalRange1 nTy i f =+ checkNaturalRange nTy [i]+ (\[i'] -> naturalToNaturalLiteral (f i'))++ checkNaturalRange2 nTy i j f =+ checkNaturalRange nTy [i, j]+ (\[i', j'] -> naturalToNaturalLiteral (f i' j'))++ -- Check given integer's range. If any of them are less than zero, give up+ -- and return an undefined type.+ checkNaturalRange+ :: Type+ -- Type of GHC.Natural.Natural ^+ -> [Integer]+ -> ([Natural] -> Term)+ -> Term+ checkNaturalRange nTy natsAsInts f =+ if any (<0) natsAsInts then+ undefinedTm nTy+ else+ f (map fromInteger natsAsInts)++ reduce :: Term -> Maybe (Heap, Stack, Term)+ reduce e = case isX e of+ Left msg -> trace (unlines ["Warning: Not evaluating constant expression:", show nm, "Because doing so generates an XException:", msg]) Nothing+ Right e' -> Just (h,k,e')+ reduceWHNF e = let (h2,[],e') = whnf reduceConstant tcm isSubj (h,[],e)+ in Just (h2,k,e')+ reduceWHNF' h' e = let (h2,[],e') = whnf reduceConstant tcm isSubj (h',[],e)+ in Just (h2,k,e')++ makeUndefinedIf :: Exception e => (e -> Bool) -> Term -> Term+ makeUndefinedIf wantToHandle tm =+ case unsafeDupablePerformIO $ tryJust selectException (evaluate $ force tm) of+ Right b -> b+ Left e -> trace (msg e) (undefinedTm resTy)+ where+ resTy = getResultTy tcm ty tys+ selectException e | wantToHandle e = Just e+ | otherwise = Nothing+ msg e = unlines ["Warning: caught exception: \"" ++ show e ++ "\" while trying to evaluate: "+ , showPpr (mkApps (Prim nm pInfo) (map (Left . valToTerm) args))+ ]++ catchDivByZero = makeUndefinedIf (==DivideByZero)++typedLiterals' :: (Value -> Maybe a) -> [Value] -> [a]+typedLiterals' typedLiteral = mapMaybe typedLiteral++doubleLiterals' :: [Value] -> [Rational]+doubleLiterals' = typedLiterals' doubleLiteral+ where+ doubleLiteral x = case x of+ Lit (DoubleLiteral i) -> Just i+ _ -> Nothing++floatLiterals' :: [Value] -> [Rational]+floatLiterals' = typedLiterals' floatLiteral+ where+ floatLiteral x = case x of+ Lit (FloatLiteral i) -> Just i+ _ -> Nothing++integerLiterals :: [Value] -> Maybe (Integer, Integer)+integerLiterals args = case integerLiterals' args of+ [i,j] -> Just (i,j)+ _ -> Nothing++naturalLiterals :: [Value] -> Maybe (Integer, Integer)+naturalLiterals args = case naturalLiterals' args of+ [i,j] -> Just (i, j)+ _ -> Nothing++integerLiterals' :: [Value] -> [Integer]+integerLiterals' = typedLiterals' integerLiteral++naturalLiterals' :: [Value] -> [Integer]+naturalLiterals' = typedLiterals' naturalLiteral++intLiterals :: [Value] -> Maybe (Integer,Integer)+intLiterals args = case args of+ [Lit (IntLiteral i), Lit (IntLiteral j)] -> Just (i,j)+ _ -> Nothing++intLiterals' :: [Value] -> [Integer]+intLiterals' = typedLiterals' intLiteral+ where+ intLiteral x = case x of+ Lit (IntLiteral i) -> Just i+ _ -> Nothing++intCLiteral :: Value -> Maybe Integer+intCLiteral (DC _ [Left (Literal (IntLiteral i))]) = Just i+intCLiteral _ = Nothing++intCLiterals :: [Value] -> Maybe (Integer, Integer)+intCLiterals (a1:a2:_) = liftA2 (,) (intCLiteral a1) (intCLiteral a2)+intCLiterals _ = Nothing++intCLiterals' :: [Value] -> [Integer]+intCLiterals' = catMaybes . map intCLiteral++mkIntCLiteral+ :: HasCallStack+ => Value+ -- ^ Some existing intC literal. To construct a new intC literal, this+ -- function needs the dataconstructor.+ -> Integer+ -- ^ New value of intC literal+ -> Term+mkIntCLiteral (DC dc [Left (Literal (IntLiteral _))]) i =+ App (Data dc) (Literal (IntLiteral i))+mkIntCLiteral v _i =+ error $ "Report as bug: mkIntCLiteral was called with wrong value: " ++ show v++wordLiterals :: [Value] -> Maybe (Integer,Integer)+wordLiterals args = case args of+ [Lit (WordLiteral i), Lit (WordLiteral j)] -> Just (i,j)+ _ -> Nothing+wordLiterals' :: [Value] -> [Integer]+wordLiterals' = typedLiterals' wordLiteral+ where+ wordLiteral x = case x of+ Lit (WordLiteral i) -> Just i+ _ -> Nothing++charLiterals :: [Value] -> Maybe (Char,Char)+charLiterals args = case args of+ [Lit (CharLiteral i), Lit (CharLiteral j)] -> Just (i,j)+ _ -> Nothing++charLiterals' :: [Value] -> [Char]+charLiterals' = typedLiterals' charLiteral+ where+ charLiteral x = case x of+ Lit (CharLiteral c) -> Just c+ _ -> Nothing++sizedLiterals :: Text -> [Value] -> Maybe (Integer,Integer)+sizedLiterals szCon args+ = case args of+ ([ PrimVal nm _ _ [_, Lit (IntegerLiteral i)]+ , PrimVal nm' _ _ [_, Lit (IntegerLiteral j)]])+ | nm == szCon+ , nm' == szCon -> Just (i,j)+ _ -> Nothing++sizedLiterals' :: Text -> [Value] -> [Integer]+sizedLiterals' szCon = typedLiterals' (sizedLiteral szCon)++sizedLiteral :: Text -> Value -> Maybe Integer+sizedLiteral szCon val = case val of+ PrimVal nm _ _ [_, Lit (IntegerLiteral i)] | nm == szCon -> Just i+ _ -> Nothing++bitLiterals+ :: [Value]+ -> [(Integer,Integer)]+bitLiterals = map normalizeBit . typedLiterals' go+ where+ normalizeBit (msk,v) = (msk .&. 1, v .&. 1)+ go val = case val of+ PrimVal nm _ _ [Lit (IntegerLiteral m), Lit (IntegerLiteral i)]+ | nm == "Clash.Sized.Internal.BitVector.fromInteger##"+ -> Just (m,i)+ _ -> Nothing++indexLiterals, signedLiterals, unsignedLiterals+ :: [Value] -> Maybe (Integer,Integer)+indexLiterals = sizedLiterals "Clash.Sized.Internal.Index.fromInteger#"+signedLiterals = sizedLiterals "Clash.Sized.Internal.Signed.fromInteger#"+unsignedLiterals = sizedLiterals "Clash.Sized.Internal.Unsigned.fromInteger#"++bitVectorLiterals+ :: [Value] -> Maybe ((Integer,Integer),(Integer,Integer))+bitVectorLiterals args+ = case args of+ ([ PrimVal nm _ _ [_, Lit (IntegerLiteral mi), Lit (IntegerLiteral i)]+ , PrimVal nm' _ _ [_, Lit (IntegerLiteral mj), Lit (IntegerLiteral j)]])+ | nm == "Clash.Sized.Internal.BitVector.fromInteger#"+ , nm' == "Clash.Sized.Internal.BitVector.fromInteger#" -> Just ((mi,i),(mj,j))+ _ -> Nothing++indexLiterals', signedLiterals', unsignedLiterals'+ :: [Value] -> [Integer]+indexLiterals' = sizedLiterals' "Clash.Sized.Internal.Index.fromInteger#"+signedLiterals' = sizedLiterals' "Clash.Sized.Internal.Signed.fromInteger#"+unsignedLiterals' = sizedLiterals' "Clash.Sized.Internal.Unsigned.fromInteger#"++bitVectorLiterals'+ :: [Value] -> [(Integer,Integer)]+bitVectorLiterals' = mapMaybe go+ where+ go :: Value -> Maybe (Integer,Integer)+ go val = case val of+ PrimVal nm _ _ [_, Lit (IntegerLiteral mi), Lit (IntegerLiteral i)]+ | nm == "Clash.Sized.Internal.BitVector.fromInteger#" -> Just (mi, i)+ _ -> Nothing++toBV :: (Integer,Integer) -> BitVector n+toBV = uncurry BV++splitBV :: BitVector n -> (Integer,Integer)+splitBV (BV msk val) = (msk,val)++valArgs+ :: Value+ -> Maybe [Term]+valArgs (PrimVal _ _ _ vs) = Just (map valToTerm vs)+valArgs (DC _ args) = Just (Either.lefts args)+valArgs _ = Nothing+++-- Tries to match literal arguments to a function like+-- (Unsigned.shiftL# :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n)+sizedLitIntLit+ :: Text -> TyConMap -> [Type] -> [Value]+ -> Maybe (Type,Integer,Integer,Integer)+sizedLitIntLit szCon tcm tys args+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , [_+ ,PrimVal nm _ _ [_,Lit (IntegerLiteral i)]+ ,valArgs -> Just [Literal (IntLiteral j)]+ ] <- args+ , nm == szCon+ = Just (nTy,kn,i,j)+ | otherwise+ = Nothing++signedLitIntLit, unsignedLitIntLit+ :: TyConMap -> [Type] -> [Value]+ -> Maybe (Type,Integer,Integer,Integer)+signedLitIntLit = sizedLitIntLit "Clash.Sized.Internal.Signed.fromInteger#"+unsignedLitIntLit = sizedLitIntLit "Clash.Sized.Internal.Unsigned.fromInteger#"++bitVectorLitIntLit+ :: TyConMap -> [Type] -> [Value]+ -> Maybe (Type,Integer,(Integer,Integer),Integer)+bitVectorLitIntLit tcm tys args+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , [_+ ,PrimVal nm _ _ [_,Lit (IntegerLiteral m),Lit (IntegerLiteral i)]+ ,valArgs -> Just [Literal (IntLiteral j)]+ ] <- args+ , nm == "Clash.Sized.Internal.BitVector.fromInteger#"+ = Just (nTy,kn,(m,i),j)+ | otherwise+ = Nothing++-- From an argument list to function of type+-- forall n. KnownNat n => ...+-- extract (nTy,nInt)+-- where nTy is the Type of n+-- and nInt is its value as an Integer+extractKnownNat :: TyConMap -> [Type] -> Maybe (Type, Integer)+extractKnownNat tcm tys = case tys of+ nTy : _ | Right nInt <- runExcept (tyNatSize tcm nTy)+ -> Just (nTy, nInt)+ _ -> Nothing++extractKnownNatVal :: TyConMap -> [Type] -> Maybe Integer+extractKnownNatVal tcm tys = fmap snd (extractKnownNat tcm tys)++-- From an argument list to function of type+-- forall n m o .. . (KnownNat n, KnownNat m, KnownNat o, ..) => ...+-- extract [(nTy,nInt), (mTy,mInt), (oTy,oInt)]+-- where nTy is the Type of n+-- and nInt is its value as an Integer+extractKnownNats :: TyConMap -> [Type] -> [(Type, Integer)]+extractKnownNats tcm tys =+ catMaybes (map (extractKnownNat tcm . pure) tys)++extractKnownNatVals :: TyConMap -> [Type] -> [Integer]+extractKnownNatVals tcm tys = map snd (extractKnownNats tcm tys)++-- Construct a constant term of a sized type+mkSizedLit+ :: (Type -> Term)+ -- ^ Type constructor?+ -> Type+ -- ^ Result type+ -> Type+ -- ^ forall n.+ -> Integer+ -- ^ KnownNat n+ -> Integer+ -- ^ Value to construct+ -> Term+mkSizedLit conPrim ty nTy kn val =+ mkApps+ (conPrim sTy)+ [ Right nTy+ , Left (Literal (NaturalLiteral kn))+ , Left (Literal (IntegerLiteral val)) ]+ where+ (_,sTy) = splitFunForallTy ty++mkBitLit+ :: Type+ -- ^ Result type+ -> Integer+ -- ^ Mask+ -> Integer+ -- ^ Value+ -> Term+mkBitLit ty msk val =+ mkApps (bConPrim sTy) [ Left (Literal (IntegerLiteral (msk .&. 1)))+ , Left (Literal (IntegerLiteral (val .&. 1)))]+ where+ (_,sTy) = splitFunForallTy ty++mkSignedLit, mkUnsignedLit+ :: Type+ -- Result type+ -> Type+ -- forall n.+ -> Integer+ -- KnownNat n+ -> Integer+ -- Value+ -> Term+mkSignedLit = mkSizedLit signedConPrim+mkUnsignedLit = mkSizedLit unsignedConPrim++mkBitVectorLit+ :: Type+ -- ^ Result type+ -> Type+ -- ^ forall n.+ -> Integer+ -- ^ KnownNat n+ -> Integer+ -- ^ mask+ -> Integer+ -- ^ Value to construct+ -> Term+mkBitVectorLit ty nTy kn mask val+ = mkApps (bvConPrim sTy)+ [Right nTy+ ,Left (Literal (NaturalLiteral kn))+ ,Left (Literal (IntegerLiteral mask))+ ,Left (Literal (IntegerLiteral val))]+ where+ (_,sTy) = splitFunForallTy ty++mkIndexLitE+ :: Type+ -- ^ Result type+ -> Type+ -- ^ forall n.+ -> Integer+ -- ^ KnownNat n+ -> Integer+ -- ^ Value to construct+ -> Either Term Term+ -- ^ Either undefined (if given value is out of bounds of given type) or term+ -- representing literal+mkIndexLitE rTy nTy kn val+ | val >= 0+ , val < kn+ = Right (mkSizedLit indexConPrim rTy nTy kn val)+ | otherwise+ = Left (undefinedTm (mkTyConApp indexTcNm [nTy]))+ where+ TyConApp indexTcNm _ = tyView (snd (splitFunForallTy rTy))++mkIndexLit+ :: Type+ -- ^ Result type+ -> Type+ -- ^ forall n.+ -> Integer+ -- ^ KnownNat n+ -> Integer+ -- ^ Value to construct+ -> Term+mkIndexLit rTy nTy kn val =+ either id id (mkIndexLitE rTy nTy kn val)++-- | Construct a constant term of a sized type+mkSizedLit'+ :: (Type -> Term)+ -- ^ Type constructor?+ -> (Type, Type, Integer)+ -- ^ (result type, forall n., KnownNat n)+ -> Integer+ -- ^ Value to construct+ -> Term+mkSizedLit' conPrim (ty,nTy,kn) = mkSizedLit conPrim ty nTy kn++mkSignedLit', mkUnsignedLit'+ :: (Type, Type, Integer)+ -- ^ (result type, forall n., KnownNat n)+ -> Integer+ -- ^ Value to construct+ -> Term+mkSignedLit' = mkSizedLit' signedConPrim+mkUnsignedLit' = mkSizedLit' unsignedConPrim++mkBitVectorLit'+ :: (Type, Type, Integer)+ -- ^ (result type, forall n., KnownNat n)+ -> Integer+ -- ^ Mask+ -> Integer+ -- ^ Value+ -> Term+mkBitVectorLit' (ty,nTy,kn) = mkBitVectorLit ty nTy kn++mkIndexLit'+ :: (Type, Type, Integer)+ -- ^ (result type, forall n., KnownNat n)+ -> Integer+ -- ^ value+ -> Term+mkIndexLit' (rTy,nTy,kn) = mkIndexLit rTy nTy kn++-- | Create a vector of supplied elements+mkVecCons+ :: DataCon+ -- ^ The Cons (:>) constructor+ -> Type+ -- ^ Element type+ -> Integer+ -- ^ Length of the vector+ -> Term+ -- ^ head of the vector+ -> Term+ -- ^ tail of the vector+ -> Term+mkVecCons consCon resTy n h t =+ mkApps (Data consCon) [Right (LitTy (NumTy n))+ ,Right resTy+ ,Right (LitTy (NumTy (n-1)))+ ,Left (primCo consCoTy)+ ,Left h+ ,Left t]++ where+ args = dataConInstArgTys consCon [LitTy (NumTy n),resTy,LitTy (NumTy (n-1))]+ Just (consCoTy : _) = args++-- | Create an empty vector+mkVecNil+ :: DataCon+ -- ^ The Nil constructor+ -> Type+ -- ^ The element type+ -> Term+mkVecNil nilCon resTy =+ mkApps (Data nilCon) [Right (LitTy (NumTy 0))+ ,Right resTy+ ,Left (primCo nilCoTy)+ ]+ where+ args = dataConInstArgTys nilCon [LitTy (NumTy 0),resTy]+ Just (nilCoTy : _ ) = args++boolToIntLiteral :: Bool -> Term+boolToIntLiteral b = if b then Literal (IntLiteral 1) else Literal (IntLiteral 0)++boolToBoolLiteral :: TyConMap -> Type -> Bool -> Term+boolToBoolLiteral tcm ty b =+ let (_,tyView -> TyConApp boolTcNm []) = splitFunForallTy ty+ (Just boolTc) = lookupUniqMap boolTcNm tcm+ [falseDc,trueDc] = tyConDataCons boolTc+ retDc = if b then trueDc else falseDc+ in Data retDc++charToCharLiteral :: Char -> Term+charToCharLiteral = Literal . CharLiteral++integerToIntLiteral :: Integer -> Term+integerToIntLiteral = Literal . IntLiteral . toInteger . (fromInteger :: Integer -> Int) -- for overflow behavior++integerToWordLiteral :: Integer -> Term+integerToWordLiteral = Literal . WordLiteral . toInteger . (fromInteger :: Integer -> Word) -- for overflow behavior++integerToIntegerLiteral :: Integer -> Term+integerToIntegerLiteral = Literal . IntegerLiteral++naturalToNaturalLiteral :: Natural -> Term+naturalToNaturalLiteral = Literal . NaturalLiteral . toInteger++bConPrim :: Type -> Term+bConPrim (tyView -> TyConApp bTcNm _)+ = Prim "Clash.Sized.Internal.BitVector.fromInteger##" (PrimInfo funTy WorkNever)+ where+ funTy = foldr1 mkFunTy [integerPrimTy,integerPrimTy,mkTyConApp bTcNm []]+bConPrim _ = error $ $(curLoc) ++ "called with incorrect type"++bvConPrim :: Type -> Term+bvConPrim (tyView -> TyConApp bvTcNm _)+ = Prim "Clash.Sized.Internal.BitVector.fromInteger#" (PrimInfo (ForAllTy nTV funTy) WorkNever)+ where+ funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,integerPrimTy,mkTyConApp bvTcNm [nVar]]+ nName = mkUnsafeSystemName "n" 0+ nVar = VarTy nTV+ nTV = mkTyVar typeNatKind nName+bvConPrim _ = error $ $(curLoc) ++ "called with incorrect type"++indexConPrim :: Type -> Term+indexConPrim (tyView -> TyConApp indexTcNm _)+ = Prim "Clash.Sized.Internal.Index.fromInteger#" (PrimInfo (ForAllTy nTV funTy) WorkNever)+ where+ funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp indexTcNm [nVar]]+ nName = mkUnsafeSystemName "n" 0+ nVar = VarTy nTV+ nTV = mkTyVar typeNatKind nName+indexConPrim _ = error $ $(curLoc) ++ "called with incorrect type"++signedConPrim :: Type -> Term+signedConPrim (tyView -> TyConApp signedTcNm _)+ = Prim "Clash.Sized.Internal.Signed.fromInteger#" (PrimInfo (ForAllTy nTV funTy) WorkNever)+ where+ funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp signedTcNm [nVar]]+ nName = mkUnsafeSystemName "n" 0+ nVar = VarTy nTV+ nTV = mkTyVar typeNatKind nName+signedConPrim _ = error $ $(curLoc) ++ "called with incorrect type"++unsignedConPrim :: Type -> Term+unsignedConPrim (tyView -> TyConApp unsignedTcNm _)+ = Prim "Clash.Sized.Internal.Unsigned.fromInteger#" (PrimInfo (ForAllTy nTV funTy) WorkNever)+ where+ funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp unsignedTcNm [nVar]]+ nName = mkUnsafeSystemName "n" 0+ nVar = VarTy nTV+ nTV = mkTyVar typeNatKind nName+unsignedConPrim _ = error $ $(curLoc) ++ "called with incorrect type"+++-- | Lift a binary function over 'Unsigned' values to be used as literal Evaluator+--+--+liftUnsigned2 :: KnownNat n+ => (Unsigned n -> Unsigned n -> Unsigned n)+ -> Type+ -> TyConMap+ -> [Type]+ -> [Value]+ -> (Proxy n -> Maybe Term)+liftUnsigned2 = liftSized2 unsignedLiterals' mkUnsignedLit++liftSigned2 :: KnownNat n+ => (Signed n -> Signed n -> Signed n)+ -> Type+ -> TyConMap+ -> [Type]+ -> [Value]+ -> (Proxy n -> Maybe Term)+liftSigned2 = liftSized2 signedLiterals' mkSignedLit++liftBitVector2 :: KnownNat n+ => (BitVector n -> BitVector n -> BitVector n)+ -> Type+ -> TyConMap+ -> [Type]+ -> [Value]+ -> (Proxy n -> Maybe Term)+liftBitVector2 f ty tcm tys args _p+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i,j] <- bitVectorLiterals' args+ = let BV mask val = f (toBV i) (toBV j)+ in Just $ mkBitVectorLit ty nTy kn mask val+ | otherwise = Nothing++liftBitVector2Bool :: KnownNat n+ => (BitVector n -> BitVector n -> Bool)+ -> Type+ -> TyConMap+ -> [Value]+ -> (Proxy n -> Maybe Term)+liftBitVector2Bool f ty tcm args _p+ | [i,j] <- bitVectorLiterals' args+ = let val = f (toBV i) (toBV j)+ in Just $ boolToBoolLiteral tcm ty val+ | otherwise = Nothing++liftSized2 :: (KnownNat n, Integral (sized n))+ => ([Value] -> [Integer])+ -- ^ literal argument extraction function+ -> (Type -> Type -> Integer -> Integer -> Term)+ -- ^ literal contruction function+ -> (sized n -> sized n -> sized n)+ -> Type+ -> TyConMap+ -> [Type]+ -> [Value]+ -> (Proxy n -> Maybe Term)+liftSized2 extractLitArgs mkLit f ty tcm tys args p+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i,j] <- extractLitArgs args+ = let val = runSizedF f i j p+ in Just $ mkLit ty nTy kn val+ | otherwise = Nothing++-- | Helper to run a function over sized types on integers+--+-- This only works on function of type (sized n -> sized n -> sized n)+-- The resulting function must be executed with reifyNat+runSizedF+ :: (KnownNat n, Integral (sized n))+ => (sized n -> sized n -> sized n)+ -- ^ function to run+ -> Integer+ -- ^ first argument+ -> Integer+ -- ^ second argument+ -> (Proxy n -> Integer)+runSizedF f i j _ = toInteger $ f (fromInteger i) (fromInteger j)++extractTySizeInfo :: TyConMap -> Type -> [Type] -> (Type, Type, Integer)+extractTySizeInfo tcm ty tys = (resTy,resSizeTy,resSize)+ where+ ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ TyConApp _ [resSizeTy] = tyView resTy+ Right resSize = runExcept (tyNatSize tcm resSizeTy)++getResultTy+ :: TyConMap+ -> Type+ -> [Type]+ -> Type+getResultTy tcm ty tys = resTy+ where+ ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'++liftDDI :: (Double# -> Double# -> Int#) -> [Value] -> Maybe Term+liftDDI f args = case doubleLiterals' args of+ [i,j] -> Just $ runDDI f i j+ _ -> Nothing+liftDDD :: (Double# -> Double# -> Double#) -> [Value] -> Maybe Term+liftDDD f args = case doubleLiterals' args of+ [i,j] -> Just $ runDDD f i j+ _ -> Nothing+liftDD :: (Double# -> Double#) -> [Value] -> Maybe Term+liftDD f args = case doubleLiterals' args of+ [i] -> Just $ runDD f i+ _ -> Nothing+runDDI :: (Double# -> Double# -> Int#) -> Rational -> Rational -> Term+runDDI f i j+ = let !(D# a) = fromRational i+ !(D# b) = fromRational j+ r = f a b+ in Literal . IntLiteral . toInteger $ I# r+runDDD :: (Double# -> Double# -> Double#) -> Rational -> Rational -> Term+runDDD f i j+ = let !(D# a) = fromRational i+ !(D# b) = fromRational j+ r = f a b+ in Literal . DoubleLiteral . toRational $ D# r+runDD :: (Double# -> Double#) -> Rational -> Term+runDD f i+ = let !(D# a) = fromRational i+ r = f a+ in Literal . DoubleLiteral . toRational $ D# r++liftFFI :: (Float# -> Float# -> Int#) -> [Value] -> Maybe Term+liftFFI f args = case floatLiterals' args of+ [i,j] -> Just $ runFFI f i j+ _ -> Nothing+liftFFF :: (Float# -> Float# -> Float#) -> [Value] -> Maybe Term+liftFFF f args = case floatLiterals' args of+ [i,j] -> Just $ runFFF f i j+ _ -> Nothing+liftFF :: (Float# -> Float#) -> [Value] -> Maybe Term+liftFF f args = case floatLiterals' args of+ [i] -> Just $ runFF f i+ _ -> Nothing+runFFI :: (Float# -> Float# -> Int#) -> Rational -> Rational -> Term+runFFI f i j+ = let !(F# a) = fromRational i+ !(F# b) = fromRational j+ r = f a b+ in Literal . IntLiteral . toInteger $ I# r+runFFF :: (Float# -> Float# -> Float#) -> Rational -> Rational -> Term+runFFF f i j+ = let !(F# a) = fromRational i+ !(F# b) = fromRational j+ r = f a b+ in Literal . FloatLiteral . toRational $ F# r+runFF :: (Float# -> Float#) -> Rational -> Term+runFF f i+ = let !(F# a) = fromRational i+ r = f a+ in Literal . FloatLiteral . toRational $ F# r++vecHeadPrim+ :: TyConName+ -- ^ Vec TyCon name+ -> Term+vecHeadPrim vecTcNm = Prim "Clash.Sized.Vector.head"+ (PrimInfo (vecHeadTy vecTcNm) WorkNever)++vecLastPrim+ :: TyConName+ -- ^ Vec TyCon name+ -> Term+vecLastPrim vecTcNm = Prim "Clash.Sized.Vector.last"+ (PrimInfo (vecHeadTy vecTcNm) WorkNever)++vecHeadTy+ :: TyConName+ -- ^ Vec TyCon name+ -> Type+vecHeadTy vecNm =+ ForAllTy nTV (+ ForAllTy aTV (+ mkFunTy+ (mkTyConApp vecNm [mkTyConApp typeNatAdd+ [VarTy nTV+ ,LitTy (NumTy 1)]+ ,VarTy aTV+ ])+ (VarTy aTV)))+ where+ aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 0)+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 1)++vecTailPrim+ :: TyConName+ -- ^ Vec TyCon name+ -> Term+vecTailPrim vecTcNm = Prim "Clash.Sized.Vector.tail"+ (PrimInfo (vecTailTy vecTcNm) WorkNever)++vecInitPrim+ :: TyConName+ -- ^ Vec TyCon name+ -> Term+vecInitPrim vecTcNm = Prim "Clash.Sized.Vector.init"+ (PrimInfo (vecTailTy vecTcNm) WorkNever)++vecTailTy+ :: TyConName+ -- ^ Vec TyCon name+ -> Type+vecTailTy vecNm =+ ForAllTy nTV (+ ForAllTy aTV (+ mkFunTy+ (mkTyConApp vecNm [mkTyConApp typeNatAdd+ [VarTy nTV+ ,LitTy (NumTy 1)]+ ,VarTy aTV+ ])+ (mkTyConApp vecNm [VarTy nTV+ ,VarTy aTV+ ])))+ where+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)+ aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 1)++splitAtPrim+ :: TyConName+ -- ^ SNat TyCon name+ -> TyConName+ -- ^ Vec TyCon name+ -> Term+splitAtPrim snatTcNm vecTcNm =+ Prim "Clash.Sized.Vector.splitAt"+ (PrimInfo (splitAtTy snatTcNm vecTcNm) WorkNever)++splitAtTy+ :: TyConName+ -- ^ SNat TyCon name+ -> TyConName+ -- ^ Vec TyCon name+ -> Type+splitAtTy snatNm vecNm =+ ForAllTy mTV (+ ForAllTy nTV (+ ForAllTy aTV (+ mkFunTy+ (mkTyConApp snatNm [VarTy mTV])+ (mkFunTy+ (mkTyConApp vecNm+ [mkTyConApp typeNatAdd+ [VarTy mTV+ ,VarTy nTV]+ ,VarTy aTV])+ (mkTyConApp tupNm+ [mkTyConApp vecNm+ [VarTy mTV+ ,VarTy aTV]+ ,mkTyConApp vecNm+ [VarTy nTV+ ,VarTy aTV]])))))+ where+ mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 0)+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 1)+ aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 2)+ tupNm = ghcTyconToTyConName (tupleTyCon Boxed 2)++foldSplitAtTy+ :: TyConName+ -- ^ Vec TyCon name+ -> Type+foldSplitAtTy vecNm =+ ForAllTy mTV (+ ForAllTy nTV (+ ForAllTy aTV (+ mkFunTy+ naturalPrimTy+ (mkFunTy+ (mkTyConApp vecNm+ [mkTyConApp typeNatAdd+ [VarTy mTV+ ,VarTy nTV]+ ,VarTy aTV])+ (mkTyConApp tupNm+ [mkTyConApp vecNm+ [VarTy mTV+ ,VarTy aTV]+ ,mkTyConApp vecNm+ [VarTy nTV+ ,VarTy aTV]])))))+ where+ mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 0)+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 1)+ aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 2)+ tupNm = ghcTyconToTyConName (tupleTyCon Boxed 2)++vecAppendPrim+ :: TyConName+ -- ^ Vec TyCon name+ -> Term+vecAppendPrim vecNm = Prim "Clash.Sized.Vector.++"+ (PrimInfo (vecAppendTy vecNm) WorkNever)++vecAppendTy+ :: TyConName+ -- ^ Vec TyCon name+ -> Type+vecAppendTy vecNm =+ ForAllTy nTV (+ ForAllTy aTV (+ ForAllTy mTV (+ mkFunTy+ (mkTyConApp vecNm [VarTy nTV+ ,VarTy aTV+ ])+ (mkFunTy+ (mkTyConApp vecNm [VarTy mTV+ ,VarTy aTV+ ])+ (mkTyConApp vecNm [mkTyConApp typeNatAdd+ [VarTy nTV+ ,VarTy mTV]+ ,VarTy aTV+ ])))))+ where+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)+ aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 1)+ mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 2)++vecZipWithPrim+ :: TyConName+ -- ^ Vec TyCon name+ -> Term+vecZipWithPrim vecNm = Prim "Clash.Sized.Vector.zipWith"+ (PrimInfo (vecAppendTy vecNm) WorkNever)++vecZipWithTy+ :: TyConName+ -- ^ Vec TyCon name+ -> Type+vecZipWithTy vecNm =+ ForAllTy aTV (+ ForAllTy bTV (+ ForAllTy cTV (+ ForAllTy nTV (+ mkFunTy+ (mkFunTy aTy (mkFunTy bTy cTy))+ (mkFunTy+ (mkTyConApp vecNm [nTy,aTy])+ (mkFunTy+ (mkTyConApp vecNm [nTy,bTy])+ (mkTyConApp vecNm [nTy,cTy])))))))+ where+ aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 0)+ bTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "b" 1)+ cTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "c" 2)+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 3)+ aTy = VarTy aTV+ bTy = VarTy bTV+ cTy = VarTy cTV+ nTy = VarTy nTV++vecImapGoTy+ :: TyConName+ -- ^ Vec TyCon name+ -> TyConName+ -- ^ Index TyCon name+ -> Type+vecImapGoTy vecTcNm indexTcNm =+ ForAllTy nTV (+ ForAllTy mTV (+ ForAllTy aTV (+ ForAllTy bTV (+ mkFunTy indexTy+ (mkFunTy fTy+ (mkFunTy vecATy vecBTy))))))+ where+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)+ mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 1)+ aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 2)+ bTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "b" 3)+ indexTy = mkTyConApp indexTcNm [nTy]+ nTy = VarTy nTV+ mTy = VarTy mTV+ fTy = mkFunTy indexTy (mkFunTy aTy bTy)+ aTy = VarTy aTV+ bTy = VarTy bTV+ vecATy = mkTyConApp vecTcNm [mTy,aTy]+ vecBTy = mkTyConApp vecTcNm [mTy,bTy]++indexAddTy+ :: TyConName+ -- ^ Index TyCon name+ -> Type+indexAddTy indexTcNm =+ ForAllTy nTV (+ mkFunTy naturalPrimTy (mkFunTy indexTy (mkFunTy indexTy indexTy)))+ where+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)+ indexTy = mkTyConApp indexTcNm [VarTy nTV]++bvAppendPrim+ :: TyConName+ -- ^ BitVector TyCon Name+ -> Term+bvAppendPrim bvTcNm = Prim "Clash.Sized.Internal.BitVector.++#"+ (PrimInfo (bvAppendTy bvTcNm) WorkNever)++bvAppendTy+ :: TyConName+ -- ^ BitVector TyCon Name+ -> Type+bvAppendTy bvNm =+ ForAllTy mTV (+ ForAllTy nTV (+ mkFunTy naturalPrimTy (mkFunTy+ (mkTyConApp bvNm [VarTy nTV])+ (mkFunTy+ (mkTyConApp bvNm [VarTy mTV])+ (mkTyConApp bvNm [mkTyConApp typeNatAdd+ [VarTy nTV+ ,VarTy mTV]])))))+ where+ mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 0)+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 1)++bvSplitPrim+ :: TyConName+ -- ^ BitVector TyCon Name+ -> Term+bvSplitPrim bvTcNm = Prim "Clash.Sized.Internal.BitVector.split#"+ (PrimInfo (bvSplitTy bvTcNm) WorkNever)++bvSplitTy+ :: TyConName+ -- ^ BitVector TyCon Name+ -> Type+bvSplitTy bvNm =+ ForAllTy nTV (+ ForAllTy mTV (+ mkFunTy naturalPrimTy (mkFunTy+ (mkTyConApp bvNm [mkTyConApp typeNatAdd+ [VarTy mTV+ ,VarTy nTV]])+ (mkTyConApp tupNm [mkTyConApp bvNm [VarTy mTV]+ ,mkTyConApp bvNm [VarTy nTV]]))))+ where+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)+ mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 1)+ tupNm = ghcTyconToTyConName (tupleTyCon Boxed 2)++typeNatAdd :: TyConName+typeNatAdd = Name User+ "GHC.TypeNats.+"+ (getKey typeNatAddTyFamNameKey)+ wiredInSrcSpan+++typeNatMul :: TyConName+typeNatMul = Name User+ "GHC.TypeNats.*"+ (getKey typeNatMulTyFamNameKey)+ wiredInSrcSpan++typeNatSub :: TyConName+typeNatSub = Name User+ "GHC.TypeNats.-"+ (getKey typeNatSubTyFamNameKey)+ wiredInSrcSpan++ghcTyconToTyConName+ :: TyCon.TyCon+ -> TyConName+ghcTyconToTyConName tc =+ Name User n' (getKey (TyCon.tyConUnique tc)) (getSrcSpan n)+ where+ n' = fromMaybe "_INTERNAL_" (modNameM n) `Text.append`+ ('.' `Text.cons` Text.pack occName) occName = occNameString $ nameOccName n n = TyCon.tyConName tc
src-ghc/Clash/GHC/GHC2Core.hs view
@@ -1,863 +1,1227 @@ {-| Copyright : (C) 2013-2016, University of Twente, 2016-2017, Myrtle Software Ltd,- 2017 , Google Inc.- License : BSD2 (see the file LICENSE)- Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module Clash.GHC.GHC2Core- ( GHC2CoreState- , tyConMap- , coreToTerm- , coreToId- , coreToName- , modNameM- , qualfiedNameString- , makeAllTyCons- , emptyGHC2CoreState- )-where---- External Modules-import Control.Lens ((^.), (%~), (&), (%=))-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Reader (ReaderT)-import qualified Control.Monad.Trans.Reader as Reader-import Control.Monad.State (State)-import qualified Control.Monad.State.Lazy as State-import qualified Data.ByteString.Char8 as Char8-import Data.Hashable (Hashable (..))-import Data.HashMap.Lazy (HashMap)-import qualified Data.HashMap.Lazy as HashMap-import qualified Data.HashMap.Strict as HSM-import Data.Maybe (catMaybes,fromMaybe,listToMaybe)-import Data.Text (isInfixOf,pack)-import qualified Data.Traversable as T-import Unbound.Generics.LocallyNameless- (bind, embed, rebind, rec, runFreshM, unbind, unembed)-import qualified Unbound.Generics.LocallyNameless as Unbound---- GHC API-import CoAxiom (CoAxiom (co_ax_branches), CoAxBranch (cab_lhs,cab_rhs),- fromBranches)-import Coercion (coercionType,coercionKind)-import CoreFVs (exprSomeFreeVars)-import CoreSyn- (AltCon (..), Bind (..), CoreExpr, Expr (..), Unfolding (..), collectArgs,- rhssOfAlts, unfoldingTemplate)-import DataCon (DataCon, dataConExTyVars,- dataConName, dataConRepArgTys,- dataConTag, dataConTyCon,- dataConUnivTyVars, dataConWorkId)-import DynFlags (unsafeGlobalDynFlags)-import FamInstEnv (FamInst (..), FamInstEnvs,- familyInstances)-import FastString (unpackFS)-import Id (isDataConId_maybe)-import IdInfo (IdDetails (..), unfoldingInfo)-import Literal (Literal (..))-import Module (moduleName, moduleNameString)-import Name (Name, nameModule_maybe,- nameOccName, nameUnique, getSrcSpan)-import PrelNames (tYPETyConKey)-import OccName (occNameString)-import Outputable (showPpr)-import Pair (Pair (..))-import SrcLoc (isGoodSrcSpan)-import TyCon (AlgTyConRhs (..), TyCon,- algTyConRhs, isAlgTyCon, isFamilyTyCon,- isFunTyCon, isNewTyCon,- isPrimTyCon, isTupleTyCon,- isClosedSynFamilyTyConWithAxiom_maybe,- expandSynTyCon_maybe,- tyConArity,- tyConDataCons, tyConKind,- tyConName, tyConUnique)-import Type (mkTvSubstPrs, substTy, coreView)-#if MIN_VERSION_ghc(8,2,0)-import TyCoRep (Coercion (..), TyLit (..), Type (..))-#else-import TyCoRep (Coercion (..), TyBinder (..), TyLit (..), Type (..))-#endif-import Unique (Uniquable (..), Unique, getKey, hasKey)-import Var (Id, TyVar, Var, idDetails,- isTyVar, varName, varType,- varUnique, idInfo)-#if MIN_VERSION_ghc(8,2,0)-import Var (TyVarBndr (..))-#endif-import VarSet (isEmptyVarSet)---- Local imports-import qualified Clash.Core.DataCon as C-import qualified Clash.Core.Literal as C-import qualified Clash.Core.Name as C-import qualified Clash.Core.Term as C-import qualified Clash.Core.TyCon as C-import qualified Clash.Core.Type as C-import qualified Clash.Core.Var as C-import Clash.Driver.Types-import Clash.Primitives.Types-import Clash.Util--instance Hashable Name where- hashWithSalt s = hashWithSalt s . getKey . nameUnique--data GHC2CoreState- = GHC2CoreState- { _tyConMap :: HashMap C.TyConOccName TyCon- , _nameMap :: HashMap Name String- }--makeLenses ''GHC2CoreState--emptyGHC2CoreState :: GHC2CoreState-emptyGHC2CoreState = GHC2CoreState HSM.empty HSM.empty--makeAllTyCons- :: GHC2CoreState- -> FamInstEnvs- -> HashMap C.TyConOccName C.TyCon-makeAllTyCons hm fiEnvs = go hm hm- where- go old new- | HSM.null (new ^. tyConMap) = HSM.empty- | otherwise = tcm `HSM.union` tcm'- where- (tcm,old') = State.runState (T.mapM (makeTyCon fiEnvs) (new ^. tyConMap)) old- tcm' = go old' (old' & tyConMap %~ (`HSM.difference` (old ^. tyConMap)))--makeTyCon :: FamInstEnvs- -> TyCon- -> State GHC2CoreState C.TyCon-makeTyCon fiEnvs tc = tycon- where- tycon- | isFamilyTyCon tc = mkFunTyCon- | isTupleTyCon tc = mkTupleTyCon- | isAlgTyCon tc = mkAlgTyCon- | isPrimTyCon tc = mkPrimTyCon- | tc `hasKey` tYPETyConKey = mkSuperKindTyCon- | otherwise = mkVoidTyCon- where- tcArity = tyConArity tc-- mkAlgTyCon = do- tcName <- coreToName tyConName tyConUnique qualfiedNameString tc- tcKind <- coreToType (tyConKind tc)- tcRhsM <- makeAlgTyConRhs $ algTyConRhs tc- case tcRhsM of- Just tcRhs ->- return- C.AlgTyCon- { C.tyConName = tcName- , C.tyConKind = tcKind- , C.tyConArity = tcArity- , C.algTcRhs = tcRhs- }- Nothing -> return (C.PrimTyCon tcName tcKind tcArity)-- mkFunTyCon = do- tcName <- coreToName tyConName tyConUnique qualfiedNameString tc- tcKind <- coreToType (tyConKind tc)- substs <- case isClosedSynFamilyTyConWithAxiom_maybe tc of- Nothing -> let instances = familyInstances fiEnvs tc- in mapM famInstToSubst instances- Just cx -> let bx = fromBranches (co_ax_branches cx)- in mapM (\b -> (,) <$> mapM coreToType (cab_lhs b)- <*> coreToType (cab_rhs b))- bx- return- C.FunTyCon- { C.tyConName = tcName- , C.tyConKind = tcKind- , C.tyConArity = tcArity- , C.tyConSubst = substs- }-- mkTupleTyCon = do- tcName <- coreToName tyConName tyConUnique qualfiedNameString tc- tcKind <- coreToType (tyConKind tc)- tcDc <- fmap (C.DataTyCon . (:[])) . coreToDataCon . head . tyConDataCons $ tc- return- C.AlgTyCon- { C.tyConName = tcName- , C.tyConKind = tcKind- , C.tyConArity = tcArity- , C.algTcRhs = tcDc- }-- mkPrimTyCon = do- tcName <- coreToName tyConName tyConUnique qualfiedNameString tc- tcKind <- coreToType (tyConKind tc)- return- C.PrimTyCon- { C.tyConName = tcName- , C.tyConKind = tcKind- , C.tyConArity = tcArity- }-- mkSuperKindTyCon = do- tcName <- coreToName tyConName tyConUnique qualfiedNameString tc- return C.SuperKindTyCon- { C.tyConName = tcName- }-- mkVoidTyCon = do- tcName <- coreToName tyConName tyConUnique qualfiedNameString tc- tcKind <- coreToType (tyConKind tc)- return (C.PrimTyCon tcName tcKind tcArity)-- famInstToSubst :: FamInst -> State GHC2CoreState ([C.Type],C.Type)- famInstToSubst fi = do- tys <- mapM coreToType (fi_tys fi)- ty <- coreToType (fi_rhs fi)- return (tys,ty)--makeAlgTyConRhs :: AlgTyConRhs- -> State GHC2CoreState (Maybe C.AlgTyConRhs)-makeAlgTyConRhs algTcRhs = case algTcRhs of- DataTyCon dcs _ -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs-#if MIN_VERSION_ghc(8,2,0)- SumTyCon dcs -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs-#endif- NewTyCon dc _ (rhsTvs,rhsEtad) _ -> Just <$> (C.NewTyCon <$> coreToDataCon dc- <*> ((,) <$> mapM coreToVar rhsTvs- <*> coreToType rhsEtad- )- )- AbstractTyCon {} -> return Nothing- TupleTyCon {} -> error "Cannot handle tuple tycons"--coreToTerm :: PrimMap a- -> [Var]- -> SrcSpan- -> CoreExpr- -> State GHC2CoreState C.Term-coreToTerm primMap unlocs srcsp coreExpr = Reader.runReaderT (term coreExpr) srcsp- where- term :: CoreExpr -> ReaderT SrcSpan (State GHC2CoreState) C.Term- term e- | (Var x,args) <- collectArgs e- , let nm = State.evalState (qualfiedNameString (varName x)) emptyGHC2CoreState- = go nm args- | otherwise- = term' e- where- -- Remove most Signal transformers- go "Clash.Signal.Internal.mapSignal#" args- | length args == 5- = term (App (args!!3) (args!!4))- go "Clash.Signal.Internal.signal#" args- | length args == 3- = term (args!!2)- go "Clash.Signal.Internal.appSignal#" args- | length args == 5- = term (App (args!!3) (args!!4))- go "Clash.Signal.Internal.joinSignal#" args- | length args == 3- = term (args!!2)- go "Clash.Signal.Bundle.vecBundle#" args- | length args == 4- = term (args!!3)- --- Remove `$`- go "GHC.Base.$" args- | length args == 5- = term (App (args!!3) (args!!4))- -- Remove most CallStack logic- go "GHC.Stack.Types.PushCallStack" args = term (last args)- go "GHC.Stack.Types.FreezeCallStack" args = term (last args)- go "GHC.Stack.withFrozenCallStack" args- | length args == 3- = term (App (args!!2) (args!!1))- go _ _ = term' e- term' (Var x) = do- srcsp' <- Reader.ask- lift (var srcsp' x)- term' (Lit l) = return $ C.Literal (coreToLiteral l)- term' (App eFun (Type tyArg)) = C.TyApp <$> term eFun <*> lift (coreToType tyArg)- term' (App eFun eArg) = C.App <$> term eFun <*> term eArg- term' (Lam x e) | isTyVar x = C.TyLam <$> (bind <$> lift (coreToTyVar x) <*> addUsefull (getSrcSpan x) (term e))- | otherwise = C.Lam <$> (bind <$> lift (coreToId x) <*> addUsefull (getSrcSpan x) (term e))- term' (Let (NonRec x e1) e2) = do- x' <- lift (coreToId x)- e1' <- addUsefull (getSrcSpan x) (term e1)- e2' <- term e2- return $ C.Letrec $ bind (rec [(x', embed e1')]) e2'-- term' (Let (Rec xes) e) = do- xes' <- mapM (\(x,b) -> (,) <$> lift (coreToId x)- <*> addUsefull (getSrcSpan x)- (embed <$> term b))- xes- e' <- term e- return $ C.Letrec $ bind (rec xes') e'-- term' (Case _ _ ty []) = C.Prim (pack "EmptyCase") <$> lift (coreToType ty)- term' (Case e b ty alts) = do- let usesBndr = any ( not . isEmptyVarSet . exprSomeFreeVars (`elem` [b]))- $ rhssOfAlts alts- b' <- lift (coreToId b)- e' <- addUsefull (getSrcSpan b) (term e)- ty' <- lift (coreToType ty)- let caseTerm v = C.Case v ty' <$> mapM (addUsefull (getSrcSpan b) . alt) alts- if usesBndr- then do- ct <- caseTerm (C.Var (unembed $ C.varType b') (C.varName b'))- return $ C.Letrec $ bind (rec [(b',embed e')]) ct- else caseTerm e'-- term' (Cast e co) = do- let (Pair ty1 ty2) = coercionKind co- hasPrimCoM <- lift (hasPrimCo co)- ty1_I <- lift (isIntegerTy ty1)- ty2_I <- lift (isIntegerTy ty2)- case hasPrimCoM of- Just _ | ty1_I || ty2_I- -> C.Cast <$> term e <*> lift (coreToType ty1) <*> lift (coreToType ty2)- _ -> term e- term' (Tick _ e) = term e- term' (Type t) = C.Prim (pack "_TY_") <$> lift (coreToType t)- term' (Coercion co) = C.Prim (pack "_CO_") <$> lift (coreToType (coercionType co))-- var srcsp' x = do- xVar <- coreToVar x- xPrim <- coreToPrimVar x- let xNameS = pack $ C.name2String xPrim- xType <- coreToType (varType x)- case isDataConId_maybe x of- Just dc -> case HashMap.lookup xNameS primMap of- Just _ -> return $ C.Prim xNameS xType- Nothing -> if isDataConWrapId x && not (isNewTyCon (dataConTyCon dc))- then let xInfo = idInfo x- unfolding = unfoldingInfo xInfo- in case unfolding of- CoreUnfolding {} -> Reader.runReaderT (term (unfoldingTemplate unfolding)) srcsp'- NoUnfolding -> error ("No unfolding for DC wrapper: " ++ showPpr unsafeGlobalDynFlags x)- _ -> error ("Unexpected unfolding for DC wrapper: " ++ showPpr unsafeGlobalDynFlags x)- else C.Data <$> coreToDataCon dc- Nothing -> case HashMap.lookup xNameS primMap of- Just (Primitive f _)- | f == pack "Clash.Signal.Internal.mapSignal#" -> return (mapSignalTerm xType)- | f == pack "Clash.Signal.Internal.signal#" -> return (signalTerm xType)- | f == pack "Clash.Signal.Internal.appSignal#" -> return (appSignalTerm xType)- | f == pack "Clash.Signal.Internal.traverse#" -> return (traverseTerm xType)- | f == pack "Clash.Signal.Internal.joinSignal#" -> return (joinTerm xType)- | f == pack "Clash.Signal.Bundle.vecBundle#" -> return (vecUnwrapTerm xType)- | f == pack "GHC.Base.$" -> return (dollarTerm xType)- | f == pack "GHC.Stack.withFrozenCallStack" -> return (withFrozenCallStackTerm xType)- | f == pack "GHC.Magic.lazy" -> return (idTerm xType)- | f == pack "GHC.Magic.runRW#" -> return (runRWTerm xType)- | otherwise -> return (C.Prim xNameS xType)- Just (BlackBox {}) ->- return (C.Prim xNameS xType)- Nothing- | x `elem` unlocs -> return (C.Prim xNameS xType)- | pack "$cshow" `isInfixOf` xNameS -> return (C.Prim xNameS xType)- | otherwise -> return (C.Var xType xVar)-- alt (DEFAULT , _ , e) = bind C.DefaultPat <$> term e- alt (LitAlt l , _ , e) = bind (C.LitPat . embed $ coreToLiteral l) <$> term e- alt (DataAlt dc, xs, e) = case span isTyVar xs of- (tyvs,tmvs) -> bind <$> (C.DataPat . embed <$>- lift (coreToDataCon dc) <*>- (rebind <$>- lift (mapM coreToTyVar tyvs) <*>- lift (mapM coreToId tmvs))) <*>- term e-- coreToLiteral :: Literal- -> C.Literal- coreToLiteral l = case l of- MachStr fs -> C.StringLiteral (Char8.unpack fs)- MachChar c -> C.CharLiteral c- MachInt i -> C.IntLiteral i- MachInt64 i -> C.IntLiteral i- MachWord i -> C.WordLiteral i- MachWord64 i -> C.WordLiteral i- LitInteger i _ -> C.IntegerLiteral i- MachFloat r -> C.FloatLiteral r- MachDouble r -> C.DoubleLiteral r- MachNullAddr -> C.StringLiteral []- MachLabel fs _ _ -> C.StringLiteral (unpackFS fs)--addUsefull :: SrcSpan -> ReaderT SrcSpan (State GHC2CoreState) a- -> ReaderT SrcSpan (State GHC2CoreState) a-addUsefull x = Reader.local (\r -> if isGoodSrcSpan x then x else r)--isIntegerTy :: Type -> State GHC2CoreState Bool-isIntegerTy (TyConApp tc []) = do- tcNm <- qualfiedNameString (tyConName tc)- return (tcNm == "GHC.Integer.Type.Integer")-isIntegerTy _ = return False--hasPrimCo :: Coercion -> State GHC2CoreState (Maybe Type)-hasPrimCo (TyConAppCo _ _ coers) = do- tcs <- catMaybes <$> mapM hasPrimCo coers- return (listToMaybe tcs)--hasPrimCo (AppCo co1 co2) = do- tc1M <- hasPrimCo co1- case tc1M of- Just _ -> return tc1M- _ -> hasPrimCo co2-hasPrimCo (ForAllCo _ _ co) = hasPrimCo co--hasPrimCo co@(AxiomInstCo _ _ coers) = do- let (Pair ty1 _) = coercionKind co- ty1PM <- isPrimTc ty1- if ty1PM- then return (Just ty1)- else do- tcs <- catMaybes <$> mapM hasPrimCo coers- return (listToMaybe tcs)- where- isPrimTc (TyConApp tc _) = do- tcNm <- qualfiedNameString (tyConName tc)- return (tcNm `elem` ["Clash.Sized.Internal.BitVector.Bit"- ,"Clash.Sized.Internal.BitVector.BitVector"- ,"Clash.Sized.Internal.Index.Index"- ,"Clash.Sized.Internal.Signed.Signed"- ,"Clash.Sized.Internal.Unsigned.Unsigned"- ])- isPrimTc _ = return False--hasPrimCo (SymCo co) = hasPrimCo co--hasPrimCo (TransCo co1 co2) = do- tc1M <- hasPrimCo co1- case tc1M of- Just _ -> return tc1M- _ -> hasPrimCo co2--hasPrimCo (AxiomRuleCo _ coers) = do- tcs <- catMaybes <$> mapM hasPrimCo coers- return (listToMaybe tcs)--hasPrimCo (NthCo _ co) = hasPrimCo co-hasPrimCo (LRCo _ co) = hasPrimCo co-hasPrimCo (InstCo co _) = hasPrimCo co-hasPrimCo (SubCo co) = hasPrimCo co--hasPrimCo _ = return Nothing--coreToDataCon :: DataCon- -> State GHC2CoreState C.DataCon-coreToDataCon dc = do- repTys <- mapM coreToType (dataConRepArgTys dc)- dcTy <- coreToType (varType $ dataConWorkId dc)- mkDc dcTy repTys- where- mkDc dcTy repTys = do- nm <- coreToName dataConName getUnique qualfiedNameString dc- uTvs <- mapM coreToVar (dataConUnivTyVars dc)- eTvs <- mapM coreToVar (dataConExTyVars dc)- return $ C.MkData- { C.dcName = nm- , C.dcTag = dataConTag dc- , C.dcType = dcTy- , C.dcArgTys = repTys- , C.dcUnivTyVars = uTvs- , C.dcExtTyVars = eTvs- }--coreToType :: Type- -> State GHC2CoreState C.Type-coreToType ty = coreToType' $ fromMaybe ty (coreView ty)--coreToType' :: Type- -> State GHC2CoreState C.Type-coreToType' (TyVarTy tv) = C.VarTy <$> coreToType (varType tv) <*> (coreToVar tv)-coreToType' (TyConApp tc args)- | isFunTyCon tc = foldl C.AppTy (C.ConstTy C.Arrow) <$> mapM coreToType args- | otherwise = case expandSynTyCon_maybe tc args of- Just (substs,synTy,remArgs) -> do- let substs' = mkTvSubstPrs substs- synTy' = substTy substs' synTy- foldl C.AppTy <$> coreToType synTy' <*> mapM coreToType remArgs- _ -> do- tcName <- coreToName tyConName tyConUnique qualfiedNameString tc- tyConMap %= (HSM.insert (C.nameOcc tcName) tc)- C.mkTyConApp <$> (pure tcName) <*> mapM coreToType args-#if MIN_VERSION_ghc(8,2,0)-coreToType' (ForAllTy (TvBndr tv _) ty) = C.ForAllTy <$> (bind <$> coreToTyVar tv <*> coreToType ty)-coreToType' (FunTy ty1 ty2) = C.mkFunTy <$> coreToType ty1 <*> coreToType ty2-#else-coreToType' (ForAllTy (Named tv _) ty) = C.ForAllTy <$> (bind <$> coreToTyVar tv <*> coreToType ty)-coreToType' (ForAllTy (Anon ty1) ty2) = C.mkFunTy <$> coreToType ty1 <*> coreToType ty2-#endif-coreToType' (LitTy tyLit) = return $ C.LitTy (coreToTyLit tyLit)-coreToType' (AppTy ty1 ty2) = C.AppTy <$> coreToType ty1 <*> coreToType' ty2-coreToType' t@(CastTy _ _) = error ("Cannot handle CastTy " ++ showPpr unsafeGlobalDynFlags t)-coreToType' t@(CoercionTy _) = error ("Cannot handle CoercionTy " ++ showPpr unsafeGlobalDynFlags t)--coreToTyLit :: TyLit- -> C.LitTy-coreToTyLit (NumTyLit i) = C.NumTy (fromInteger i)-coreToTyLit (StrTyLit s) = C.SymTy (unpackFS s)--coreToTyVar :: TyVar- -> State GHC2CoreState C.TyVar-coreToTyVar tv =- C.TyVar <$> (coreToVar tv) <*> (embed <$> coreToType (varType tv))--coreToId :: Id- -> State GHC2CoreState C.Id-coreToId i =- C.Id <$> (coreToVar i) <*> (embed <$> coreToType (varType i))--coreToVar :: Var- -> State GHC2CoreState (C.Name a)-coreToVar = coreToName varName varUnique qualfiedNameStringM--coreToPrimVar :: Var- -> State GHC2CoreState (C.Name C.Term)-coreToPrimVar = coreToName varName varUnique qualfiedNameString--coreToName :: (b -> Name)- -> (b -> Unique)- -> (Name -> State GHC2CoreState String)- -> b- -> State GHC2CoreState (C.Name a)-coreToName toName toUnique toString v = do- ns <- toString (toName v)- let nm = Unbound.makeName ns (toInteger . getKey . toUnique $ v)- loc = getSrcSpan (toName v)- return (C.Name C.User nm loc)--qualfiedNameString :: Name- -> State GHC2CoreState String-qualfiedNameString n = makeCached n nameMap- $ return (fromMaybe "_INTERNAL_" (modNameM n) ++ ('.':occName))- where- occName = occNameString $ nameOccName n--qualfiedNameStringM :: Name- -> State GHC2CoreState String-qualfiedNameStringM n = makeCached n nameMap- $ return (maybe occName (\modName -> modName ++ ('.':occName)) (modNameM n))- where- occName = occNameString $ nameOccName n--modNameM :: Name- -> Maybe String-modNameM n = do- module_ <- nameModule_maybe n- let moduleNm = moduleName module_- return (moduleNameString moduleNm)---- | Given the type:------ @forall a. forall b. forall clk. (a -> b) -> Signal' clk a -> Signal' clk b@------ Generate the term:------ @--- /\(a:*)./\(b:*)./\(clk:Clock).\(f : (Signal' clk a -> Signal' clk b)).--- \(x : Signal' clk a).f x--- @-mapSignalTerm :: C.Type- -> C.Term-mapSignalTerm (C.ForAllTy tvATy) =- C.TyLam (bind aTV (- C.TyLam (bind bTV (- C.TyLam (bind clkTV (- C.Lam (bind fId (- C.Lam (bind xId (- C.App (C.Var fTy fName) (C.Var aTy xName)))))))))))- where- (aTV,bTV,clkTV,funTy) = runFreshM $ do- { (aTV',C.ForAllTy tvBTy) <- unbind tvATy- ; (bTV',C.ForAllTy tvClkTy) <- unbind tvBTy- ; (clkTV',funTy') <- unbind tvClkTy- ; return (aTV',bTV',clkTV',funTy')- }- (C.FunTy _ funTy'') = C.tyView funTy- (C.FunTy aTy bTy) = C.tyView funTy''- fName = C.string2SystemName "f"- xName = C.string2SystemName "x"- fTy = C.mkFunTy aTy bTy- fId = C.Id fName (embed fTy)- xId = C.Id xName (embed aTy)--mapSignalTerm ty = error $ $(curLoc) ++ show ty---- | Given the type:------ @forall a. forall clk. a -> Signal' clk a@------ Generate the term------ @/\(a:*)./\(clk:Clock).\(x:Signal' clk a).x@-signalTerm :: C.Type- -> C.Term-signalTerm (C.ForAllTy tvATy) =- C.TyLam (bind aTV (- C.TyLam (bind clkTV (- C.Lam (bind xId (- C.Var aTy xName))))))- where- (aTV,clkTV,funTy) = runFreshM $ do- { (aTV', C.ForAllTy tvClkTy) <- unbind tvATy- ; (clkTV', funTy') <- unbind tvClkTy- ; return (aTV',clkTV',funTy')- }- (C.FunTy _ aTy) = C.tyView funTy- xName = C.string2SystemName "x"- xId = C.Id xName (embed aTy)--signalTerm ty = error $ $(curLoc) ++ show ty---- | Given the type:------ @--- forall clk. forall a. forall b. Signal' clk (a -> b) -> Signal' clk a ->--- Signal' clk b--- @------ Generate the term:------ @--- /\(clk:Clock)./\(a:*)./\(b:*).\(f : (Signal' clk a -> Signal' clk b)).--- \(x : Signal' clk a).f x--- @-appSignalTerm :: C.Type- -> C.Term-appSignalTerm (C.ForAllTy tvClkTy) =- C.TyLam (bind clkTV (- C.TyLam (bind aTV (- C.TyLam (bind bTV (- C.Lam (bind fId (- C.Lam (bind xId (- C.App (C.Var fTy fName) (C.Var aTy xName)))))))))))- where- (clkTV,aTV,bTV,funTy) = runFreshM $ do- { (clkTV',C.ForAllTy tvATy) <- unbind tvClkTy- ; (aTV',C.ForAllTy tvBTy) <- unbind tvATy- ; (bTV',funTy') <- unbind tvBTy- ; return (clkTV',aTV',bTV',funTy')- }- (C.FunTy _ funTy'') = C.tyView funTy- (C.FunTy aTy bTy) = C.tyView funTy''- fName = C.string2SystemName "f"- xName = C.string2SystemName "x"- fTy = C.mkFunTy aTy bTy- fId = C.Id fName (embed fTy)- xId = C.Id xName (embed aTy)--appSignalTerm ty = error $ $(curLoc) ++ show ty---- | Given the type:------ @--- forall t.forall n.forall a.Vec n (Signal' t a) ->--- Signal' t (Vec n a)--- @------ Generate the term:------ @--- /\(t:Clock)./\(n:Nat)./\(a:*).\(vs:Signal' t (Vec n a)).vs--- @-vecUnwrapTerm :: C.Type- -> C.Term-vecUnwrapTerm (C.ForAllTy tvTTy) =- C.TyLam (bind tTV (- C.TyLam (bind nTV (- C.TyLam (bind aTV (- C.Lam (bind vsId (- C.Var vsTy vsName))))))))- where- (tTV,nTV,aTV,funTy) = runFreshM $ do- { (tTV',C.ForAllTy tvNTy) <- unbind tvTTy- ; (nTV',C.ForAllTy tvATy) <- unbind tvNTy- ; (aTV',funTy') <- unbind tvATy- ; return (tTV',nTV',aTV',funTy')- }- (C.FunTy _ vsTy) = C.tyView funTy- vsName = C.string2SystemName "vs"- vsId = C.Id vsName (embed vsTy)--vecUnwrapTerm ty = error $ $(curLoc) ++ show ty---- | Given the type:------ @--- forall f.forall a.forall b.forall clk.Applicative f => (a -> f b) ->--- CSignal clk a -> f (Signal' clk b)--- @------ Generate the term:------ @--- /\(f:* -> *)./\(a:*)./\(b:*)./\(clk:Clock).\(dict:Applicative f).--- \(g:a -> f b).\(x:Signal' clk a).g x--- @-traverseTerm :: C.Type- -> C.Term-traverseTerm (C.ForAllTy tvFTy) =- C.TyLam (bind fTV (- C.TyLam (bind aTV (- C.TyLam (bind bTV (- C.TyLam (bind clkTV (- C.Lam (bind dictId (- C.Lam (bind gId (- C.Lam (bind xId (- C.App (C.Var gTy gName) (C.Var xTy xName)))))))))))))))- where- (fTV,aTV,bTV,clkTV,funTy) = runFreshM $ do- { (fTV',C.ForAllTy tvATy) <- unbind tvFTy- ; (aTV',C.ForAllTy tvBTy) <- unbind tvATy- ; (bTV',C.ForAllTy tvClkTy) <- unbind tvBTy- ; (clkTV',funTy') <- unbind tvClkTy- ; return (fTV',aTV',bTV',clkTV',funTy')- }- (C.FunTy dictTy funTy1) = C.tyView funTy- (C.FunTy gTy funTy2) = C.tyView funTy1- (C.FunTy xTy _) = C.tyView funTy2- dictName = C.string2SystemName "dict"- gName = C.string2SystemName "g"- xName = C.string2SystemName "x"- dictId = C.Id dictName (embed dictTy)- gId = C.Id gName (embed gTy)- xId = C.Id xName (embed xTy)--traverseTerm ty = error $ $(curLoc) ++ show ty---- ∀ (r :: GHC.Types.RuntimeRep)--- (a :: GHC.Prim.TYPE GHC.Types.PtrRepLifted)--- (b :: GHC.Prim.TYPE r).--- (a -> b) -> a -> b----- | Given the type:------ @forall (r :: Rep) (a :: TYPE Lifted) (b :: TYPE r). (a -> b) -> a -> b@------ Generate the term:------ @/\(r:Rep)/\(a:TYPE Lifted)./\(b:TYPE r).\(f : (a -> b)).\(x : a).f x@-dollarTerm :: C.Type- -> C.Term-dollarTerm (C.ForAllTy tvRTy) =- C.TyLam (bind rTV (- C.TyLam (bind aTV (- C.TyLam (bind bTV (- C.Lam (bind fId (- C.Lam (bind xId (- C.App (C.Var fTy fName) (C.Var aTy xName)))))))))))- where- (rTV,aTV,bTV,funTy) = runFreshM $ do- { (rTV',C.ForAllTy tvATy) <- unbind tvRTy- ; (aTV',C.ForAllTy tvBTy) <- unbind tvATy- ; (bTV',funTy') <- unbind tvBTy- ; return (rTV',aTV',bTV',funTy')- }- (C.FunTy fTy funTy'') = C.tyView funTy- (C.FunTy aTy _) = C.tyView funTy''- fName = C.string2SystemName "f"- xName = C.string2SystemName "x"- fId = C.Id fName (embed fTy)- xId = C.Id xName (embed aTy)--dollarTerm ty = error $ $(curLoc) ++ show ty---- | Given the type:------ @forall a. forall clk. Signal' clk (Signal' clk a) -> Signal' clk a@------ Generate the term------ @/\(a:*)./\(clk:Clock).\(x:Signal' clk a).x@-joinTerm :: C.Type- -> C.Term-joinTerm ty@(C.ForAllTy _) = signalTerm ty-joinTerm ty = error $ $(curLoc) ++ show ty---- | Given the type:------ @forall a. CallStack -> (HasCallStack => a) -> a@------ Generate the term------ @/\(a:*)./\(callStack:CallStack).\(f:HasCallStack => a).f callStack@-withFrozenCallStackTerm- :: C.Type- -> C.Term-withFrozenCallStackTerm (C.ForAllTy tvATy) =- C.TyLam (bind aTV (- C.Lam (bind callStackId (- C.Lam (bind fId (- C.App (C.Var fTy fName) (C.Var callStackTy callStackName)))))))- where- (aTV,funTy) = runFreshM (unbind tvATy)- (C.FunTy callStackTy fTy) = C.tyView funTy- callStackName = C.string2SystemName "callStack"- fName = C.string2SystemName "f"- callStackId = C.Id callStackName (embed callStackTy)- fId = C.Id fName (embed fTy)--withFrozenCallStackTerm ty = error $ $(curLoc) ++ show ty---- | Given the type:------ @forall a. a -> a@------ Generate the term------ @/\(a:*).\(x:a).x@-idTerm- :: C.Type- -> C.Term-idTerm (C.ForAllTy tvATy) =- C.TyLam (bind aTV (- C.Lam (bind xId (- C.Var xTy xName))))- where- (aTV,funTy) = runFreshM (unbind tvATy)- (C.FunTy xTy _) = C.tyView funTy- xName = C.string2SystemName "x"- xId = C.Id xName (embed xTy)--idTerm ty = error $ $(curLoc) ++ show ty---- | Given type type:------ @forall (r :: RuntimeRep) (o :: TYPE r).(State# RealWorld -> o) -> o@------ Genereate the term:------ @/\(r:RuntimeRep)./\(o:TYPE r).\(f:State# RealWord -> o) -> f realWorld#@-runRWTerm- :: C.Type- -> C.Term-runRWTerm (C.ForAllTy tvRTy) =- C.TyLam (bind rTV (- C.TyLam (bind oTV (- C.Lam (bind fId (- (C.App (C.Var fTy fName) (C.Prim rwNm rwTy))))))))- where- (rTV,oTV,funTy) = runFreshM $ do- { (rTV',C.ForAllTy tvOTy) <- unbind tvRTy- ; (oTV',funTy') <- unbind tvOTy- ; return (rTV',oTV',funTy')- }- (C.FunTy fTy _) = C.tyView funTy- (C.FunTy rwTy _) = C.tyView fTy- fName = C.string2SystemName "f"- fId = C.Id fName (embed fTy)- rwNm = pack "GHC.Prim.realWorld#"--runRWTerm ty = error $ $(curLoc) ++ show ty+ 2017-2818, Google Inc.+ License : BSD2 (see the file LICENSE)+ Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Clash.GHC.GHC2Core+ ( C2C+ , GHC2CoreState+ , tyConMap+ , coreToTerm+ , coreToId+ , coreToName+ , modNameM+ , qualifiedNameString+ , qualifiedNameString'+ , makeAllTyCons+ , emptyGHC2CoreState+ )+where++-- External Modules+import Control.Lens ((^.), (%~), (&), (%=))+import Control.Monad.RWS.Lazy (RWS)+import qualified Control.Monad.RWS.Lazy as RWS+import qualified Data.ByteString.Char8 as Char8+import Data.Hashable (Hashable (..))+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap+import qualified Data.HashMap.Strict as HSM+import Data.Maybe (catMaybes,fromMaybe,listToMaybe)+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup+#endif+import Data.Text (Text, isInfixOf,pack)+import qualified Data.Text as Text+import Data.Text.Encoding (decodeUtf8)+import qualified Data.Traversable as T++-- GHC API+import CoAxiom (CoAxiom (co_ax_branches), CoAxBranch (cab_lhs,cab_rhs),+ fromBranches)+import Coercion (coercionType,coercionKind)+import CoreFVs (exprSomeFreeVars)+import CoreSyn+ (AltCon (..), Bind (..), CoreExpr, Expr (..), Unfolding (..), Tickish (..),+ collectArgs, rhssOfAlts, unfoldingTemplate)+import DataCon (DataCon,+#if MIN_VERSION_ghc(8,8,0)+ dataConExTyCoVars,+#else+ dataConExTyVars,+#endif+ dataConName, dataConRepArgTys,+ dataConTag, dataConTyCon,+ dataConUnivTyVars, dataConWorkId,+ dataConFieldLabels, flLabel)+import DynFlags (unsafeGlobalDynFlags)+import FamInstEnv (FamInst (..), FamInstEnvs,+ familyInstances)+import FastString (unpackFS, fastStringToByteString)+import Id (isDataConId_maybe)+import IdInfo (IdDetails (..), unfoldingInfo)+import Literal (Literal (..))+#if MIN_VERSION_ghc(8,6,0)+import Literal (LitNumType (..))+#endif+import Module (moduleName, moduleNameString)+import Name (Name, nameModule_maybe,+ nameOccName, nameUnique, getSrcSpan)+import PrelNames (tYPETyConKey)+import OccName (occNameString)+import Outputable (showPpr)+import Pair (Pair (..))+import SrcLoc (SrcSpan (..), isGoodSrcSpan)+import TyCon (AlgTyConRhs (..), TyCon, tyConName,+ algTyConRhs, isAlgTyCon, isFamilyTyCon,+ isFunTyCon, isNewTyCon,+ isPrimTyCon, isTupleTyCon,+ isClosedSynFamilyTyConWithAxiom_maybe,+ expandSynTyCon_maybe,+ tyConArity,+ tyConDataCons, tyConKind,+ tyConName, tyConUnique, isClassTyCon)+import Type (mkTvSubstPrs, substTy, coreView)+import TyCoRep (Coercion (..), TyLit (..), Type (..))+import Unique (Uniquable (..), Unique, getKey, hasKey)+import Var (Id, TyVar, Var, idDetails,+ isTyVar, varName, varType,+ varUnique, idInfo, isGlobalId)+#if MIN_VERSION_ghc(8,8,0)+import Var (VarBndr (..))+#else+import Var (TyVarBndr (..))+#endif+import VarSet (isEmptyVarSet)++-- Local imports+import Clash.Annotations.Primitive (extractPrim)+import qualified Clash.Core.DataCon as C+import qualified Clash.Core.Literal as C+import qualified Clash.Core.Name as C+import qualified Clash.Core.Term as C+import qualified Clash.Core.TyCon as C+import qualified Clash.Core.Type as C+import qualified Clash.Core.Var as C+import Clash.Primitives.Types+import qualified Clash.Unique as C+import Clash.Util++instance Hashable Name where+ hashWithSalt s = hashWithSalt s . getKey . nameUnique++data GHC2CoreState+ = GHC2CoreState+ { _tyConMap :: C.UniqMap TyCon+ , _nameMap :: HashMap Name Text+ }++makeLenses ''GHC2CoreState++emptyGHC2CoreState :: GHC2CoreState+emptyGHC2CoreState = GHC2CoreState C.emptyUniqMap HSM.empty++newtype SrcSpanRB = SrcSpanRB {unSrcSpanRB :: SrcSpan}++instance Semigroup SrcSpanRB where+ (SrcSpanRB l) <> (SrcSpanRB r) =+ if isGoodSrcSpan r+ then SrcSpanRB r+ else SrcSpanRB l++instance Monoid SrcSpanRB where+ mempty = SrcSpanRB noSrcSpan+#if !MIN_VERSION_base(4,11,0)+ mappend = (<>)+#endif++type C2C = RWS SrcSpan SrcSpanRB GHC2CoreState++makeAllTyCons+ :: GHC2CoreState+ -> FamInstEnvs+ -> C.UniqMap C.TyCon+makeAllTyCons hm fiEnvs = go hm hm+ where+ go old new+ | C.nullUniqMap (new ^. tyConMap) = C.emptyUniqMap+ | otherwise = tcm `C.unionUniqMap` tcm'+ where+ (tcm,old', _) = RWS.runRWS (T.mapM (makeTyCon fiEnvs) (new ^. tyConMap)) noSrcSpan old+ tcm' = go old' (old' & tyConMap %~ (`C.differenceUniqMap` (old ^. tyConMap)))++makeTyCon :: FamInstEnvs+ -> TyCon+ -> C2C C.TyCon+makeTyCon fiEnvs tc = tycon+ where+ tycon+ | isFamilyTyCon tc = mkFunTyCon+ | isTupleTyCon tc = mkTupleTyCon+ | isAlgTyCon tc = mkAlgTyCon+ | isPrimTyCon tc = mkPrimTyCon+ | tc `hasKey` tYPETyConKey = mkSuperKindTyCon+ | otherwise = mkVoidTyCon+ where+ tcArity = tyConArity tc++ mkAlgTyCon = do+ tcName <- coreToName tyConName tyConUnique qualifiedNameString tc+ tcKind <- coreToType (tyConKind tc)+ tcRhsM <- makeAlgTyConRhs $ algTyConRhs tc+ case tcRhsM of+ Just tcRhs ->+ return+ C.AlgTyCon+ { C.tyConUniq = C.nameUniq tcName+ , C.tyConName = tcName+ , C.tyConKind = tcKind+ , C.tyConArity = tcArity+ , C.algTcRhs = tcRhs+ , C.isClassTc = isClassTyCon tc+ }+ Nothing -> return (C.PrimTyCon (C.nameUniq tcName) tcName tcKind tcArity)++ mkFunTyCon = do+ tcName <- coreToName tyConName tyConUnique qualifiedNameString tc+ tcKind <- coreToType (tyConKind tc)+ substs <- case isClosedSynFamilyTyConWithAxiom_maybe tc of+ Nothing -> let instances = familyInstances fiEnvs tc+ in mapM famInstToSubst instances+ Just cx -> let bx = fromBranches (co_ax_branches cx)+ in mapM (\b -> (,) <$> mapM coreToType (cab_lhs b)+ <*> coreToType (cab_rhs b))+ bx+ return+ C.FunTyCon+ { C.tyConUniq = C.nameUniq tcName+ , C.tyConName = tcName+ , C.tyConKind = tcKind+ , C.tyConArity = tcArity+ , C.tyConSubst = substs+ }++ mkTupleTyCon = do+ tcName <- coreToName tyConName tyConUnique qualifiedNameString tc+ tcKind <- coreToType (tyConKind tc)+ tcDc <- fmap (C.DataTyCon . (:[])) . coreToDataCon . head . tyConDataCons $ tc+ return+ C.AlgTyCon+ { C.tyConUniq = C.nameUniq tcName+ , C.tyConName = tcName+ , C.tyConKind = tcKind+ , C.tyConArity = tcArity+ , C.algTcRhs = tcDc+ , C.isClassTc = isClassTyCon tc+ }++ mkPrimTyCon = do+ tcName <- coreToName tyConName tyConUnique qualifiedNameString tc+ tcKind <- coreToType (tyConKind tc)+ return+ C.PrimTyCon+ { C.tyConUniq = C.nameUniq tcName+ , C.tyConName = tcName+ , C.tyConKind = tcKind+ , C.tyConArity = tcArity+ }++ mkSuperKindTyCon = do+ tcName <- coreToName tyConName tyConUnique qualifiedNameString tc+ return C.SuperKindTyCon+ { C.tyConUniq = C.nameUniq tcName+ , C.tyConName = tcName+ }++ mkVoidTyCon = do+ tcName <- coreToName tyConName tyConUnique qualifiedNameString tc+ tcKind <- coreToType (tyConKind tc)+ return (C.PrimTyCon (C.nameUniq tcName) tcName tcKind tcArity)++ famInstToSubst :: FamInst -> C2C ([C.Type],C.Type)+ famInstToSubst fi = do+ tys <- mapM coreToType (fi_tys fi)+ ty <- coreToType (fi_rhs fi)+ return (tys,ty)++makeAlgTyConRhs :: AlgTyConRhs+ -> C2C (Maybe C.AlgTyConRhs)+makeAlgTyConRhs algTcRhs = case algTcRhs of+#if MIN_VERSION_ghc(8,6,0)+ DataTyCon dcs _ _ -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs+#else+ DataTyCon dcs _ -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs+#endif+#if MIN_VERSION_ghc(8,6,0)+ SumTyCon dcs _ -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs+#else+ SumTyCon dcs -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs+#endif+ NewTyCon dc _ (rhsTvs,rhsEtad) _ -> Just <$> (C.NewTyCon <$> coreToDataCon dc+ <*> ((,) <$> mapM coreToTyVar rhsTvs+ <*> coreToType rhsEtad+ )+ )+ AbstractTyCon {} -> return Nothing+ TupleTyCon {} -> error "Cannot handle tuple tycons"++coreToTerm+ :: CompiledPrimMap+ -> [Var]+ -> CoreExpr+ -> C2C C.Term+coreToTerm primMap unlocs = term+ where+ term :: CoreExpr -> C2C C.Term+ term e+ | (Var x,args) <- collectArgs e+ , let (nm, _) = RWS.evalRWS (qualifiedNameString (varName x))+ noSrcSpan+ emptyGHC2CoreState+ = go nm args+ | otherwise+ = term' e+ where+ -- Remove most Signal transformers+ go "Clash.Signal.Internal.mapSignal#" args+ | length args == 5+ = term (App (args!!3) (args!!4))+ go "Clash.Signal.Internal.signal#" args+ | length args == 3+ = term (args!!2)+ go "Clash.Signal.Internal.appSignal#" args+ | length args == 5+ = term (App (args!!3) (args!!4))+ go "Clash.Signal.Internal.joinSignal#" args+ | length args == 3+ = term (args!!2)+ go "Clash.Signal.Bundle.vecBundle#" args+ | length args == 4+ = term (args!!3)+ --- Remove `$`+ go "GHC.Base.$" args+ | length args == 5+ = term (App (args!!3) (args!!4))+ go "GHC.Magic.noinline" args -- noinline :: forall a. a -> a+ | [_ty, x] <- args+ = term x+ -- Remove most CallStack logic+ go "GHC.Stack.Types.PushCallStack" args = term (last args)+ go "GHC.Stack.Types.FreezeCallStack" args = term (last args)+ go "GHC.Stack.withFrozenCallStack" args+ | length args == 3+ = term (App (args!!2) (args!!1))+ go "Clash.Class.BitPack.packXWith" args+ | [_nTy,_aTy,_kn,f] <- args+ = term f+ go "Clash.Sized.BitVector.Internal.checkUnpackUndef" args+ | [_nTy,_aTy,_kn,_typ,f] <- args+ = term f+ go "Clash.Magic.prefixName" args+ | [Type nmTy,_aTy,f] <- args+ = C.Tick <$> (C.NameMod C.PrefixName <$> coreToType nmTy) <*> term f+ go "Clash.Magic.suffixName" args+ | [Type nmTy,_aTy,f] <- args+ = C.Tick <$> (C.NameMod C.SuffixName <$> coreToType nmTy) <*> term f+ go "Clash.Magic.setName" args+ | [Type nmTy,_aTy,f] <- args+ = C.Tick <$> (C.NameMod C.SetName <$> coreToType nmTy) <*> term f++ go _ _ = term' e+ term' (Var x) = var x+ term' (Lit l) = return $ C.Literal (coreToLiteral l)+ term' (App eFun (Type tyArg)) = C.TyApp <$> term eFun <*> coreToType tyArg+ term' (App eFun eArg) = C.App <$> term eFun <*> term eArg+ term' (Lam x e)+ | isTyVar x+ = C.TyLam <$> coreToTyVar x <*> addUsefull (getSrcSpan x) (term e)+ | otherwise+ = do+ (e',sp) <- termSP (getSrcSpan x) e+ x' <- coreToIdSP sp x+ return (C.Lam x' e')+ term' (Let (NonRec x e1) e2) = do+ (e1',sp) <- termSP (getSrcSpan x) e1+ x' <- coreToIdSP sp x+ e2' <- term e2+ return (C.Letrec [(x', e1')] e2')++ term' (Let (Rec xes) e) = do+ xes' <- mapM go xes+ e' <- term e+ return (C.Letrec xes' e')+ where+ go (x,b) = do+ (b',sp) <- termSP (getSrcSpan x) b+ x' <- coreToIdSP sp x+ return (x',b')++ term' (Case _ _ ty []) = C.TyApp (C.Prim (pack "EmptyCase") (C.PrimInfo C.undefinedTy C.WorkNever))+ <$> coreToType ty+ term' (Case e b ty alts) = do+ let usesBndr = any ( not . isEmptyVarSet . exprSomeFreeVars (== b))+ $ rhssOfAlts alts+ (e',sp) <- termSP (getSrcSpan b) e+ b' <- coreToIdSP sp b+ ty' <- coreToType ty+ let caseTerm v =+ C.Case v ty' <$> mapM (addUsefull sp . alt sp) alts+ if usesBndr+ then do+ ct <- caseTerm (C.Var b')+ return (C.Letrec [(b', e')] ct)+ else caseTerm e'++ term' (Cast e co) = do+ let (Pair ty1 ty2) = coercionKind co+ hasPrimCoM <- hasPrimCo co+ ty1_I <- isIntegerTy ty1+ ty2_I <- isIntegerTy ty2+ case hasPrimCoM of+ Just _ | ty1_I || ty2_I+ -> C.Cast <$> term e <*> coreToType ty1 <*> coreToType ty2+ _ -> term e+ term' (Tick (SourceNote rsp _) e) =+ C.Tick (C.SrcSpan (RealSrcSpan rsp)) <$> addUsefull (RealSrcSpan rsp) (term e)+ term' (Tick _ e) = term e+ term' (Type t) = C.TyApp (C.Prim (pack "_TY_") (C.PrimInfo C.undefinedTy C.WorkNever)) <$>+ coreToType t+ term' (Coercion co) = C.TyApp (C.Prim (pack "_CO_") (C.PrimInfo C.undefinedTy C.WorkNever)) <$>+ coreToType (coercionType co)+++ termSP sp = fmap (second unSrcSpanRB) . RWS.listen . addUsefullR sp . term+ coreToIdSP sp = RWS.local (\r -> if isGoodSrcSpan sp then sp else r) . coreToId+++ lookupPrim :: Text -> Maybe (Maybe CompiledPrimitive)+ lookupPrim nm = extractPrim <$> HashMap.lookup nm primMap++ var x = do+ xPrim <- if isGlobalId x then coreToPrimVar x else coreToVar x+ let xNameS = C.nameOcc xPrim+ xType <- coreToType (varType x)+ case isDataConId_maybe x of+ Just dc -> case lookupPrim xNameS of+ Just p -> return $ C.Prim xNameS (C.PrimInfo xType (maybe C.WorkVariable workInfo p))+ Nothing -> if isDataConWrapId x && not (isNewTyCon (dataConTyCon dc))+ then let xInfo = idInfo x+ unfolding = unfoldingInfo xInfo+ in case unfolding of+ CoreUnfolding {} -> do+ sp <- RWS.ask+ RWS.censor (const (SrcSpanRB sp)) (term (unfoldingTemplate unfolding))+ NoUnfolding -> error ("No unfolding for DC wrapper: " ++ showPpr unsafeGlobalDynFlags x)+ _ -> error ("Unexpected unfolding for DC wrapper: " ++ showPpr unsafeGlobalDynFlags x)+ else C.Data <$> coreToDataCon dc+ Nothing -> case lookupPrim xNameS of+ Just (Just (Primitive f wi _))+ | f == pack "Clash.Signal.Internal.mapSignal#" -> return (mapSignalTerm xType)+ | f == pack "Clash.Signal.Internal.signal#" -> return (signalTerm xType)+ | f == pack "Clash.Signal.Internal.appSignal#" -> return (appSignalTerm xType)+ | f == pack "Clash.Signal.Internal.traverse#" -> return (traverseTerm xType)+ | f == pack "Clash.Signal.Internal.joinSignal#" -> return (joinTerm xType)+ | f == pack "Clash.Signal.Bundle.vecBundle#" -> return (vecUnwrapTerm xType)+ | f == pack "GHC.Base.$" -> return (dollarTerm xType)+ | f == pack "GHC.Stack.withFrozenCallStack" -> return (withFrozenCallStackTerm xType)+ | f == pack "GHC.Magic.noinline" -> return (idTerm xType)+ | f == pack "GHC.Magic.lazy" -> return (idTerm xType)+ | f == pack "GHC.Magic.runRW#" -> return (runRWTerm xType)+ | f == pack "Clash.Class.BitPack.packXWith" -> return (packXWithTerm xType)+ | f == pack "Clash.Sized.Internal.BitVector.checkUnpackUndef" -> return (checkUnpackUndefTerm xType)+ | f == pack "Clash.Magic.prefixName"+ -> return (nameModTerm C.PrefixName xType)+ | f == pack "Clash.Magic.postfixName"+ -> return (nameModTerm C.SuffixName xType)+ | f == pack "Clash.Magic.setName"+ -> return (nameModTerm C.SetName xType)+ | otherwise -> return (C.Prim xNameS (C.PrimInfo xType wi))+ Just (Just (BlackBox {workInfo = wi})) ->+ return $ C.Prim xNameS (C.PrimInfo xType wi)+ Just (Just (BlackBoxHaskell {workInfo = wi})) ->+ return $ C.Prim xNameS (C.PrimInfo xType wi)+ Just Nothing ->+ -- Was guarded by "DontTranslate". We don't know yet if Clash will+ -- actually use it later on, so we don't err here.+ return $ C.Prim xNameS (C.PrimInfo xType C.WorkAlways)+ Nothing+ | x `elem` unlocs+ -> return (C.Prim xNameS (C.PrimInfo xType C.WorkAlways))+ | pack "$cshow" `isInfixOf` xNameS+ -> return (C.Prim xNameS (C.PrimInfo xType C.WorkAlways))+ | otherwise+ -> C.Var <$> coreToId x++ alt _ (DEFAULT , _ , e) = (C.DefaultPat,) <$> term e+ alt _ (LitAlt l , _ , e) = (C.LitPat (coreToLiteral l),) <$> term e+ alt sp0 (DataAlt dc, xs, e) = case span isTyVar xs of+ (tyvs,tmvs) -> do+ (e',sp1) <- termSP sp0 e+ (,) <$> (C.DataPat <$> coreToDataCon dc+ <*> mapM coreToTyVar tyvs+ <*> mapM (coreToIdSP sp1) tmvs)+ <*> pure e'++ coreToLiteral :: Literal+ -> C.Literal+ coreToLiteral l = case l of+#if MIN_VERSION_ghc(8,8,0)+ LitString fs -> C.StringLiteral (Char8.unpack fs)+ LitChar c -> C.CharLiteral c+ LitRubbish ->+ error $ "coreToTerm: Encountered LibRubbish. This is a bug in Clash. "+ ++ "Report on https://github.com/clash-lang/clash-compiler/issues."+#else+ MachStr fs -> C.StringLiteral (Char8.unpack fs)+ MachChar c -> C.CharLiteral c+#endif+#if MIN_VERSION_ghc(8,6,0)+ LitNumber lt i _ -> case lt of+ LitNumInteger -> C.IntegerLiteral i+ LitNumNatural -> C.NaturalLiteral i+ LitNumInt -> C.IntLiteral i+ LitNumInt64 -> C.IntLiteral i+ LitNumWord -> C.WordLiteral i+ LitNumWord64 -> C.WordLiteral i+#else+ MachInt i -> C.IntLiteral i+ MachInt64 i -> C.IntLiteral i+ MachWord i -> C.WordLiteral i+ MachWord64 i -> C.WordLiteral i+ LitInteger i _ -> C.IntegerLiteral i+#endif+#if MIN_VERSION_ghc(8,8,0)+ LitFloat r -> C.FloatLiteral r+ LitDouble r -> C.DoubleLiteral r+ LitNullAddr -> C.StringLiteral []+ LitLabel fs _ _ -> C.StringLiteral (unpackFS fs)+#else+ MachFloat r -> C.FloatLiteral r+ MachDouble r -> C.DoubleLiteral r+ MachNullAddr -> C.StringLiteral []+ MachLabel fs _ _ -> C.StringLiteral (unpackFS fs)+#endif++addUsefull :: SrcSpan+ -> C2C a+ -> C2C a+addUsefull x m =+ if isGoodSrcSpan x+ then do a <- RWS.local (const x) m+ RWS.tell (SrcSpanRB x)+ return a+ else m++addUsefullR :: SrcSpan+ -> C2C a+ -> C2C a+addUsefullR x m =+ if isGoodSrcSpan x+ then RWS.local (const x) m+ else m++isIntegerTy :: Type -> C2C Bool+isIntegerTy (TyConApp tc []) = do+ tcNm <- qualifiedNameString (tyConName tc)+ return (tcNm == "GHC.Integer.Type.Integer")+isIntegerTy _ = return False++hasPrimCo :: Coercion -> C2C (Maybe Type)+hasPrimCo (TyConAppCo _ _ coers) = do+ tcs <- catMaybes <$> mapM hasPrimCo coers+ return (listToMaybe tcs)++hasPrimCo (AppCo co1 co2) = do+ tc1M <- hasPrimCo co1+ case tc1M of+ Just _ -> return tc1M+ _ -> hasPrimCo co2+hasPrimCo (ForAllCo _ _ co) = hasPrimCo co++hasPrimCo co@(AxiomInstCo _ _ coers) = do+ let (Pair ty1 _) = coercionKind co+ ty1PM <- isPrimTc ty1+ if ty1PM+ then return (Just ty1)+ else do+ tcs <- catMaybes <$> mapM hasPrimCo coers+ return (listToMaybe tcs)+ where+ isPrimTc (TyConApp tc _) = do+ tcNm <- qualifiedNameString (tyConName tc)+ return (tcNm `elem` ["Clash.Sized.Internal.BitVector.Bit"+ ,"Clash.Sized.Internal.BitVector.BitVector"+ ,"Clash.Sized.Internal.Index.Index"+ ,"Clash.Sized.Internal.Signed.Signed"+ ,"Clash.Sized.Internal.Unsigned.Unsigned"+ ])+ isPrimTc _ = return False++hasPrimCo (SymCo co) = hasPrimCo co++hasPrimCo (TransCo co1 co2) = do+ tc1M <- hasPrimCo co1+ case tc1M of+ Just _ -> return tc1M+ _ -> hasPrimCo co2++hasPrimCo (AxiomRuleCo _ coers) = do+ tcs <- catMaybes <$> mapM hasPrimCo coers+ return (listToMaybe tcs)++#if MIN_VERSION_ghc(8,6,0)+hasPrimCo (NthCo _ _ co) = hasPrimCo co+#else+hasPrimCo (NthCo _ co) = hasPrimCo co+#endif+hasPrimCo (LRCo _ co) = hasPrimCo co+hasPrimCo (InstCo co _) = hasPrimCo co+hasPrimCo (SubCo co) = hasPrimCo co++hasPrimCo _ = return Nothing++coreToDataCon :: DataCon+ -> C2C C.DataCon+coreToDataCon dc = do+ repTys <- mapM coreToType (dataConRepArgTys dc)+ dcTy <- coreToType (varType $ dataConWorkId dc)+ mkDc dcTy repTys+ where+ mkDc dcTy repTys = do+ let decLabel = decodeUtf8 . fastStringToByteString . flLabel+ let fLabels = map decLabel (dataConFieldLabels dc)++ nm <- coreToName dataConName getUnique qualifiedNameString dc+ uTvs <- mapM coreToTyVar (dataConUnivTyVars dc)+#if MIN_VERSION_ghc(8,8,0)+ eTvs <- mapM coreToTyVar (dataConExTyCoVars dc)+#else+ eTvs <- mapM coreToTyVar (dataConExTyVars dc)+#endif+ return $ C.MkData+ { C.dcName = nm+ , C.dcUniq = C.nameUniq nm+ , C.dcTag = dataConTag dc+ , C.dcType = dcTy+ , C.dcArgTys = repTys+ , C.dcUnivTyVars = uTvs+ , C.dcExtTyVars = eTvs+ , C.dcFieldLabels = fLabels+ }++typeConstructorToString+ :: TyCon+ -> C2C String+typeConstructorToString constructor =+ Text.unpack . C.nameOcc <$> coreToName tyConName tyConUnique qualifiedNameString constructor++_ATTR_NAME :: String+_ATTR_NAME = "Clash.Annotations.SynthesisAttributes.Attr"++-- | Flatten a list type structure to a list of types.+listTypeToListOfTypes :: Type -> [Type]+listTypeToListOfTypes (TyConApp _ [_, a, as]) = a : listTypeToListOfTypes as+listTypeToListOfTypes _ = []++-- | Try to determine boolean value by looking at constructor name of type.+boolTypeToBool :: Type -> C2C Bool+boolTypeToBool (TyConApp constructor _args) = do+ constructorName <- typeConstructorToString constructor+ return $ case constructorName of+ "GHC.Types.True" -> True+ "GHC.Types.False" -> False+ _ -> error $ "Expected boolean constructor, got:" ++ constructorName+boolTypeToBool s =+ error $ unwords [ "Could not unpack given type to bool:"+ , showPpr unsafeGlobalDynFlags s ]++-- | Returns string of (LitTy (StrTyLit s)) construction.+tyLitToString :: Type -> String+tyLitToString (LitTy (StrTyLit s)) = unpackFS s+tyLitToString s = error $ unwords [ "Could not unpack given type to string:"+ , showPpr unsafeGlobalDynFlags s ]++-- | Returns integer of (LitTy (NumTyLit n)) construction.+tyLitToInteger :: Type -> Integer+tyLitToInteger (LitTy (NumTyLit n)) = n+tyLitToInteger s = error $ unwords [ "Could not unpack given type to integer:"+ , showPpr unsafeGlobalDynFlags s ]++-- | Try to interpret a Type as an Attr+coreToAttr+ :: Type+ -> C2C C.Attr'+coreToAttr (TyConApp ty args) = do+ let key = args !! 0+ let value = args !! 1+ name' <- typeConstructorToString ty+ case name' of+ "Clash.Annotations.SynthesisAttributes.StringAttr" ->+ return $ C.StringAttr' (tyLitToString key) (tyLitToString value)+ "Clash.Annotations.SynthesisAttributes.IntegerAttr" ->+ return $ C.IntegerAttr' (tyLitToString key) (tyLitToInteger value)+ "Clash.Annotations.SynthesisAttributes.BoolAttr" -> do+ bool <- boolTypeToBool value+ return $ C.BoolAttr' (tyLitToString key) bool+ "Clash.Annotations.SynthesisAttributes.Attr" ->+ return $ C.Attr' (tyLitToString key)+ _ ->+ error $ unwords [ "Expected StringAttr, IntegerAttr, BoolAttr or Attr"+ , "constructor, got:" ++ name' ]++coreToAttr t =+ error $ unwords [ "Expected type constructor (TyConApp), but got:"+ , showPpr unsafeGlobalDynFlags t ]++coreToAttrs'+ :: [Type]+ -> C2C [C.Attr']+coreToAttrs' [annotationType, realType, attributes] = allAttrs+ where+ allAttrs = (++) <$> attrs <*> subAttrs++ subAttrs =+ coreToAttrs realType++ attrs =+ case annotationType of+ TyConApp ty [TyConApp ty' _args'] -> do+ name' <- typeConstructorToString ty+ name'' <- typeConstructorToString ty'++ let result | name' == "GHC.Types.[]" && name'' == _ATTR_NAME =+ -- List of attributes+ sequence $ map coreToAttr (listTypeToListOfTypes attributes)+ | name' == "GHC.Types.[]" =+ -- List, but unknown types+ error $ $(curLoc) ++ unwords [ "Annotate expects an"+ , "Attr or a list of"+ , "Attr's, but got a list"+ , "of:", name'']+ | otherwise =+ -- Some unknown nested type+ error $ $(curLoc) ++ unwords [ "Annotate expects an"+ , "Attr or a list of"+ , "Attr's, but got:"+ , name' ]++ result++ TyConApp ty _args -> do+ name' <- typeConstructorToString ty+ if name' == _ATTR_NAME+ then+ -- Single annotation+ sequence [coreToAttr attributes]+ else do+ -- Annotation to something we don't recognize (not a list,+ -- nor an Attr)+ tystr <- typeConstructorToString ty+ error $ unwords [ "Annotate expects an Attr or a list of Attr's,"+ , "but got:", tystr ]+ _ ->+ error $ $(curLoc) ++ unwords [ "Expected TyConApp, not:"+ , showPpr unsafeGlobalDynFlags annotationType]++coreToAttrs' illegal =+ error $ "Expected list with three items (as Annotate has three arguments), but got: "+ ++ show (map (showPpr unsafeGlobalDynFlags) illegal)++-- | If this type has an annotate type synonym, return list of attributes.+coreToAttrs+ :: Type+ -> C2C [C.Attr']+coreToAttrs (TyConApp tycon kindsOrTypes) = do+ name' <- typeConstructorToString tycon++ if name' == "Clash.Annotations.SynthesisAttributes.Annotate"+ then+ coreToAttrs' kindsOrTypes+ else+ return []++coreToAttrs _ =+ return []++-- | Wrap given type in an annotation if it is annotated using the constructs+-- defined in Clash.Annotations.SynthesisAttributes.+annotateType+ :: Type+ -> C.Type+ -> C2C C.Type+annotateType ty cty = do+ attrs <- coreToAttrs ty+ case attrs of+ [] -> return cty+ _ -> return $ C.AnnType attrs cty++-- | Converts GHC Type to a Clash Type. Strips newtypes and signals, with the+-- exception of newtypes used as annotations (see: SynthesisAttributes).+coreToType+ :: Type+ -> C2C C.Type+coreToType ty = ty'' >>= annotateType ty+ where+ ty'' =+ case coreView ty of+ Just ty' -> coreToType ty'+ Nothing -> coreToType' ty++coreToType'+ :: Type+ -> C2C C.Type+coreToType' (TyVarTy tv) = C.VarTy <$> coreToTyVar tv+coreToType' (TyConApp tc args)+ | isFunTyCon tc = foldl C.AppTy (C.ConstTy C.Arrow) <$> mapM coreToType args+ | otherwise = case expandSynTyCon_maybe tc args of+ Just (substs,synTy,remArgs) -> do+ let substs' = mkTvSubstPrs substs+ synTy' = substTy substs' synTy+ foldl C.AppTy <$> coreToType synTy' <*> mapM coreToType remArgs+ _ -> do+ tcName <- coreToName tyConName tyConUnique qualifiedNameString tc+ tyConMap %= (C.extendUniqMap tcName tc)+ C.mkTyConApp <$> (pure tcName) <*> mapM coreToType args+#if MIN_VERSION_ghc(8,8,0)+coreToType' (ForAllTy (Bndr tv _) ty) = C.ForAllTy <$> coreToTyVar tv <*> coreToType ty+#else+coreToType' (ForAllTy (TvBndr tv _) ty) = C.ForAllTy <$> coreToTyVar tv <*> coreToType ty+#endif+coreToType' (FunTy ty1 ty2) = C.mkFunTy <$> coreToType ty1 <*> coreToType ty2+coreToType' (LitTy tyLit) = return $ C.LitTy (coreToTyLit tyLit)+coreToType' (AppTy ty1 ty2) = C.AppTy <$> coreToType ty1 <*> coreToType' ty2+coreToType' t@(CastTy _ _) = error ("Cannot handle CastTy " ++ showPpr unsafeGlobalDynFlags t)+coreToType' t@(CoercionTy _) = error ("Cannot handle CoercionTy " ++ showPpr unsafeGlobalDynFlags t)++coreToTyLit :: TyLit+ -> C.LitTy+coreToTyLit (NumTyLit i) = C.NumTy (fromInteger i)+coreToTyLit (StrTyLit s) = C.SymTy (unpackFS s)++coreToTyVar :: TyVar+ -> C2C C.TyVar+coreToTyVar tv =+ C.mkTyVar <$> coreToType (varType tv) <*> coreToVar tv++coreToId :: Id+ -> C2C C.Id+coreToId i = do+ C.mkId <$> coreToType (varType i) <*> pure scope <*> coreToVar i+ where+ scope = if isGlobalId i then C.GlobalId else C.LocalId++coreToVar :: Var+ -> C2C (C.Name a)+coreToVar = coreToName varName varUnique qualifiedNameStringM++coreToPrimVar :: Var+ -> C2C (C.Name C.Term)+coreToPrimVar = coreToName varName varUnique qualifiedNameString++coreToName+ :: (b -> Name)+ -> (b -> Unique)+ -> (Name -> C2C Text)+ -> b+ -> C2C (C.Name a)+coreToName toName toUnique toString v = do+ ns <- toString (toName v)+ let key = getKey (toUnique v)+ locI = getSrcSpan (toName v)+ sort | ns == "ds" || Text.isPrefixOf "$" ns+ = C.System+ | otherwise+ = C.User+ locR <- RWS.ask+ let loc = if isGoodSrcSpan locI then locI else locR+ return (C.Name sort ns key loc)++qualifiedNameString'+ :: Name+ -> Text+qualifiedNameString' n =+ fromMaybe "_INTERNAL_" (modNameM n) `Text.append` ('.' `Text.cons` occName)+ where+ occName = pack (occNameString (nameOccName n))++qualifiedNameString+ :: Name+ -> C2C Text+qualifiedNameString n =+ makeCached n nameMap $+ return (fromMaybe "_INTERNAL_" (modNameM n) `Text.append` ('.' `Text.cons` occName))+ where+ occName = pack (occNameString (nameOccName n))++qualifiedNameStringM+ :: Name+ -> C2C Text+qualifiedNameStringM n =+ makeCached n nameMap $+ return (maybe occName (\modName -> modName `Text.append` ('.' `Text.cons` occName)) (modNameM n))+ where+ occName = pack (occNameString (nameOccName n))++modNameM :: Name+ -> Maybe Text+modNameM n = do+ module_ <- nameModule_maybe n+ let moduleNm = moduleName module_+ return (pack (moduleNameString moduleNm))++-- | Given the type:+--+-- @forall a. forall b. forall clk. (a -> b) -> Signal clk a -> Signal clk b@+--+-- Generate the term:+--+-- @+-- /\(a:*)./\(b:*)./\(clk:Clock).\(f : (Signal clk a -> Signal clk b)).+-- \(x : Signal clk a).f x+-- @+mapSignalTerm :: C.Type+ -> C.Term+mapSignalTerm (C.ForAllTy aTV (C.ForAllTy bTV (C.ForAllTy clkTV funTy))) =+ C.TyLam aTV (+ C.TyLam bTV (+ C.TyLam clkTV (+ C.Lam fId (+ C.Lam xId (+ C.App (C.Var fId) (C.Var xId))))))+ where+ (C.FunTy _ funTy'') = C.tyView funTy+ (C.FunTy aTy bTy) = C.tyView funTy''+ fName = C.mkUnsafeSystemName "f" 0+ xName = C.mkUnsafeSystemName "x" 1+ fTy = C.mkFunTy aTy bTy+ fId = C.mkLocalId fTy fName+ xId = C.mkLocalId aTy xName++mapSignalTerm ty = error $ $(curLoc) ++ show ty++-- | Given the type:+--+-- @forall a. forall clk. a -> Signal clk a@+--+-- Generate the term+--+-- @/\(a:*)./\(clk:Clock).\(x:Signal clk a).x@+signalTerm :: C.Type+ -> C.Term+signalTerm (C.ForAllTy aTV (C.ForAllTy clkTV funTy)) =+ C.TyLam aTV (+ C.TyLam clkTV (+ C.Lam xId (+ C.Var xId)))+ where+ (C.FunTy _ aTy) = C.tyView funTy+ xName = C.mkUnsafeSystemName "x" 0+ xId = C.mkLocalId aTy xName++signalTerm ty = error $ $(curLoc) ++ show ty++-- | Given the type:+--+-- @+-- forall clk. forall a. forall b. Signal clk (a -> b) -> Signal clk a ->+-- Signal clk b+-- @+--+-- Generate the term:+--+-- @+-- /\(clk:Clock)./\(a:*)./\(b:*).\(f : (Signal clk a -> Signal clk b)).+-- \(x : Signal clk a).f x+-- @+appSignalTerm :: C.Type+ -> C.Term+appSignalTerm (C.ForAllTy clkTV (C.ForAllTy aTV (C.ForAllTy bTV funTy))) =+ C.TyLam clkTV (+ C.TyLam aTV (+ C.TyLam bTV (+ C.Lam fId (+ C.Lam xId (+ C.App (C.Var fId) (C.Var xId))))))+ where+ (C.FunTy _ funTy'') = C.tyView funTy+ (C.FunTy aTy bTy) = C.tyView funTy''+ fName = C.mkUnsafeSystemName "f" 0+ xName = C.mkUnsafeSystemName "x" 1+ fTy = C.mkFunTy aTy bTy+ fId = C.mkLocalId fTy fName+ xId = C.mkLocalId aTy xName++appSignalTerm ty = error $ $(curLoc) ++ show ty++-- | Given the type:+--+-- @+-- forall t.forall n.forall a.Vec n (Signal t a) ->+-- Signal t (Vec n a)+-- @+--+-- Generate the term:+--+-- @+-- /\(t:Clock)./\(n:Nat)./\(a:*).\(vs:Signal t (Vec n a)).vs+-- @+vecUnwrapTerm :: C.Type+ -> C.Term+vecUnwrapTerm (C.ForAllTy tTV (C.ForAllTy nTV (C.ForAllTy aTV funTy))) =+ C.TyLam tTV (+ C.TyLam nTV (+ C.TyLam aTV (+ C.Lam vsId (+ C.Var vsId))))+ where+ (C.FunTy _ vsTy) = C.tyView funTy+ vsName = C.mkUnsafeSystemName "vs" 0+ vsId = C.mkLocalId vsTy vsName++vecUnwrapTerm ty = error $ $(curLoc) ++ show ty++-- | Given the type:+--+-- @+-- forall f.forall a.forall b.forall clk.Applicative f => (a -> f b) ->+-- CSignal clk a -> f (Signal clk b)+-- @+--+-- Generate the term:+--+-- @+-- /\(f:* -> *)./\(a:*)./\(b:*)./\(clk:Clock).\(dict:Applicative f).+-- \(g:a -> f b).\(x:Signal clk a).g x+-- @+traverseTerm :: C.Type+ -> C.Term+traverseTerm (C.ForAllTy fTV (C.ForAllTy aTV (C.ForAllTy bTV (C.ForAllTy clkTV funTy)))) =+ C.TyLam fTV (+ C.TyLam aTV (+ C.TyLam bTV (+ C.TyLam clkTV (+ C.Lam dictId (+ C.Lam gId (+ C.Lam xId (+ C.App (C.Var gId) (C.Var xId))))))))+ where+ (C.FunTy dictTy funTy1) = C.tyView funTy+ (C.FunTy gTy funTy2) = C.tyView funTy1+ (C.FunTy xTy _) = C.tyView funTy2+ dictName = C.mkUnsafeSystemName "dict" 0+ gName = C.mkUnsafeSystemName "g" 1+ xName = C.mkUnsafeSystemName "x" 2+ dictId = C.mkLocalId dictTy dictName+ gId = C.mkLocalId gTy gName+ xId = C.mkLocalId xTy xName++traverseTerm ty = error $ $(curLoc) ++ show ty++-- ∀ (r :: GHC.Types.RuntimeRep)+-- (a :: GHC.Prim.TYPE GHC.Types.PtrRepLifted)+-- (b :: GHC.Prim.TYPE r).+-- (a -> b) -> a -> b+++-- | Given the type:+--+-- @forall (r :: Rep) (a :: TYPE Lifted) (b :: TYPE r). (a -> b) -> a -> b@+--+-- Generate the term:+--+-- @/\(r:Rep)/\(a:TYPE Lifted)./\(b:TYPE r).\(f : (a -> b)).\(x : a).f x@+dollarTerm :: C.Type+ -> C.Term+dollarTerm (C.ForAllTy rTV (C.ForAllTy aTV (C.ForAllTy bTV funTy))) =+ C.TyLam rTV (+ C.TyLam aTV (+ C.TyLam bTV (+ C.Lam fId (+ C.Lam xId (+ C.App (C.Var fId) (C.Var xId))))))+ where+ (C.FunTy fTy funTy'') = C.tyView funTy+ (C.FunTy aTy _) = C.tyView funTy''+ fName = C.mkUnsafeSystemName "f" 0+ xName = C.mkUnsafeSystemName "x" 1+ fId = C.mkLocalId fTy fName+ xId = C.mkLocalId aTy xName++dollarTerm ty = error $ $(curLoc) ++ show ty++-- | Given the type:+--+-- @forall a. forall clk. Signal clk (Signal clk a) -> Signal clk a@+--+-- Generate the term+--+-- @/\(a:*)./\(clk:Clock).\(x:Signal clk a).x@+joinTerm :: C.Type+ -> C.Term+joinTerm ty@(C.ForAllTy {}) = signalTerm ty+joinTerm ty = error $ $(curLoc) ++ show ty++-- | Given the type:+--+-- @forall a. CallStack -> (HasCallStack => a) -> a@+--+-- Generate the term+--+-- @/\(a:*)./\(callStack:CallStack).\(f:HasCallStack => a).f callStack@+withFrozenCallStackTerm+ :: C.Type+ -> C.Term+withFrozenCallStackTerm (C.ForAllTy aTV funTy) =+ C.TyLam aTV (+ C.Lam callStackId (+ C.Lam fId (+ C.App (C.Var fId) (C.Var callStackId))))+ where+ (C.FunTy callStackTy fTy) = C.tyView funTy+ callStackName = C.mkUnsafeSystemName "callStack" 0+ fName = C.mkUnsafeSystemName "f" 1+ callStackId = C.mkLocalId callStackTy callStackName+ fId = C.mkLocalId fTy fName++withFrozenCallStackTerm ty = error $ $(curLoc) ++ show ty++-- | Given the type:+--+-- @forall a. a -> a@+--+-- Generate the term+--+-- @/\(a:*).\(x:a).x@+idTerm+ :: C.Type+ -> C.Term+idTerm (C.ForAllTy aTV funTy) =+ C.TyLam aTV (+ C.Lam xId (+ C.Var xId))+ where+ (C.FunTy xTy _) = C.tyView funTy+ xName = C.mkUnsafeSystemName "x" 0+ xId = C.mkLocalId xTy xName++idTerm ty = error $ $(curLoc) ++ show ty++-- | Given type type:+--+-- @forall (r :: RuntimeRep) (o :: TYPE r).(State# RealWorld -> o) -> o@+--+-- Genereate the term:+--+-- @/\(r:RuntimeRep)./\(o:TYPE r).\(f:State# RealWord -> o) -> f realWorld#@+runRWTerm+ :: C.Type+ -> C.Term+runRWTerm (C.ForAllTy rTV (C.ForAllTy oTV funTy)) =+ C.TyLam rTV (+ C.TyLam oTV (+ C.Lam fId (+ (C.App (C.Var fId) (C.Prim rwNm (C.PrimInfo rwTy C.WorkNever))))))+ where+ (C.FunTy fTy _) = C.tyView funTy+ (C.FunTy rwTy _) = C.tyView fTy+ fName = C.mkUnsafeSystemName "f" 0+ fId = C.mkLocalId fTy fName+ rwNm = pack "GHC.Prim.realWorld#"++runRWTerm ty = error $ $(curLoc) ++ show ty++-- | Given type type:+--+-- @forall (n :: Nat) (a :: Type) .Knownnat n => (a -> BitVector n) -> a -> BitVector n@+--+-- Genereate the term:+--+-- @/\(n:Nat)./\(a:TYPE r).\(kn:KnownNat n).\(f:a -> BitVector n).f@+packXWithTerm+ :: C.Type+ -> C.Term+packXWithTerm (C.ForAllTy nTV (C.ForAllTy aTV funTy)) =+ C.TyLam nTV (+ C.TyLam aTV (+ C.Lam knId (+ C.Lam fId (+ C.Var fId))))+ where+ C.FunTy knTy rTy = C.tyView funTy+ C.FunTy fTy _ = C.tyView rTy+ knName = C.mkUnsafeSystemName "kn" 0+ fName = C.mkUnsafeSystemName "f" 1+ knId = C.mkLocalId knTy knName+ fId = C.mkLocalId fTy fName++packXWithTerm ty = error $ $(curLoc) ++ show ty++-- | Given type type:+--+-- @forall (n :: Nat) (a :: Type) .Knownnat n => Typeable a => (BitVector n -> a) -> BitVector n -> a@+--+-- Genereate the term:+--+-- @/\(n:Nat)./\(a:TYPE r).\(kn:KnownNat n).\(f:a -> BitVector n).f@+checkUnpackUndefTerm+ :: C.Type+ -> C.Term+checkUnpackUndefTerm (C.ForAllTy nTV (C.ForAllTy aTV funTy)) =+ C.TyLam nTV (+ C.TyLam aTV (+ C.Lam knId (+ C.Lam tpId (+ C.Lam fId (+ C.Var fId)))))+ where+ C.FunTy knTy r0Ty = C.tyView funTy+ C.FunTy tpTy r1Ty = C.tyView r0Ty+ C.FunTy fTy _ = C.tyView r1Ty+ knName = C.mkUnsafeSystemName "kn" 0+ tpName = C.mkUnsafeSystemName "tp" 1+ fName = C.mkUnsafeSystemName "f" 2+ knId = C.mkLocalId knTy knName+ tpId = C.mkLocalId tpTy tpName+ fId = C.mkLocalId fTy fName++checkUnpackUndefTerm ty = error $ $(curLoc) ++ show ty++-- | Given the type:+--+-- @forall (name :: Symbol) (a :: Type) . a -> (name ::: a)@+--+-- Generate the term:+--+-- @/\(name:Symbol)./\(a:Type).\(x:a) -> <TICK>x@+nameModTerm+ :: C.NameMod+ -> C.Type+ -> C.Term+nameModTerm sa (C.ForAllTy nmTV (C.ForAllTy aTV funTy)) =+ C.TyLam nmTV (+ C.TyLam aTV (+ C.Lam xId (+ (C.Tick (C.NameMod sa (C.VarTy nmTV)) (C.Var xId)))))+ where+ (C.FunTy xTy _) = C.tyView funTy+ -- Safe to use `mkUnsafeSystemName` here, because we're building the+ -- identity \x.x, so any shadowing of 'x' would be the desired behavior.+ xName = C.mkUnsafeSystemName "x" 0+ xId = C.mkLocalId xTy xName++nameModTerm _ ty = error $ $(curLoc) ++ show ty isDataConWrapId :: Id -> Bool isDataConWrapId v = case idDetails v of
src-ghc/Clash/GHC/GenerateBindings.hs view
@@ -5,196 +5,279 @@ Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com> -} -{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-} module Clash.GHC.GenerateBindings (generateBindings) where -import Control.Lens ((%~),(&),(^.),_1,_2)-import Control.Monad.State (State)+import Control.DeepSeq (deepseq)+import Control.Lens ((%~),(&),view,_1)+import Control.Monad (unless) import qualified Control.Monad.State as State-import Data.Either (lefts, rights)-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap+import qualified Control.Monad.RWS.Lazy as RWS+import Data.Coerce (coerce)+import Data.Either (partitionEithers, lefts, rights) import Data.IntMap.Strict (IntMap)-import qualified Data.IntMap.Strict as IM-import Data.List (foldl')-import Data.Text.Lazy (Text)-import qualified Data.Set as Set-import qualified Data.Set.Lens as Lens-import Unbound.Generics.LocallyNameless (bind,embed,rec,runFreshM,unembed)+import qualified Data.IntMap.Strict as IMS+import qualified Data.HashMap.Strict as HashMap+import Data.List (isPrefixOf)+import qualified Data.Text as Text+import qualified Data.Time.Clock as Clock import qualified BasicTypes as GHC import qualified CoreSyn as GHC+import qualified Demand as GHC import qualified DynFlags as GHC import qualified IdInfo as GHC+import qualified Outputable as GHC import qualified Name as GHC hiding (varName) import qualified TyCon as GHC+import qualified Type as GHC import qualified TysWiredIn as GHC+import qualified Util as GHC import qualified Var as GHC import qualified SrcLoc as GHC +import Clash.Annotations.BitRepresentation.Internal (DataRepr') import Clash.Annotations.TopEntity (TopEntity)-import Clash.Annotations.Primitive (HDL)-import Clash.Core.FreeVars (termFreeIds)-import Clash.Core.Name (Name (..), string2SystemName)-import Clash.Core.Term (Term (..), TmName, TmOccName)-import Clash.Core.Type (Type, TypeView (..), mkFunTy, splitFunForallTy, tyView)-import Clash.Core.TyCon (TyCon, TyConName, TyConOccName)+import Clash.Annotations.Primitive (HDL, extractPrim)++import Clash.Core.Subst (extendGblSubstList, mkSubst, substTm)+import Clash.Core.Term (Term (..))+import Clash.Core.Type (Type (..), TypeView (..), mkFunTy, splitFunForallTy, tyView)+import Clash.Core.TyCon (TyConMap, TyConName, isNewTypeTc) import Clash.Core.TysPrim (tysPrimMap)-import Clash.Core.Subst (substTms)-import Clash.Core.Util (mkLams, mkTyLams, termType)-import Clash.Core.Var (Var (..))+import Clash.Core.Util (mkLams, mkTyLams)+import Clash.Core.Var (Var (..), Id, IdScope (..), setIdScope)+import Clash.Core.VarEnv+ (InScopeSet, VarEnv, emptyInScopeSet, extendInScopeSet, mkInScopeSet, mkVarEnv, unionVarEnv)+import Clash.Driver (compilePrimitive) import Clash.Driver.Types (BindingMap)-import Clash.GHC.GHC2Core (GHC2CoreState, tyConMap, coreToId, coreToName, coreToTerm,- makeAllTyCons, qualfiedNameString, emptyGHC2CoreState)-import Clash.GHC.LoadModules (loadModules)-import Clash.Primitives.Types (PrimMap)+import Clash.GHC.GHC2Core+ (C2C, GHC2CoreState, tyConMap, coreToId, coreToName, coreToTerm,+ makeAllTyCons, qualifiedNameString, emptyGHC2CoreState)+import Clash.GHC.LoadModules (ghcLibDir, loadModules)+import Clash.Netlist.BlackBox.Util (usedArguments)+import Clash.Primitives.Types+ (Primitive (..), CompiledPrimMap) import Clash.Primitives.Util (generatePrimMap) import Clash.Rewrite.Util (mkInternalVar, mkSelectorCase)-import Clash.Util ((***),first)+import Clash.Unique+ (listToUniqMap, lookupUniqMap, mapUniqMap, unionUniqMap, uniqMapToUniqSet)+import Clash.Util+ ((***),first,traceIf,indexMaybe,reportTimeDiff) -generateBindings ::- [FilePath] -- ^ primitives (blackbox) directory+generateBindings+ :: GHC.OverridingBool+ -- ^ Use color -> [FilePath]+ -- ^ primitives (blackbox) directories+ -> [FilePath]+ -- ^ import directories (-i flag)+ -> [FilePath]+ -- ^ Package database -> HDL+ -- ^ HDL target -> String- -> Maybe (GHC.DynFlags)- -> IO (BindingMap,HashMap TyConOccName TyCon,IntMap TyConName- ,[( TmName -- topEntity bndr- , Type -- type of the topEntity bndr- , Maybe TopEntity -- (maybe) TopEntity annotation- , Maybe TmName)] -- (maybe) associated testbench- ,PrimMap Text) -- The primitives found in '.' and 'primDir'-generateBindings primDirs importDirs hdl modName dflagsM = do- (bindings,clsOps,unlocatable,fiEnvs,topEntities,pFP) <- loadModules hdl modName dflagsM- primMap <- generatePrimMap $ concat [pFP, primDirs, importDirs]- let ((bindingsMap,clsVMap),tcMap) = State.runState (mkBindings primMap bindings clsOps unlocatable) emptyGHC2CoreState+ -> Maybe GHC.DynFlags+ -> IO ( BindingMap+ , TyConMap+ , IntMap TyConName+ , [( Id+ , Maybe TopEntity -- (maybe) TopEntity annotation+ , Maybe Id -- (maybe) associated testbench+ )]+ , CompiledPrimMap -- The primitives found in '.' and 'primDir'+ , [DataRepr']+ )+generateBindings useColor primDirs importDirs dbs hdl modName dflagsM = do+ ( bindings+ , clsOps+ , unlocatable+ , fiEnvs+ , topEntities+ , partitionEithers -> (unresolvedPrims, pFP)+ , customBitRepresentations+ , primGuards ) <- loadModules useColor hdl modName dflagsM importDirs+ primMapR <- generatePrimMap unresolvedPrims primGuards (concat [pFP, primDirs, importDirs])+ tdir <- maybe ghcLibDir (pure . GHC.topDir) dflagsM+ startTime <- Clock.getCurrentTime+ primMapC <-+ sequence $ HashMap.map+ (sequence . fmap (compilePrimitive importDirs dbs tdir))+ primMapR+ let ((bindingsMap,clsVMap),tcMap,_) =+ RWS.runRWS (mkBindings primMapC bindings clsOps unlocatable)+ GHC.noSrcSpan+ emptyGHC2CoreState (tcMap',tupTcCache) = mkTupTyCons tcMap tcCache = makeAllTyCons tcMap' fiEnvs- allTcCache = tysPrimMap `HashMap.union` tcCache- clsMap = HashMap.map (\(nm,ty,i) -> (nm,ty,GHC.noSrcSpan,GHC.Inline,mkClassSelector allTcCache ty i)) clsVMap- allBindings = bindingsMap `HashMap.union` clsMap+ allTcCache = tysPrimMap `unionUniqMap` tcCache+ inScope0 = mkInScopeSet (uniqMapToUniqSet+ ((mapUniqMap (coerce . view _1) bindingsMap) `unionUniqMap`+ (mapUniqMap (coerce . view _1) clsMap)))+ clsMap = mapUniqMap (\(v,i) -> (v,GHC.noSrcSpan,GHC.Inline,mkClassSelector inScope0 allTcCache (varType v) i)) clsVMap+ allBindings = bindingsMap `unionVarEnv` clsMap topEntities' =- flip State.evalState tcMap' $ mapM (\(topEnt,annM,benchM) -> do- topEnt' <- coreToName GHC.varName GHC.varUnique qualfiedNameString topEnt- benchM' <- traverse (coreToName GHC.varName GHC.varUnique qualfiedNameString) benchM+ (\m -> fst (RWS.evalRWS m GHC.noSrcSpan tcMap')) $ mapM (\(topEnt,annM,benchM) -> do+ topEnt' <- coreToName GHC.varName GHC.varUnique qualifiedNameString topEnt+ benchM' <- traverse coreToId benchM return (topEnt',annM,benchM')) topEntities- retypedBindings = retypeBindings allTcCache allBindings topEntities'- topEntities'' = map (\(topEnt,annM,benchM) -> case HashMap.lookup (nameOcc topEnt) retypedBindings of- Just (_,ty,_,_,_) -> (topEnt,ty,annM,benchM)- Nothing -> error "This shouldn't happen"+ topEntities'' = map (\(topEnt,annM,benchM) -> case lookupUniqMap topEnt allBindings of+ Just (v,_,_,_) -> (v,annM,benchM)+ Nothing -> error "This shouldn't happen" ) topEntities'-- return (retypedBindings,allTcCache,tupTcCache,topEntities'',primMap)--retypeBindings- :: HashMap TyConOccName TyCon- -> BindingMap- -> [(TmName,Maybe TopEntity,Maybe TmName)]- -> BindingMap-retypeBindings allTcCache = foldl' go- where- go allBindings (topEnt,_,benchM) = bBindings- where- topEntity = do e <- HashMap.lookup (nameOcc topEnt) allBindings- return (nameOcc topEnt,e)- bench = do t <- benchM- e <- HashMap.lookup (nameOcc t) allBindings- return (nameOcc t,e)-- tBindings = maybe allBindings (retype' allBindings) topEntity- bBindings = maybe tBindings (retype' tBindings) bench- retype' d (t,_) = snd (retype allTcCache ([],d) t)+ -- Parsing / compiling primitives:+ prepTime <- startTime `deepseq` primMapC `seq` Clock.getCurrentTime+ let prepStartDiff = reportTimeDiff prepTime startTime+ putStrLn $ "Clash: Parsing and compiling primitives took " ++ prepStartDiff --- | clean up cast-removal mess-retype- :: HashMap TyConOccName TyCon- -> ([TmOccName], BindingMap) -- (visited, bindings)- -> TmOccName -- top- -> ([TmOccName], BindingMap)-retype tcm (visited,bindings) current = (visited', HashMap.insert current (nm,ty',sp,inl,tm') bindings')- where- (nm,_,sp,inl,tm) = bindings HashMap.! current- used = Set.toList $ Lens.setOf termFreeIds tm- (visited',bindings') = foldl (retype tcm) (current:visited,bindings) (filter (`notElem` visited) used)- used' = map ((^. _1) . (bindings' HashMap.!)) used- usedTys = map ((^. _2) . (bindings' HashMap.!)) used- usedVars = zipWith Var usedTys used'- tm' = substTms (zip used usedVars) tm- ty' = runFreshM (termType tcm tm')+ return ( allBindings+ , allTcCache+ , tupTcCache+ , topEntities''+ , primMapC+ , customBitRepresentations+ ) mkBindings- :: PrimMap a+ :: CompiledPrimMap -> [GHC.CoreBind] -- Binders -> [(GHC.CoreBndr,Int)] -- Class operations -> [GHC.CoreBndr] -- Unlocatable Expressions- -> State GHC2CoreState- ( BindingMap- , HashMap TmOccName (TmName,Type,Int)- )+ -> C2C ( BindingMap+ , VarEnv (Id,Int)+ ) mkBindings primMap bindings clsOps unlocatable = do bindingsList <- mapM (\case- GHC.NonRec v e -> do- let sp = GHC.getSrcSpan v- inl = GHC.inlinePragmaSpec . GHC.inlinePragInfo $ GHC.idInfo v- tm <- coreToTerm primMap unlocatable sp e- v' <- coreToId v- return [(nameOcc (varName v'), (varName v',unembed (varType v'), sp, inl, tm))]- GHC.Rec bs -> do- tms <- mapM (\(v,e) -> do- let sp = GHC.getSrcSpan v- tm <- coreToTerm primMap unlocatable sp e- v' <- coreToId v- return (v',sp,tm)- ) bs- case tms of- [(v,sp,tm)] -> return [(nameOcc (varName v), (varName v,unembed (varType v), sp, GHC.NoInline, tm))]- _ ->- return $ map (\(v,sp,e) -> (nameOcc (varName v),(varName v,unembed (varType v),sp,GHC.NoInline- ,Letrec (bind (rec (map (\(x,_,y) -> (x,embed y)) tms)) e)))) tms- ) bindings+ GHC.NonRec v e -> do+ let sp = GHC.getSrcSpan v+ inl = GHC.inlinePragmaSpec . GHC.inlinePragInfo $ GHC.idInfo v+ tm <- RWS.local (const sp) (coreToTerm primMap unlocatable e)+ v' <- coreToId v+ checkPrimitive primMap v+ return [(v', (v', sp, inl, tm))]+ GHC.Rec bs -> do+ tms <- mapM (\(v,e) -> do+ let sp = GHC.getSrcSpan v+ inl = GHC.inlinePragmaSpec . GHC.inlinePragInfo $ GHC.idInfo v+ tm <- RWS.local (const sp) (coreToTerm primMap unlocatable e)+ v' <- coreToId v+ checkPrimitive primMap v+ return (v',sp,inl,tm)+ ) bs+ case tms of+ [(v,sp,inl,tm)] -> return [(v, (v, sp, inl, tm))]+ _ -> let vsL = map (setIdScope LocalId . view _1) tms+ vsV = map Var vsL+ subst = extendGblSubstList (mkSubst emptyInScopeSet) (zip vsL vsV)+ lbs = zipWith (\(_,_,_,e) vL -> (vL,substTm "mkBindings" subst e)) tms vsL+ tms1 = zipWith (\(v,sp,inl,_) (_,e) -> (v,(v,sp,inl,Letrec lbs e))) tms lbs+ in return tms1+ ) bindings clsOpList <- mapM (\(v,i) -> do v' <- coreToId v- let ty = unembed $ varType v'- return (nameOcc (varName v'), (varName v',ty,i))+ return (v', (v',i)) ) clsOps - return (HashMap.fromList (concat bindingsList), HashMap.fromList clsOpList)+ return (mkVarEnv (concat bindingsList), mkVarEnv clsOpList) +-- | If this CoreBndr is a primitive, check it's Haskell definition+-- for potential problems.+--+-- Warns when a primitive:+-- * isn't marked NOINLINE+-- * produces an error when evaluating its result to WHNF+-- * isn't using all its arguments+checkPrimitive :: CompiledPrimMap -> GHC.CoreBndr -> C2C ()+checkPrimitive primMap v = do+ nm <- qualifiedNameString (GHC.varName v)+ case HashMap.lookup nm primMap of+ Just (extractPrim -> Just (BlackBox _ _ _ _ _ _ _ inc templ)) -> do+ let+ info = GHC.idInfo v+ inline = GHC.inlinePragmaSpec $ GHC.inlinePragInfo info+ strictness = GHC.strictnessInfo info+ ty = GHC.varType v+ (argTys,_resTy) = GHC.splitFunTys . snd . GHC.splitForAllTys $ ty+ (dmdArgs,_dmdRes) = GHC.splitStrictSig strictness+ nrOfArgs = length argTys+ loc = case GHC.getSrcLoc v of+ GHC.UnhelpfulLoc _ -> ""+ GHC.RealSrcLoc l -> showPpr l ++ ": "+ warnIf cond msg = traceIf cond ("\n"++loc++"Warning: "++msg) return ()+ qName <- Text.unpack <$> qualifiedNameString (GHC.varName v)+ let primStr = "primitive " ++ qName ++ " "+ let usedArgs = usedArguments templ ++ concatMap (usedArguments . snd) inc++ let warnArgs [] = return ()+ warnArgs (x:xs) = do+ warnIf (maybe False GHC.isAbsDmd (indexMaybe dmdArgs x))+ ("The Haskell implementation of " ++ primStr ++ "isn't using argument #" +++ show (x+1) ++ ", but the corresponding primitive blackbox does.\n" +++ "This can lead to compile failures because GHC can replace these " +++ "arguments by an undefined value.")+ warnArgs xs++ unless (qName == "Clash.XException.errorX" || "GHC." `isPrefixOf` qName) $ do+ warnIf (inline /= GHC.NoInline)+ (primStr ++ "isn't marked NOINLINE."+ ++ "\nThis might make Clash ignore this primitive.")+ warnIf (GHC.appIsBottom strictness nrOfArgs)+ ("The Haskell implementation of " ++ primStr+ ++ "produces a result that always results in an error.\n"+ ++ "This can lead to compile failures because GHC can replace entire "+ ++ "calls to this primitive by an undefined value.")+ warnArgs usedArgs+ _ -> return ()+ where+ showPpr :: GHC.Outputable a => a -> String+ showPpr = GHC.showSDocUnsafe . GHC.ppr+ mkClassSelector- :: HashMap TyConOccName TyCon+ :: InScopeSet+ -> TyConMap -> Type -> Int -> Term-mkClassSelector tcm ty sel = newExpr+mkClassSelector inScope0 tcm ty sel = newExpr where ((tvs,dictTy:_),_) = first (lefts *** rights) $ first (span (\l -> case l of Left _ -> True _ -> False)) $ splitFunForallTy ty newExpr = case tyView dictTy of- (TyConApp _ _) -> runFreshM $ flip State.evalStateT (0 :: Int) $ do- (dcId,dcVar) <- mkInternalVar (string2SystemName "dict") dictTy- selE <- mkSelectorCase "mkClassSelector" tcm dcVar 1 sel+ (TyConApp tcNm _)+ | Just tc <- lookupUniqMap tcNm tcm+ , not (isNewTypeTc tc)+ -> flip State.evalState (0 :: Int) $ do+ dcId <- mkInternalVar inScope0 "dict" dictTy+ let inScope1 = extendInScopeSet inScope0 dcId+ selE <- mkSelectorCase "mkClassSelector" inScope1 tcm (Var dcId) 1 sel return (mkTyLams (mkLams selE [dcId]) tvs)- (FunTy arg res) -> runFreshM $ flip State.evalStateT (0 :: Int) $ do- (dcId,dcVar) <- mkInternalVar (string2SystemName "dict") (mkFunTy arg res)- return (mkTyLams (mkLams dcVar [dcId]) tvs)- (OtherType oTy) -> runFreshM $ flip State.evalStateT (0 :: Int) $ do- (dcId,dcVar) <- mkInternalVar (string2SystemName "dict") oTy- return (mkTyLams (mkLams dcVar [dcId]) tvs)+ (FunTy arg res) -> flip State.evalState (0 :: Int) $ do+ dcId <- mkInternalVar inScope0 "dict" (mkFunTy arg res)+ return (mkTyLams (mkLams (Var dcId) [dcId]) tvs)+ _ -> flip State.evalState (0 :: Int) $ do+ dcId <- mkInternalVar inScope0 "dict" dictTy+ return (mkTyLams (mkLams (Var dcId) [dcId]) tvs) mkTupTyCons :: GHC2CoreState -> (GHC2CoreState,IntMap TyConName) mkTupTyCons tcMap = (tcMap'',tupTcCache) where- tupTyCons = map (GHC.tupleTyCon GHC.Boxed) [2..62]- (tcNames,tcMap') = State.runState (mapM (\tc -> coreToName GHC.tyConName GHC.tyConUnique qualfiedNameString tc) tupTyCons) tcMap- tupTcCache = IM.fromList (zip [2..62] tcNames)- tupHM = HashMap.fromList (zip (map nameOcc tcNames) tupTyCons)- tcMap'' = tcMap' & tyConMap %~ (`HashMap.union` tupHM)+ tupTyCons = GHC.boolTyCon : GHC.promotedTrueDataCon : GHC.promotedFalseDataCon+ : map (GHC.tupleTyCon GHC.Boxed) [2..62]+ (tcNames,tcMap',_) =+ RWS.runRWS (mapM (\tc -> coreToName GHC.tyConName GHC.tyConUnique+ qualifiedNameString tc) tupTyCons)+ GHC.noSrcSpan+ tcMap+ tupTcCache = IMS.fromList (zip [2..62] (drop 3 tcNames))+ tupHM = listToUniqMap (zip tcNames tupTyCons)+ tcMap'' = tcMap' & tyConMap %~ (`unionUniqMap` tupHM)
src-ghc/Clash/GHC/LoadInterfaceFiles.hs view
@@ -10,29 +10,28 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-} module Clash.GHC.LoadInterfaceFiles ( loadExternalExprs- , primitiveFilePath+ , unresolvedPrimitives ) where -- External Modules import Control.Monad.IO.Class (MonadIO (..))-import Data.Char (toLower)+import qualified Data.ByteString.Lazy.UTF8 as BLU+import qualified Data.ByteString.Lazy as BL import Data.Either (partitionEithers) import Data.List (elemIndex, foldl', partition)-import Data.Maybe (fromMaybe, isJust, isNothing,- mapMaybe)+import qualified Data.Text as Text+import Data.Maybe (isJust, isNothing,+ mapMaybe, catMaybes) import Data.Word (Word8)-import System.Directory (createDirectoryIfMissing)-import System.FilePath.Posix ((<.>), (</>)) -import Clash.Annotations.Primitive- -- GHC API+import Annotations (Annotation(..), getAnnTargetName_maybe) import qualified Annotations-import qualified BasicTypes import qualified Class import qualified CoreFVs import qualified CoreSyn@@ -45,40 +44,33 @@ import qualified LoadIface import qualified Maybes import qualified MkCore-#if MIN_VERSION_ghc(8,2,0) import qualified Module-#endif import qualified MonadUtils import qualified Name import Outputable (showPpr, showSDoc, text)-#if MIN_VERSION_ghc(8,4,1)-import qualified GhcPlugins-#else-import qualified Serialized-#endif+import qualified GhcPlugins (deserializeWithData, fromSerialized) import qualified TcIface import qualified TcRnMonad import qualified TcRnTypes import qualified UniqFM import qualified UniqSet import qualified Var-#if !MIN_VERSION_ghc(8,2,0)-import qualified VarSet-#endif -- Internal Modules-import Clash.Util (curLoc, traceIf, (***))+import Clash.Annotations.BitRepresentation.Internal+ (DataRepr', dataReprAnnToDataRepr')+import Clash.Annotations.Primitive+import Clash.Annotations.BitRepresentation (DataReprAnn)+import Clash.Primitives.Types (UnresolvedPrimitive, name)+import Clash.Primitives.Util (decodeOrErr)+import Clash.GHC.GHC2Core (qualifiedNameString')+import Clash.Util (curLoc, traceIf) runIfl :: GHC.GhcMonad m => GHC.Module -> TcRnTypes.IfL a -> m a runIfl modName action = do hscEnv <- GHC.getSession-#if MIN_VERSION_ghc(8,2,0) let localEnv = TcRnTypes.IfLclEnv modName False (text "runIfl") Nothing Nothing UniqFM.emptyUFM UniqFM.emptyUFM-#else- let localEnv = TcRnTypes.IfLclEnv modName (text "runIfl")- UniqFM.emptyUFM UniqFM.emptyUFM-#endif let globalEnv = TcRnTypes.IfGblEnv (text "Clash.runIfl") Nothing MonadUtils.liftIO $ TcRnMonad.initTcRnIf 'r' hscEnv globalEnv localEnv action@@ -88,12 +80,8 @@ loadIface :: GHC.Module -> TcRnTypes.IfL (Maybe GHC.ModIface) loadIface foundMod = do-#if MIN_VERSION_ghc(8,2,0) ifaceFailM <- LoadIface.findAndReadIface (Outputable.text "loadIface") (fst (Module.splitModuleInsts foundMod)) foundMod False-#else- ifaceFailM <- LoadIface.findAndReadIface (Outputable.text "loadIface") foundMod False-#endif case ifaceFailM of Maybes.Succeeded (modInfo,_) -> return (Just modInfo) Maybes.Failed msg -> let msg' = concat [ $(curLoc)@@ -104,35 +92,36 @@ ] in traceIf True msg' (return Nothing) -loadExternalExprs ::- GHC.GhcMonad m+loadExternalExprs+ :: GHC.GhcMonad m => HDL -> UniqSet.UniqSet CoreSyn.CoreBndr -> [CoreSyn.CoreBind] -> m ( [(CoreSyn.CoreBndr,CoreSyn.CoreExpr)] -- Binders , [(CoreSyn.CoreBndr,Int)] -- Class Ops , [CoreSyn.CoreBndr] -- Unlocatable- , [FilePath]+ , [Either UnresolvedPrimitive FilePath]+ , [DataRepr'] )-loadExternalExprs hdl = go [] [] [] []+loadExternalExprs hdl = go [] [] [] [] [] where- go locatedExprs clsOps unlocated pFP _ [] =- return (locatedExprs,clsOps,unlocated,pFP)+ go locatedExprs clsOps unlocated pFP reprs _ [] =+ return (locatedExprs,clsOps,unlocated,pFP,reprs) - go locatedExprs clsOps unlocated pFP visited (CoreSyn.NonRec _ e:bs) = do- (locatedExprs',clsOps',unlocated',pFP',visited') <-- go' locatedExprs clsOps unlocated pFP visited [e]- go locatedExprs' clsOps' unlocated' pFP' visited' bs+ go locatedExprs clsOps unlocated pFP reprs visited (CoreSyn.NonRec _ e:bs) = do+ (locatedExprs',clsOps',unlocated',pFP',reprs',visited') <-+ go' locatedExprs clsOps unlocated pFP reprs visited [e]+ go locatedExprs' clsOps' unlocated' pFP' reprs' visited' bs - go locatedExprs clsOps unlocated pFP visited (CoreSyn.Rec bs:bs') = do- (locatedExprs',clsOps',unlocated',pFP',visited') <-- go' locatedExprs clsOps unlocated pFP visited (map snd bs)- go locatedExprs' clsOps' unlocated' pFP' visited' bs'+ go locatedExprs clsOps unlocated pFP reprs visited (CoreSyn.Rec bs:bs') = do+ (locatedExprs',clsOps',unlocated',pFP',reprs',visited') <-+ go' locatedExprs clsOps unlocated pFP reprs visited (map snd bs)+ go locatedExprs' clsOps' unlocated' pFP' reprs' visited' bs' - go' locatedExprs clsOps unlocated pFP visited [] =- return (locatedExprs,clsOps,unlocated,pFP,visited)+ go' locatedExprs clsOps unlocated pFP reprs visited [] =+ return (locatedExprs,clsOps,unlocated,pFP,reprs,visited) - go' locatedExprs clsOps unlocated pFP visited (e:es) = do+ go' locatedExprs clsOps unlocated pFP reprs visited (e:es) = do let fvs = CoreFVs.exprSomeFreeVarsList (\v -> Var.isId v && isNothing (Id.isDataConId_maybe v) &&@@ -149,8 +138,8 @@ (elemIndex v clsIds) ) clsOps' - ((locatedExprs',unlocated'),pFP') <-- ((partitionEithers *** concat) . unzip) <$> mapM (loadExprFromIface hdl) fvs'+ (locatedAndUnlocated, pFP', reprs') <- unzip3 <$> mapM (loadExprFromIface hdl) fvs'+ let (locatedExprs', unlocated') = partitionEithers locatedAndUnlocated let visited' = foldl' UniqSet.addListToUniqSet visited [ map fst locatedExprs'@@ -161,7 +150,8 @@ go' (locatedExprs'++locatedExprs) (clsOps''++clsOps) (unlocated'++unlocated)- (pFP'++pFP)+ (concat pFP'++pFP)+ (concat reprs'++reprs) visited' (es ++ map snd locatedExprs') @@ -170,101 +160,128 @@ => HDL -> CoreSyn.CoreBndr -> m (Either- (CoreSyn.CoreBndr,CoreSyn.CoreExpr)- CoreSyn.CoreBndr- ,[FilePath]+ (CoreSyn.CoreBndr,CoreSyn.CoreExpr) -- Located+ CoreSyn.CoreBndr -- Unlocated+ ,[Either UnresolvedPrimitive FilePath]+ ,[DataRepr'] ) loadExprFromIface hdl bndr = do- dflags <- GHC.getSessionDynFlags-- let -- Using the stub directory as the output directory for inline primitives- outDir = fromMaybe "." $ GHC.stubDir dflags- moduleM = Name.nameModule_maybe $ Var.varName bndr+ let moduleM = Name.nameModule_maybe $ Var.varName bndr case moduleM of Just nameMod -> runIfl nameMod $ do ifaceM <- loadIface nameMod case ifaceM of- Nothing -> return (Right bndr,[])+ Nothing -> return (Right bndr,[],[]) Just iface -> do let decls = map snd (GHC.mi_decls iface) let nameFun = GHC.getOccName $ Var.varName bndr-#if MIN_VERSION_ghc(8,2,0) let declM = filter ((== nameFun) . Name.nameOccName . IfaceSyn.ifName) decls-#else- let declM = filter ((== nameFun) . IfaceSyn.ifName) decls-#endif anns <- TcIface.tcIfaceAnnotations (GHC.mi_anns iface)- primFPs <- loadPrimitiveAnnotations hdl outDir anns+ primFPs <- loadPrimitiveAnnotations hdl anns+ let reprs = loadCustomReprAnnotations anns case declM of [namedDecl] -> do tyThing <- loadDecl namedDecl- return (loadExprFromTyThing bndr tyThing,primFPs)- _ -> return (Right bndr,primFPs)- Nothing -> return (Right bndr,[])+ return (loadExprFromTyThing bndr tyThing,primFPs,reprs)+ _ -> return (Right bndr,primFPs,reprs)+ Nothing -> return (Right bndr,[],[]) ++loadCustomReprAnnotations+ :: [Annotations.Annotation]+ -> [DataRepr']+loadCustomReprAnnotations anns =+ catMaybes $ map go $ catMaybes $ zipWith filterNameless anns reprs+ where+ env = Annotations.mkAnnEnv anns+ deserialize = GhcPlugins.deserializeWithData :: [Word8] -> DataReprAnn+ reprs = UniqFM.eltsUFM (Annotations.deserializeAnns deserialize env)++ filterNameless+ :: Annotation+ -> [DataReprAnn]+ -> Maybe (Name.Name, [DataReprAnn])+ filterNameless (Annotation ann_target _) reprs' =+ (,reprs') <$> getAnnTargetName_maybe ann_target++ go+ :: (Name.Name, [DataReprAnn])+ -> Maybe DataRepr'+ go (_name, []) = Nothing+ go (_name, [repr]) = Just $ dataReprAnnToDataRepr' repr+ go (name, reprs') =+ error $ $(curLoc) ++ "Multiple DataReprAnn annotations for same type: \n\n"+ ++ (Outputable.showPpr DynFlags.unsafeGlobalDynFlags name)+ ++ "\n\nReprs:\n\n"+ ++ show reprs'+ loadPrimitiveAnnotations :: MonadIO m => HDL- -> FilePath -> [Annotations.Annotation]- -> m [FilePath]-loadPrimitiveAnnotations hdl outDir anns =- sequence $ mapMaybe (primitiveFilePath hdl outDir) prims+ -> m [Either UnresolvedPrimitive FilePath]+loadPrimitiveAnnotations hdl anns =+ concat <$> mapM (unresolvedPrimitives hdl) prims where prims = mapMaybe filterPrim anns filterPrim (Annotations.Annotation target value) = (target,) <$> deserialize value-#if MIN_VERSION_ghc(8,4,1) deserialize = GhcPlugins.fromSerialized (GhcPlugins.deserializeWithData :: [Word8] -> Primitive)-#else- deserialize =- Serialized.fromSerialized- (Serialized.deserializeWithData :: [Word8] -> Primitive)-#endif -primitiveFilePath ::- MonadIO m+unresolvedPrimitives+ :: MonadIO m => HDL- -> FilePath -> (Annotations.CoreAnnTarget, Primitive)- -> Maybe (m FilePath)-primitiveFilePath hdl outDir targetPrim =+ -> m ([Either UnresolvedPrimitive FilePath])+unresolvedPrimitives hdl targetPrim = case targetPrim of- (_, Primitive hdl' fp)- | hdl == hdl' -> Just $ pure fp- (target, InlinePrimitive hdl' content)- | hdl == hdl' -> Just . liftIO $ do- let qualifiedName =- case target of- Annotations.NamedTarget name -> Name.nameStableString name- Annotations.ModuleTarget mod' -> Module.moduleStableString mod'- inlinePrimsDir =- outDir </> "inline_primitives" </> map toLower (show hdl)- primFile = inlinePrimsDir </> qualifiedName <.> "json"- createDirectoryIfMissing True inlinePrimsDir- writeFile primFile content- return inlinePrimsDir- _ -> Nothing+ (_, Primitive hdl' fp) | hdl == hdl' -> pure [Right fp] -loadExprFromTyThing :: CoreSyn.CoreBndr- -> GHC.TyThing- -> Either- (CoreSyn.CoreBndr,CoreSyn.CoreExpr) -- Located Binder- CoreSyn.CoreBndr -- unlocatable Var+ (target, InlinePrimitive hdl' contentOrFp) | hdl == hdl' ->+ case target of+ -- Module annotation, can house many primitives+ Annotations.ModuleTarget _ ->+ liftIO (decodeOrErr contentOrFp <$> BL.readFile contentOrFp)+ Annotations.NamedTarget targetName0 ->+ let targetName1 = Text.unpack (qualifiedNameString' targetName0)+ prim =+ case decodeOrErr targetName1 (BLU.fromString contentOrFp) of+ [] -> error $ "No annotations found for " ++ targetName1+ ++ " even though it had an InlinePrimitive annotation."+ [p] -> p+ _ -> error $ "Multiple primitive definitions found in "+ ++ "InlinePrimitive annotation for " ++ targetName1 ++ ". "+ ++ "Expected a single one."++ primName = Text.unpack (name prim) in++ if primName /= targetName1 then+ error $ concat+ [ "Function " ++ targetName1 ++ " was annotated with an inline "+ , "primitive for " ++ primName ++ ". These names "+ , "should be the same." ]+ else+ pure [Left prim]+ _ ->+ -- Only consider the HDL (Verilog/SystemVerilog/VHDL) annotation we're+ -- currently targeting.+ pure []++loadExprFromTyThing+ :: CoreSyn.CoreBndr+ -> GHC.TyThing+ -> Either+ (CoreSyn.CoreBndr,CoreSyn.CoreExpr) -- Located Binder+ CoreSyn.CoreBndr -- unlocatable Var loadExprFromTyThing bndr tyThing = case tyThing of GHC.AnId _id | Var.isId _id -> let _idInfo = Var.idInfo _id unfolding = IdInfo.unfoldingInfo _idInfo- inlineInfo = IdInfo.inlinePragInfo _idInfo in case unfolding of CoreSyn.CoreUnfolding {} ->- case (BasicTypes.inl_inline inlineInfo,BasicTypes.inl_act inlineInfo) of- (BasicTypes.NoInline,BasicTypes.AlwaysActive) -> Right bndr- (BasicTypes.NoInline,BasicTypes.NeverActive) -> Right bndr- (BasicTypes.NoInline,_) -> Left (bndr, CoreSyn.unfoldingTemplate unfolding)- _ -> Left (bndr, CoreSyn.unfoldingTemplate unfolding)+ Left (bndr, CoreSyn.unfoldingTemplate unfolding) (CoreSyn.DFunUnfolding dfbndrs dc es) -> let dcApp = MkCore.mkCoreConApps dc es dfExpr = MkCore.mkCoreLams dfbndrs dcApp
src-ghc/Clash/GHC/LoadModules.hs view
@@ -16,33 +16,56 @@ module Clash.GHC.LoadModules ( loadModules , ghcLibDir+ , wantedLanguageExtensions ) where +#ifndef USE_GHC_PATHS #ifndef TOOL_VERSION_ghc #error TOOL_VERSION_ghc undefined #endif+#endif -- External Modules-import Clash.Annotations.Primitive (HDL, Primitive (..))+import Clash.Annotations.Primitive (HDL, PrimitiveGuard) import Clash.Annotations.TopEntity (TopEntity (..))-import Control.Arrow (second)+import Clash.Primitives.Types (UnresolvedPrimitive)+import Clash.Util (ClashException(..), pkgIdFromTypeable)+import Control.Arrow (first, second)+import Control.DeepSeq (deepseq)+import Control.Exception (throw)+#if MIN_VERSION_ghc(8,6,0)+import Control.Exception (throwIO)+#endif+import Control.Monad.IO.Class (liftIO)+import Data.Char (isDigit) import Data.Generics.Uniplate.DataOnly (transform)-import Data.List (foldl', lookup, nub)-import Data.Maybe (catMaybes, fromMaybe,- listToMaybe, mapMaybe)-import Data.Word (Word8)+import Data.Data (Data)+import Data.Typeable (Typeable)+import Data.List (foldl', nub)+import Data.Maybe (catMaybes, listToMaybe)+import qualified Data.Text as Text+import qualified Data.Time.Clock as Clock+import Language.Haskell.TH.Syntax (lift)++#ifdef USE_GHC_PATHS+import GHC.Paths (libdir)+#else import System.Exit (ExitCode (..)) import System.IO (hGetLine) import System.IO.Error (tryIOError) import System.Process (runInteractiveCommand, waitForProcess)+#endif -- GHC API import qualified Annotations import qualified CoreFVs import qualified CoreSyn import qualified Digraph+#if MIN_VERSION_ghc(8,6,0)+import qualified DynamicLoading+#endif import DynFlags (GeneralFlag (..)) import qualified DynFlags import qualified GHC@@ -50,20 +73,12 @@ import qualified HscTypes import qualified MonadUtils import qualified Panic-#if MIN_VERSION_ghc(8,4,1)-import qualified GhcPlugins-#else-import qualified Serialized-#endif+import qualified GhcPlugins (deserializeWithData, installedUnitIdString) import qualified TcRnMonad import qualified TcRnTypes import qualified TidyPgm import qualified Unique-#if MIN_VERSION_ghc(8,2,0)-import qualified UniqDFM-#else import qualified UniqFM-#endif import qualified FamInst import qualified FamInstEnv import qualified GHC.LanguageExtensions as LangExt@@ -72,14 +87,21 @@ import Outputable (ppr) import qualified Outputable import qualified UniqSet+import Util (OverridingBool) import qualified Var -- Internal Modules-import Clash.GHC.GHC2Core (modNameM)-import Clash.GHC.LoadInterfaceFiles-import Clash.Util (curLoc)+import Clash.GHC.GHC2Core (modNameM, qualifiedNameString')+import Clash.GHC.LoadInterfaceFiles (loadExternalExprs, unresolvedPrimitives)+import Clash.GHCi.Common (checkMonoLocalBindsMod)+import Clash.Util (curLoc, noSrcSpan, reportTimeDiff)+import Clash.Annotations.BitRepresentation.Internal+ (DataRepr', dataReprAnnToDataRepr') ghcLibDir :: IO FilePath+#ifdef USE_GHC_PATHS+ghcLibDir = return libdir+#else ghcLibDir = do (libDirM,exitCode) <- getProcessOutput $ "ghc-" ++ TOOL_VERSION_ghc ++ " --print-libdir" case exitCode of@@ -103,11 +125,19 @@ output <- either (const Nothing) Just <$> tryIOError (hGetLine pOut) -- return both the output and the exit code. return (output, exitCode)+#endif loadModules- :: HDL+ :: OverridingBool+ -- ^ Use color+ -> HDL+ -- ^ HDL target -> String+ -- ^ Module name -> Maybe (DynFlags.DynFlags)+ -- ^ Flags to run GHC with+ -> [FilePath]+ -- ^ Import dirs to use when no DynFlags are provided -> IO ( [CoreSyn.CoreBind] -- Binders , [(CoreSyn.CoreBndr,Int)] -- Class operations , [CoreSyn.CoreBndr] -- Unlocatable Expressions@@ -115,46 +145,35 @@ , [( CoreSyn.CoreBndr -- topEntity bndr , Maybe TopEntity -- (maybe) TopEntity annotation , Maybe CoreSyn.CoreBndr)] -- (maybe) testBench bndr- , [FilePath]+ , [Either UnresolvedPrimitive FilePath]+ , [DataRepr']+ , [(Text.Text, PrimitiveGuard ())] )-loadModules hdl modName dflagsM = do+loadModules useColor hdl modName dflagsM idirs = do libDir <- MonadUtils.liftIO ghcLibDir-+ startTime <- Clock.getCurrentTime GHC.runGhc (Just libDir) $ do dflags <- case dflagsM of Just df -> return df Nothing -> do+#if MIN_VERSION_ghc(8,6,0)+ -- Make sure we read the .ghc environment files+ df <- do { df <- GHC.getSessionDynFlags+ ; _ <- GHC.setSessionDynFlags df {DynFlags.pkgDatabase = Nothing}+ ; GHC.getSessionDynFlags+ }+#else df <- GHC.getSessionDynFlags- let dfEn = foldl DynFlags.xopt_set df- [ LangExt.TemplateHaskell- , LangExt.TemplateHaskellQuotes- , LangExt.DataKinds- , LangExt.MonoLocalBinds- , LangExt.TypeOperators- , LangExt.FlexibleContexts- , LangExt.ConstraintKinds- , LangExt.TypeFamilies- , LangExt.BinaryLiterals- , LangExt.ExplicitNamespaces- , LangExt.KindSignatures- , LangExt.DeriveLift- , LangExt.TypeApplications- , LangExt.ScopedTypeVariables- , LangExt.MagicHash- , LangExt.ExplicitForAll- ]- let dfDis = foldl DynFlags.xopt_unset dfEn- [ LangExt.ImplicitPrelude- , LangExt.MonomorphismRestriction- , LangExt.Strict- , LangExt.StrictData- ]+#endif+ let df1 = wantedLanguageExtensions df let ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise" ghcTyLitExtrPlugin = GHC.mkModuleName "GHC.TypeLits.Extra.Solver" ghcTyLitKNPlugin = GHC.mkModuleName "GHC.TypeLits.KnownNat.Solver"- let dfPlug = dfDis { DynFlags.pluginModNames = nub $+ let dfPlug = df1 { DynFlags.pluginModNames = nub $ ghcTyLitNormPlugin : ghcTyLitExtrPlugin :- ghcTyLitKNPlugin : DynFlags.pluginModNames dfDis+ ghcTyLitKNPlugin : DynFlags.pluginModNames df1+ , DynFlags.useColor = useColor+ , DynFlags.importPaths = idirs } return dfPlug @@ -162,13 +181,12 @@ { DynFlags.optLevel = 2 , DynFlags.ghcMode = GHC.CompManager , DynFlags.ghcLink = GHC.LinkInMemory- , DynFlags.hscTarget = DynFlags.defaultObjectTarget- (DynFlags.targetPlatform dflags)-#if __GLASGOW_HASKELL__ >= 711+ , DynFlags.hscTarget+ = if DynFlags.rtsIsProfiled+ then DynFlags.HscNothing+ else DynFlags.defaultObjectTarget+ (DynFlags.targetPlatform dflags) , DynFlags.reductionDepth = 1000-#else- , DynFlags.ctxtStkDepth = 1000-#endif } let dflags2 = wantedOptimizationFlags dflags1 let ghcDynamic = case lookup "GHC Dynamic" (DynFlags.compilerInfo dflags) of@@ -176,7 +194,13 @@ _ -> False let dflags3 = if ghcDynamic then DynFlags.gopt_set dflags2 DynFlags.Opt_BuildDynamicToo else dflags2+#if MIN_VERSION_ghc(8,6,0)+ hscenv <- GHC.getSession+ dflags4 <- MonadUtils.liftIO (DynamicLoading.initializePlugins hscenv dflags3)+ _ <- GHC.setSessionDynFlags dflags4+#else _ <- GHC.setSessionDynFlags dflags3+#endif target <- GHC.guessTarget modName Nothing GHC.setTargets [target] modGraph <- GHC.depanal [] False@@ -214,6 +238,7 @@ #else ; simpl_guts <- MonadUtils.liftIO $ HscMain.hscSimplify hsc_env dsMod #endif+ ; checkForInvalidPrelude simpl_guts ; (tidy_guts,_) <- MonadUtils.liftIO $ TidyPgm.tidyProgram hsc_env simpl_guts ; let pgm = HscTypes.cg_binds tidy_guts ; let modFamInstEnv = TcRnTypes.tcg_fam_inst_env $ fst $ GHC.tm_internals_ tcMod@@ -224,20 +249,36 @@ let (binders,modFamInstEnvs) = unzip tidiedMods bindersC = concat binders binderIds = map fst (CoreSyn.flattenBinds bindersC)-#if MIN_VERSION_ghc(8,2,0)- modFamInstEnvs' = foldr UniqDFM.plusUDFM UniqDFM.emptyUDFM modFamInstEnvs-#else- modFamInstEnvs' = foldr UniqFM.plusUFM UniqFM.emptyUFM modFamInstEnvs-#endif+ plusFamInst f1 f2 = FamInstEnv.extendFamInstEnvList f1 (FamInstEnv.famInstEnvElts f2)+ modFamInstEnvs' = foldl' plusFamInst FamInstEnv.emptyFamInstEnv modFamInstEnvs - (externalBndrs,clsOps,unlocatable,pFP) <-+ modTime <- startTime `deepseq` length binderIds `deepseq` MonadUtils.liftIO Clock.getCurrentTime+ let modStartDiff = reportTimeDiff modTime startTime+ MonadUtils.liftIO $ putStrLn $ "GHC: Parsing and optimising modules took: " ++ modStartDiff++ (externalBndrs,clsOps,unlocatable,unresolvedPrimitives0,reprs) <- loadExternalExprs hdl (UniqSet.mkUniqSet binderIds) bindersC + let externalBndrIds = map fst externalBndrs+ let allBinderIds = externalBndrIds ++ binderIds++ extTime <- modTime `deepseq` length unlocatable `deepseq` MonadUtils.liftIO Clock.getCurrentTime+ let extModDiff = reportTimeDiff extTime modTime+ MonadUtils.liftIO $ putStrLn $ "GHC: Loading external modules from interface files took: " ++ extModDiff+ -- Find local primitive annotations- pFP' <- findPrimitiveAnnotations hdl binderIds+ unresolvedPrimitives1 <- findPrimitiveAnnotations hdl binderIds hscEnv <- GHC.getSession+#if MIN_VERSION_ghc(8,6,0)+ famInstEnvs <- do { (msgs,m) <- TcRnMonad.liftIO $ TcRnMonad.initTcInteractive hscEnv FamInst.tcGetFamInstEnvs+ ; case m of+ Nothing -> TcRnMonad.liftIO $ throwIO (HscTypes.mkSrcErr (snd msgs))+ Just x -> return x+ }+#else famInstEnvs <- TcRnMonad.liftIO $ TcRnMonad.initTcForLookup hscEnv FamInst.tcGetFamInstEnvs+#endif -- Because tidiedMods is in topological order, binders is also, and hence -- the binders belonging to the "root" module are the last binders@@ -247,28 +288,62 @@ -- Because tidiedMods is in topological order, binders is also, and hence -- allSyn is in topological order. This means that the "root" 'topEntity' -- will be compiled last.- allSyn <- findSynthesizeAnnotations binderIds- benchAnn <- findTestBenchAnnotations binderIds- topSyn <- findSynthesizeAnnotations rootIds+ allSyn <- map (second Just) <$> findSynthesizeAnnotations binderIds+ topSyn <- map (second Just) <$> findSynthesizeAnnotations rootIds+ benchAnn <- findTestBenchAnnotations binderIds+ reprs' <- findCustomReprAnnotations+ primGuards <- findPrimitiveGuardAnnotations allBinderIds let varNameString = OccName.occNameString . Name.nameOccName . Var.varName topEntities = filter ((== "topEntity") . varNameString) rootIds benches = filter ((== "testBench") . varNameString) rootIds mergeBench (x,y) = (x,y,lookup x benchAnn) allSyn' = map mergeBench allSyn- topEntities' <- case topEntities of- [] -> case topSyn of- [] -> Panic.pgmError $ "No 'topEntity', nor function with a 'Synthesize' annotation found in root module: " ++- (Outputable.showSDocUnsafe (ppr rootModule))- _ -> return allSyn'- [x] -> case lookup x topSyn of- Nothing -> case lookup x benchAnn of- Nothing -> return ((x,Nothing,listToMaybe benches):allSyn')- Just y -> return ((x,Nothing,Just y):allSyn')- Just _ -> return allSyn'- _ -> Panic.pgmError $ $(curLoc) ++ "Multiple 'topEntities' found." - return (bindersC ++ makeRecursiveGroups externalBndrs,clsOps,unlocatable,(fst famInstEnvs,modFamInstEnvs'),topEntities',nub $ pFP ++ pFP')+ topEntities' <-+ case (topEntities, topSyn) of+ ([], []) ->+ Panic.pgmError $ unwords [ "No 'topEntity', nor function with a"+ , "'Synthesize' annotation found in root"+ , "module:"+ , (Outputable.showSDocUnsafe (ppr rootModule)) ]+ ([], _) ->+ return allSyn'+ ([x], _) ->+ case lookup x topSyn of+ Nothing ->+ case lookup x benchAnn of+ Nothing -> return ((x,Nothing,listToMaybe benches):allSyn')+ Just y -> return ((x,Nothing,Just y):allSyn')+ Just _ ->+ return allSyn'+ (_, _) ->+ Panic.pgmError $ $(curLoc) ++ "Multiple 'topEntities' found." + let unresolvedPrimitives2 = unresolvedPrimitives0 ++ unresolvedPrimitives1+ reprs1 = reprs ++ reprs'++ annTime <-+ extTime+ `deepseq` length topEntities'+ `deepseq` unresolvedPrimitives2+ `deepseq` reprs1+ `deepseq` primGuards+ `deepseq` MonadUtils.liftIO Clock.getCurrentTime++ let annExtDiff = reportTimeDiff annTime extTime+ MonadUtils.liftIO $ putStrLn $ "GHC: Parsing annotations took: " ++ annExtDiff+ MonadUtils.liftIO $ mapM_ checkMonoLocalBindsMod modGraph2++ return ( bindersC ++ makeRecursiveGroups externalBndrs+ , clsOps+ , unlocatable+ , (fst famInstEnvs, modFamInstEnvs')+ , topEntities'+ , unresolvedPrimitives2+ , reprs1+ , primGuards+ )+ -- | Given a set of bindings, make explicit non-recursive bindings and -- recursive binding groups. --@@ -307,53 +382,105 @@ makeBind (Digraph.AcyclicSCC (b,e)) = CoreSyn.NonRec b e makeBind (Digraph.CyclicSCC bs) = CoreSyn.Rec bs +errOnDuplicateAnnotations+ :: String+ -- ^ Name of annotation+ -> [CoreSyn.CoreBndr]+ -- ^ Binders searched for+ -> [[a]]+ -- ^ Parsed annotations+ -> [(CoreSyn.CoreBndr, a)]+errOnDuplicateAnnotations nm bndrs anns =+ go (zip bndrs anns)+ where+ go+ :: [(CoreSyn.CoreBndr, [a])]+ -> [(CoreSyn.CoreBndr, a)]+ go [] = []+ go ((_, []):ps) = go ps+ go ((b, [p]):ps) = (b, p) : (go ps)+ go ((b, _):_) =+ Panic.pgmError $ "The following value has multiple "+ ++ "'" ++ nm ++ "' annotations: "+ ++ Outputable.showSDocUnsafe (ppr b)++-- | Find annotations by given targets+findAnnotationsByTargets+ :: GHC.GhcMonad m+ => Typeable a+ => Data a+ => [Annotations.AnnTarget Name.Name]+ -> m [[a]]+findAnnotationsByTargets targets =+ mapM (GHC.findGlobalAnns GhcPlugins.deserializeWithData) targets++-- | Find all annotations of a certain type in all modules seen so far.+findAllModuleAnnotations+ :: GHC.GhcMonad m+ => Data a+ => Typeable a+ => m [a]+findAllModuleAnnotations = do+ hsc_env <- GHC.getSession+ ann_env <- liftIO $ HscTypes.prepareAnnotations hsc_env Nothing+ return $ concat+ $ UniqFM.nonDetEltsUFM+ $ Annotations.deserializeAnns GhcPlugins.deserializeWithData ann_env++-- | Find all annotations belonging to all binders seen so far.+findNamedAnnotations+ :: GHC.GhcMonad m+ => Data a+ => Typeable a+ => [CoreSyn.CoreBndr]+ -> m [[a]]+findNamedAnnotations bndrs =+ findAnnotationsByTargets (map (Annotations.NamedTarget . Var.varName) bndrs)++findPrimitiveGuardAnnotations+ :: GHC.GhcMonad m+ => [CoreSyn.CoreBndr]+ -> m [(Text.Text, (PrimitiveGuard ()))]+findPrimitiveGuardAnnotations bndrs = do+ anns0 <- findNamedAnnotations bndrs+ let anns1 = errOnDuplicateAnnotations "PrimitiveGuard" bndrs anns0+ pure (map (first (qualifiedNameString' . Var.varName)) anns1)++-- | Find annotations of type @DataReprAnn@ and convert them to @DataRepr'@+findCustomReprAnnotations+ :: GHC.GhcMonad m+ => m [DataRepr']+findCustomReprAnnotations =+ map dataReprAnnToDataRepr' <$> findAllModuleAnnotations++-- | Find synthesize annotations and make sure each binder has no more than+-- a single annotation. findSynthesizeAnnotations :: GHC.GhcMonad m => [CoreSyn.CoreBndr]- -> m [(CoreSyn.CoreBndr,Maybe TopEntity)]+ -> m [(CoreSyn.CoreBndr, TopEntity)] findSynthesizeAnnotations bndrs = do-#if MIN_VERSION_ghc(8,4,1)- let deserializer = GhcPlugins.deserializeWithData :: ([Word8] -> TopEntity)-#else- let deserializer = Serialized.deserializeWithData :: ([Word8] -> TopEntity)-#endif- targets = map (Annotations.NamedTarget . Var.varName) bndrs-- anns <- mapM (GHC.findGlobalAnns deserializer) targets- let isSyn (Synthesize {}) = True- isSyn _ = False- anns' = map (filter isSyn) anns- annBndrs = filter (not . null . snd) (zip bndrs anns')- case filter ((> 1) . length . snd) annBndrs of- [] -> return (map (second listToMaybe) annBndrs)- as -> Panic.pgmError $- "The following functions have multiple 'Synthesize' annotations: " ++- Outputable.showSDocUnsafe (ppr (map fst as))+ anns <- findNamedAnnotations bndrs+ pure (errOnDuplicateAnnotations "Synthesize" bndrs (map (filter isSyn) anns))+ where+ isSyn (Synthesize {}) = True+ isSyn _ = False +-- | Find testbench annotations and make sure that each binder has no more than+-- a single annotation. findTestBenchAnnotations :: GHC.GhcMonad m => [CoreSyn.CoreBndr] -> m [(CoreSyn.CoreBndr,CoreSyn.CoreBndr)] findTestBenchAnnotations bndrs = do-#if MIN_VERSION_ghc(8,4,1)- let deserializer = GhcPlugins.deserializeWithData :: ([Word8] -> TopEntity)-#else- let deserializer = Serialized.deserializeWithData :: ([Word8] -> TopEntity)-#endif- targets = map (Annotations.NamedTarget . Var.varName) bndrs-- anns <- mapM (GHC.findGlobalAnns deserializer) targets- let isTB (TestBench {}) = True- isTB _ = False- anns' = map (filter isTB) anns- annBndrs = filter (not . null . snd) (zip bndrs anns')- annBndrs' = case filter ((> 1) . length . snd) annBndrs of- [] -> map (second head) annBndrs- as -> Panic.pgmError $- "The following functions have multiple 'TestBench' annotations: " ++- Outputable.showSDocUnsafe (ppr (map fst as))- return (map (second findTB) annBndrs')+ anns0 <- findNamedAnnotations bndrs+ let anns1 = map (filter isTB) anns0+ anns2 = errOnDuplicateAnnotations "TestBench" bndrs anns1+ return (map (second findTB) anns2) where+ isTB (TestBench {}) = True+ isTB _ = False+ findTB :: TopEntity -> CoreSyn.CoreBndr findTB (TestBench tb) = case listToMaybe (filter (eqNm tb) bndrs) of Just tb' -> tb'@@ -361,38 +488,35 @@ "TestBench named: " ++ show tb ++ " not found" findTB _ = Panic.pgmError "Unexpected Synthesize" - eqNm thNm bndr = show thNm == qualNm+ eqNm thNm bndr = Text.pack (show thNm) == qualNm where bndrNm = Var.varName bndr- qualNm = maybe occName (\modName -> modName ++ ('.':occName)) (modNameM bndrNm)- occName = OccName.occNameString (Name.nameOccName bndrNm)+ qualNm = maybe occName (\modName -> modName `Text.append` ('.' `Text.cons` occName)) (modNameM bndrNm)+ occName = Text.pack (OccName.occNameString (Name.nameOccName bndrNm)) +-- | Find primitive annotations bound to given binders, or annotations made+-- in modules of those binders. findPrimitiveAnnotations :: GHC.GhcMonad m => HDL -> [CoreSyn.CoreBndr]- -> m [FilePath]+ -> m [Either UnresolvedPrimitive FilePath] findPrimitiveAnnotations hdl bndrs = do- dflags <- GHC.getSessionDynFlags+ let+ annTargets =+ map+ (fmap Annotations.ModuleTarget . Name.nameModule_maybe)+ (map Var.varName bndrs) - let -- Using the stub directory as the output directory for inline primitives- outDir = fromMaybe "." $ GHC.stubDir dflags-#if MIN_VERSION_ghc(8,4,1)- deserializer = GhcPlugins.deserializeWithData :: ([Word8] -> Primitive)-#else- deserializer = Serialized.deserializeWithData :: ([Word8] -> Primitive)-#endif- targets =- concatMap- ( (\v -> catMaybes- [ Just $ Annotations.NamedTarget v- , Annotations.ModuleTarget <$> Name.nameModule_maybe v- ]) . Var.varName- ) bndrs+ let+ targets =+ (catMaybes annTargets) +++ (map (Annotations.NamedTarget . Var.varName) bndrs) - anns <- mapM (GHC.findGlobalAnns deserializer) targets- sequence $- mapMaybe (primitiveFilePath hdl outDir)+ anns <- findAnnotationsByTargets targets++ concat <$>+ mapM (unresolvedPrimitives hdl) (concat $ zipWith (\t -> map ((,) t)) targets anns) parseModule :: GHC.GhcMonad m => GHC.ModSummary -> m GHC.ParsedModule@@ -409,11 +533,7 @@ where dflags = wantedOptimizationFlags (ms_hspp_opts { DynFlags.optLevel = 2-#if __GLASGOW_HASKELL__ >= 711 , DynFlags.reductionDepth = 1000-#else- , DynFlags.ctxtStkDepth = 1000-#endif }) wantedOptimizationFlags :: GHC.DynFlags -> GHC.DynFlags@@ -446,8 +566,10 @@ , Opt_DoEtaReduction -- We want eta-expansion , Opt_UnboxStrictFields -- Unboxed types are not handled properly: avoid , Opt_UnboxSmallStrictFields -- Unboxed types are not handled properly: avoid+#if !MIN_VERSION_ghc(8,6,0) , Opt_Vectorise -- Don't care , Opt_VectorisationAvoidance -- Don't care+#endif , Opt_RegsGraph -- Don't care , Opt_RegsGraph -- Don't care , Opt_PedanticBottoms -- Stops eta-expansion through case: avoid@@ -464,7 +586,7 @@ ] -- Coercions between Integer and Clash' numeric primitives cause Clash to- -- fail. As strictness only affects simulation behaviour, removing them+ -- fail. As strictness only affects simulation behavior, removing them -- is perfectly safe. unwantedLang = [ LangExt.Strict , LangExt.StrictData@@ -494,6 +616,47 @@ -- recursive functions involved, and hence we need to disable this useful transformation. After -- everything is done properly, we should enable it again. ++wantedLanguageExtensions :: GHC.DynFlags -> GHC.DynFlags+wantedLanguageExtensions df =+ foldl' DynFlags.xopt_unset+ (foldl' DynFlags.xopt_set df wanted) unwanted+ where+ -- Also update @Test.Tasty.Clash.outputTest'@ when updating this list!+ wanted = [ LangExt.BinaryLiterals+ , LangExt.ConstraintKinds+ , LangExt.DataKinds+ , LangExt.DeriveAnyClass+ , LangExt.DeriveGeneric+ , LangExt.DeriveLift+ , LangExt.DerivingStrategies+ , LangExt.ExplicitForAll+ , LangExt.ExplicitNamespaces+ , LangExt.FlexibleContexts+ , LangExt.FlexibleInstances+ , LangExt.KindSignatures+ , LangExt.MagicHash+ , LangExt.MonoLocalBinds+ , LangExt.QuasiQuotes+ , LangExt.ScopedTypeVariables+ , LangExt.TemplateHaskell+ , LangExt.TemplateHaskellQuotes+ , LangExt.TypeApplications+ , LangExt.TypeFamilies+ , LangExt.TypeOperators+#if __GLASGOW_HASKELL__ < 806+ , LangExt.TypeInType+#endif+ ]+ unwanted = [ LangExt.ImplicitPrelude+ , LangExt.MonomorphismRestriction+#if MIN_VERSION_ghc(8,6,0)+ , LangExt.StarIsType+#endif+ , LangExt.Strict+ , LangExt.StrictData+ ]+ -- | Remove all strictness annotations: -- -- * Remove strictness annotations from data type declarations@@ -508,46 +671,89 @@ -- we could lose bits when the original numeric type had more bits than 64. -- -- Removing these strictness annotations is perfectly safe, as they only--- affect simulation behaviour.+-- affect simulation behavior. removeStrictnessAnnotations :: GHC.ParsedModule -> GHC.ParsedModule removeStrictnessAnnotations pm = pm {GHC.pm_parsed_source = fmap rmPS (GHC.pm_parsed_source pm)} where- rmPS :: GHC.DataId name => GHC.HsModule name -> GHC.HsModule name+ -- rmPS :: GHC.DataId name => GHC.HsModule name -> GHC.HsModule name rmPS hsm = hsm {GHC.hsmodDecls = (fmap . fmap) rmHSD (GHC.hsmodDecls hsm)} - rmHSD :: GHC.DataId name => GHC.HsDecl name -> GHC.HsDecl name+ -- rmHSD :: GHC.DataId name => GHC.HsDecl name -> GHC.HsDecl name+#if MIN_VERSION_ghc(8,6,0)+ rmHSD (GHC.TyClD x tyClDecl) = GHC.TyClD x (rmTyClD tyClDecl)+#else rmHSD (GHC.TyClD tyClDecl) = GHC.TyClD (rmTyClD tyClDecl)+#endif rmHSD hsd = hsd - rmTyClD :: GHC.DataId name => GHC.TyClDecl name -> GHC.TyClDecl name+ -- rmTyClD :: GHC.DataId name => GHC.TyClDecl name -> GHC.TyClDecl name rmTyClD dc@(GHC.DataDecl {}) = dc {GHC.tcdDataDefn = rmDataDefn (GHC.tcdDataDefn dc)} rmTyClD tyClD = tyClD - rmDataDefn :: GHC.DataId name => GHC.HsDataDefn name -> GHC.HsDataDefn name+ -- rmDataDefn :: GHC.DataId name => GHC.HsDataDefn name -> GHC.HsDataDefn name rmDataDefn hdf = hdf {GHC.dd_cons = (fmap . fmap) rmCD (GHC.dd_cons hdf)} - rmCD :: GHC.DataId name => GHC.ConDecl name -> GHC.ConDecl name+ -- rmCD :: GHC.DataId name => GHC.ConDecl name -> GHC.ConDecl name+#if MIN_VERSION_ghc(8,6,0)+ rmCD gadt@(GHC.ConDeclGADT {}) = gadt {GHC.con_res_ty = rmHsType (GHC.con_res_ty gadt)+ ,GHC.con_args = rmConDetails (GHC.con_args gadt)+ }+ rmCD h98@(GHC.ConDeclH98 {}) = h98 {GHC.con_args = rmConDetails (GHC.con_args h98)}+ rmCD xcon = xcon+#else rmCD gadt@(GHC.ConDeclGADT {}) = gadt {GHC.con_type = rmSigType (GHC.con_type gadt)} rmCD h98@(GHC.ConDeclH98 {}) = h98 {GHC.con_details = rmConDetails (GHC.con_details h98)}+#endif -- type LHsSigType name = HsImplicitBndrs name (LHsType name)- rmSigType :: GHC.DataId name => GHC.LHsSigType name -> GHC.LHsSigType name+ -- rmSigType :: GHC.DataId name => GHC.LHsSigType name -> GHC.LHsSigType name+#if !MIN_VERSION_ghc(8,6,0) rmSigType hsIB = hsIB {GHC.hsib_body = rmHsType (GHC.hsib_body hsIB)}+#endif -- type HsConDeclDetails name = HsConDetails (LBangType name) (Located [LConDeclField name])- rmConDetails :: GHC.DataId name => GHC.HsConDeclDetails name -> GHC.HsConDeclDetails name+ -- rmConDetails :: GHC.DataId name => GHC.HsConDeclDetails name -> GHC.HsConDeclDetails name rmConDetails (GHC.PrefixCon args) = GHC.PrefixCon (fmap rmHsType args) rmConDetails (GHC.RecCon rec) = GHC.RecCon ((fmap . fmap . fmap) rmConDeclF rec) rmConDetails (GHC.InfixCon l r) = GHC.InfixCon (rmHsType l) (rmHsType r) - rmHsType :: GHC.DataId name => GHC.Located (GHC.HsType name) -> GHC.Located (GHC.HsType name)+ -- rmHsType :: GHC.DataId name => GHC.Located (GHC.HsType name) -> GHC.Located (GHC.HsType name) rmHsType = transform go where+#if MIN_VERSION_ghc(8,6,0)+ go (GHC.unLoc -> GHC.HsBangTy _ _ ty) = ty+#else go (GHC.unLoc -> GHC.HsBangTy _ ty) = ty+#endif go ty = ty - rmConDeclF :: GHC.DataId name => GHC.ConDeclField name -> GHC.ConDeclField name+ -- rmConDeclF :: GHC.DataId name => GHC.ConDeclField name -> GHC.ConDeclField name rmConDeclF cdf = cdf {GHC.cd_fld_type = rmHsType (GHC.cd_fld_type cdf)}++-- | The package id of the clash-prelude we were built with+preludePkgId :: String+preludePkgId = $(lift $ pkgIdFromTypeable (undefined :: TopEntity))++-- | Check that we're using the same clash-prelude as we were built with+--+-- Because if they differ clash won't be able to recognize any ANNotations.+checkForInvalidPrelude :: Monad m => HscTypes.ModGuts -> m ()+checkForInvalidPrelude guts =+ case filter isWrongPrelude pkgIds of+ [] -> return ()+ (x:_) -> throw (ClashException noSrcSpan (msgWrongPrelude x) Nothing)+ where+ pkgs = HscTypes.dep_pkgs . HscTypes.mg_deps $ guts+ pkgIds = map (GhcPlugins.installedUnitIdString . fst) pkgs+ prelude = "clash-prelude-"+ isPrelude pkg = case splitAt (length prelude) pkg of+ (x,y:_) | x == prelude && isDigit y -> True -- check for a digit so we don't match clash-prelude-extras+ _ -> False+ isWrongPrelude pkg = isPrelude pkg && pkg /= preludePkgId+ msgWrongPrelude pkg = unlines ["Clash only works with the exact clash-prelude it was built with."+ ,"Clash was built with: " ++ preludePkgId+ ,"So can't run with: " ++ pkg+ ]
src-ghc/Clash/GHC/NetlistTypes.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} module Clash.GHC.NetlistTypes@@ -15,185 +16,316 @@ import Data.Coerce (coerce) import Data.Functor.Identity (Identity (..))-import Data.HashMap.Strict (HashMap,(!))-import Data.Text.Lazy (pack)+import Data.Text (pack)+import Control.Monad.State.Strict (State) import Control.Monad.Trans.Except- (ExceptT (..), mapExceptT, runExceptT, throwE)+ (Except, ExceptT (..), mapExceptT, runExceptT, throwE)+import Control.Monad.Trans.Maybe (MaybeT (..))+import Language.Haskell.TH.Syntax (showName) import Clash.Core.DataCon (DataCon (..))-import Clash.Core.Name (Name (..), name2String)-import Clash.Core.Pretty (showDoc)-import Clash.Core.TyCon (TyCon (..), TyConOccName, tyConDataCons)+import Clash.Core.Name (Name (..))+import Clash.Core.Pretty (showPpr)+import Clash.Core.TyCon (TyConMap, tyConDataCons) import Clash.Core.Type (LitTy (..), Type (..), TypeView (..), coreView, tyView)-import Clash.Core.Util (tyNatSize)-import Clash.Netlist.Util (coreTypeToHWType)-import Clash.Netlist.Types (HWType(..))-import Clash.Signal.Internal (ClockKind (..), ResetKind (..))+import Clash.Core.Util (tyNatSize, substArgTys)+import Clash.Netlist.Util (coreTypeToHWType, stripFiltered)+import Clash.Netlist.Types+ (HWType(..), HWMap, FilteredHWType(..), PortDirection (..))+import Clash.Signal.Internal+ (ResetPolarity(..), ActiveEdge(..), ResetKind(..)+ ,InitBehavior(..))+import Clash.Unique (lookupUniqMap') import Clash.Util (curLoc) +import Clash.Annotations.BitRepresentation.Internal+ (CustomReprs)+ ghcTypeToHWType :: Int- -> Bool- -> HashMap TyConOccName TyCon+ -- ^ Integer width. The width Clash assumes an Integer to be (instead of it+ -- begin an arbitrarily large, runtime sized construct). -> Bool+ -- ^ Float support+ -> CustomReprs+ -- ^ Custom bit representations+ -> TyConMap+ -- ^ Type constructor map -> Type- -> Maybe (Either String HWType)+ -- ^ Type to convert to HWType+ -> State HWMap (Maybe (Either String FilteredHWType)) ghcTypeToHWType iw floatSupport = go where- go m keepVoid ty@(tyView -> TyConApp tc args) = runExceptT $- case name2String tc of- "GHC.Int.Int8" -> return (Signed 8)- "GHC.Int.Int16" -> return (Signed 16)- "GHC.Int.Int32" -> return (Signed 32)+ -- returnN :: HWType ->+ returnN t = return (FilteredHWType t [])++ go :: CustomReprs -> TyConMap -> Type -> State HWMap (Maybe (Either String FilteredHWType))+ go reprs m (AnnType attrs typ) = fmap Just . runExceptT $ do+ FilteredHWType typ' areVoids <- ExceptT $ coreTypeToHWType go reprs m typ+ return (FilteredHWType (Annotated attrs typ') areVoids)++ go reprs m ty@(tyView -> TyConApp tc args) = runMaybeT . runExceptT $+ case nameOcc tc of+ "GHC.Int.Int8" -> returnN (Signed 8)+ "GHC.Int.Int16" -> returnN (Signed 16)+ "GHC.Int.Int32" -> returnN (Signed 32) "GHC.Int.Int64" -> if iw < 64- then case tyConDataCons (m ! nameOcc tc) of+ then case tyConDataCons (m `lookupUniqMap'` tc) of [dc] -> case dcArgTys dc of [tyView -> TyConApp nm _]- | name2String nm == "GHC.Prim.Int#" ->+ | nameOcc nm == "GHC.Prim.Int#" -> throwE $ unlines ["Int64 not supported in forced 32-bit mode on a 64-bit machine." ,"Run Clash with `-fclash-intwidth=64`." ]- | name2String nm == "GHC.Prim.Int64#" ->- return (Signed 64)+ | nameOcc nm == "GHC.Prim.Int64#" ->+ returnN (Signed 64) _ -> throwE $ $(curLoc) ++ "Int64 DC has unexpected amount of arguments" _ -> throwE $ $(curLoc) ++ "Int64 TC has unexpected amount of DCs"- else return (Signed 64)- "GHC.Word.Word8" -> return (Unsigned 8)- "GHC.Word.Word16" -> return (Unsigned 16)- "GHC.Word.Word32" -> return (Unsigned 32)+ else returnN (Signed 64)+ "GHC.Word.Word8" -> returnN (Unsigned 8)+ "GHC.Word.Word16" -> returnN (Unsigned 16)+ "GHC.Word.Word32" -> returnN (Unsigned 32) "GHC.Word.Word64" -> if iw < 64- then case tyConDataCons (m ! nameOcc tc) of+ then case tyConDataCons (m `lookupUniqMap'` tc) of [dc] -> case dcArgTys dc of [tyView -> TyConApp nm _]- | name2String nm == "GHC.Prim.Word#" ->+ | nameOcc nm == "GHC.Prim.Word#" -> throwE $ unlines ["Word64 not supported in forced 32-bit mode on a 64-bit machine." ,"Run Clash with `-fclash-intwidth=64`." ]- | name2String nm == "GHC.Prim.Word64#" ->- return (Unsigned 64)+ | nameOcc nm == "GHC.Prim.Word64#" ->+ returnN (Unsigned 64) _ -> throwE $ $(curLoc) ++ "Word64 DC has unexpected amount of arguments" _ -> throwE $ $(curLoc) ++ "Word64 TC has unexpected amount of DCs"- else return (Unsigned 64)- "GHC.Integer.Type.Integer" -> return (Signed iw)- "GHC.Natural.Natural" -> return (Unsigned iw)- "GHC.Prim.Char#" -> return (Unsigned 21)- "GHC.Prim.Int#" -> return (Signed iw)- "GHC.Prim.Word#" -> return (Unsigned iw)- "GHC.Prim.Int64#" -> return (Signed 64)- "GHC.Prim.Word64#" -> return (Unsigned 64)- "GHC.Prim.Float#" | floatSupport -> return (BitVector 32)- "GHC.Prim.Double#" | floatSupport -> return (BitVector 64)+ else returnN (Unsigned 64)+ "GHC.Integer.Type.Integer" -> returnN (Signed iw)+ "GHC.Natural.Natural" -> returnN (Unsigned iw)+ "GHC.Prim.Char#" -> returnN (Unsigned 21)+ "GHC.Prim.Int#" -> returnN (Signed iw)+ "GHC.Prim.Word#" -> returnN (Unsigned iw)+ "GHC.Prim.Int64#" -> returnN (Signed 64)+ "GHC.Prim.Word64#" -> returnN (Unsigned 64)+ "GHC.Prim.Float#" | floatSupport -> returnN (BitVector 32)+ "GHC.Prim.Double#" | floatSupport -> returnN (BitVector 64) "GHC.Prim.ByteArray#" ->- throwE $ "Can't translate type: " ++ showDoc ty-- "GHC.Types.Bool" -> return Bool- "GHC.Types.Float" | floatSupport-> return (BitVector 32)- "GHC.Types.Double" | floatSupport -> return (BitVector 64)- "GHC.Prim.~#" -> return (Void Nothing)+ throwE $ "Can't translate type: " ++ showPpr ty - "GHC.Prim.Any" -> return (Void Nothing)+ "GHC.Types.Bool" -> returnN Bool+ "GHC.Types.Float" | floatSupport-> returnN (BitVector 32)+ "GHC.Types.Double" | floatSupport -> returnN (BitVector 64)+ "GHC.Prim.~#" -> returnN (Void Nothing) "Clash.Signal.Internal.Signal" ->- ExceptT $ return $ coreTypeToHWType go m keepVoid (args !! 1)+ ExceptT $ MaybeT $ Just <$> coreTypeToHWType go reprs m (args !! 1) + "Clash.Signal.BiSignal.BiSignalIn" -> do+ let [_, _, szTy] = args+ let fType ty1 = FilteredHWType ty1 []+ (fType . BiDirectional In . BitVector . fromInteger) <$>+ liftE (tyNatSize m szTy)++ "Clash.Signal.BiSignal.BiSignalOut" -> do+ let [_, _, szTy] = args+ let fType ty1 = FilteredHWType ty1 []+ (fType . Void . Just . BiDirectional Out . BitVector . fromInteger) <$>+ liftE (tyNatSize m szTy)++ -- XXX: this is a hack to get a KnownDomain from a KnownConfiguration+ "GHC.Classes.(%,%)"+ | [arg0@(tyView -> TyConApp kdNm _), _] <- args+ , nameOcc kdNm == "Clash.Signal.Internal.KnownDomain"+ -> ExceptT (MaybeT (go reprs m arg0))++ "Clash.Signal.Internal.KnownDomain"+ -> case tyConDataCons (m `lookupUniqMap'` tc) of+ [dc] -> case substArgTys dc args of+ [_,tyView -> TyConApp _ [_,dom]] -> case tyView (coreView m dom) of+ TyConApp _ [tag0, period0, edge0, rstKind0, init0, polarity0] -> do+ tag1 <- domTag tag0+ period1 <- domPeriod period0+ edge1 <- domEdge m edge0+ rstKind1 <- domResetKind m rstKind0+ init1 <- domInitBehavior m init0+ polarity1 <- domResetPolarity m polarity0+ let kd = KnownDomain (pack tag1) period1 edge1 rstKind1 init1 polarity1+ returnN (Void (Just kd))+ _ -> ExceptT (MaybeT (pure Nothing))+ _ -> ExceptT (MaybeT (pure Nothing))+ _ -> ExceptT (MaybeT (pure Nothing))+ "Clash.Signal.Internal.Clock"- | [dom,clkKind] <- args- -> do (nm,rate) <- domain m dom- gated <- clockKind m clkKind- return (Clock (pack nm) rate gated)+ | [tag0] <- args+ -> do+ tag1 <- domTag tag0+ returnN (Clock (pack tag1)) "Clash.Signal.Internal.Reset"- | [dom,rstKind] <- args- -> do (nm,rate) <- domain m dom- synchronous <- resetKind m rstKind- return (Reset (pack nm) rate synchronous)+ | [tag0] <- args+ -> do+ tag1 <- domTag tag0+ returnN (Reset (pack tag1)) - "Clash.Sized.Internal.BitVector.Bit" -> return Bit+ "Clash.Sized.Internal.BitVector.Bit" -> returnN Bit "Clash.Sized.Internal.BitVector.BitVector" -> do- n <- mapExceptT (Just . coerce) (tyNatSize m (head args))+ n <- liftE (tyNatSize m (head args)) case n of- 0 -> return (Void (Just (BitVector (fromInteger n))))- _ -> return (BitVector (fromInteger n))+ 0 -> returnN (Void (Just (BitVector (fromInteger n))))+ _ -> returnN (BitVector (fromInteger n)) "Clash.Sized.Internal.Index.Index" -> do- n <- mapExceptT (Just . coerce) (tyNatSize m (head args))+ n <- liftE (tyNatSize m (head args)) if n < 2- then return (Void (Just (Index (fromInteger n))))- else return (Index (fromInteger n))+ then returnN (Void (Just (Index (fromInteger n))))+ else returnN (Index (fromInteger n)) "Clash.Sized.Internal.Signed.Signed" -> do- n <- mapExceptT (Just . coerce) (tyNatSize m (head args))+ n <- liftE (tyNatSize m (head args)) if n == 0- then return (Void (Just (Signed (fromInteger n))))- else return (Signed (fromInteger n))+ then returnN (Void (Just (Signed (fromInteger n))))+ else returnN (Signed (fromInteger n)) "Clash.Sized.Internal.Unsigned.Unsigned" -> do- n <- mapExceptT (Just .coerce) (tyNatSize m (head args))+ n <- liftE (tyNatSize m (head args)) if n == 0- then return (Void (Just (Unsigned (fromInteger n))))- else return (Unsigned (fromInteger n))+ then returnN (Void (Just (Unsigned (fromInteger n))))+ else returnN (Unsigned (fromInteger n)) "Clash.Sized.Vector.Vec" -> do let [szTy,elTy] = args- sz <- mapExceptT (Just . coerce) (tyNatSize m szTy)- elHWTy <- ExceptT $ return $ coreTypeToHWType go m keepVoid elTy- case elHWTy of- Void {} -> return (Void (Just (Vector (fromInteger sz) elHWTy)))- _ | sz == 0 -> return (Void (Just (Vector (fromInteger sz) elHWTy)))- _ -> return $ Vector (fromInteger sz) elHWTy+ sz0 <- liftE (tyNatSize m szTy)+ fElHWTy <- ExceptT $ MaybeT $ Just <$> coreTypeToHWType go reprs m elTy + -- Treat Vec as a product type with a single constructor and N+ -- constructor fields.+ let sz1 = fromInteger sz0 :: Int+ elHWTy = stripFiltered fElHWTy++ let+ (isVoid, vecHWTy) =+ case elHWTy of+ Void {} -> (True, Void (Just (Vector sz1 elHWTy)))+ _ | sz1 == 0 -> (True, Void (Just (Vector sz1 elHWTy)))+ _ -> (False, Vector sz1 elHWTy)++ let filtered = [replicate sz1 (isVoid, fElHWTy)]+ return (FilteredHWType vecHWTy filtered)+ "Clash.Sized.RTree.RTree" -> do let [szTy,elTy] = args- sz <- mapExceptT (Just . coerce) (tyNatSize m szTy)- elHWTy <- ExceptT $ return $ coreTypeToHWType go m keepVoid elTy- case elHWTy of- Void {} -> return (Void (Just (RTree (fromInteger sz) elHWTy)))- _ -> return $ RTree (fromInteger sz) elHWTy+ sz0 <- liftE (tyNatSize m szTy)+ fElHWTy <- ExceptT $ MaybeT $ Just <$> coreTypeToHWType go reprs m elTy - "String" -> return String+ -- Treat RTree as a product type with a single constructor and 2^N+ -- constructor fields.+ let sz1 = fromInteger sz0 :: Int+ elHWTy = stripFiltered fElHWTy++ let+ (isVoid, vecHWTy) =+ case elHWTy of+ Void {} -> (True, Void (Just (RTree sz1 elHWTy)))+ _ -> (False, RTree sz1 elHWTy)++ let filtered = [replicate (2^sz1) (isVoid, fElHWTy)]+ return (FilteredHWType vecHWTy filtered)++ "String" -> returnN String "GHC.Types.[]" -> case tyView (head args) of- (TyConApp (name2String -> "GHC.Types.Char") []) -> return String- _ -> throwE $ "Can't translate type: " ++ showDoc ty+ (TyConApp (nameOcc -> "GHC.Types.Char") []) -> returnN String+ _ -> throwE $ "Can't translate type: " ++ showPpr ty - _ -> ExceptT Nothing+ -- To ensure that Clash doesn't get stuck working away callstacks that+ -- never end up being used in the generated HDL.+ "GHC.Stack.Types.CallStack" -> returnN (Void Nothing) - go _ _ _ = Nothing+ _ -> ExceptT (MaybeT (pure Nothing)) -domain- :: HashMap TyConOccName TyCon+ go _ _ _ = pure Nothing++liftE+ :: Applicative m+ => Except e a+ -> ExceptT e (MaybeT m) a+liftE = mapExceptT (MaybeT . pure . Just . coerce)++domTag :: Monad m => Type -> ExceptT String (MaybeT m) String+domTag (LitTy (SymTy tag)) = pure tag+domTag ty = throwE $ "Can't translate domain tag" ++ showPpr ty++domPeriod :: Monad m => Type -> ExceptT String (MaybeT m) Integer+domPeriod (LitTy (NumTy period)) = pure period+domPeriod ty = throwE $ "Can't translate domain period" ++ showPpr ty++fromType+ :: Monad m+ => String+ -- ^ Name of type (for error reporting)+ -> [(String, a)]+ -- ^ [(Fully qualified constructor name, constructor value)+ -> TyConMap+ -- ^ Constructor map (used to look through newtypes) -> Type- -> ExceptT String Maybe (String,Integer)-domain m (coreView m -> Just ty') = domain m ty'-domain m (tyView -> TyConApp tcNm [LitTy (SymTy nm),rateTy])- | name2String tcNm == "Clash.Signal.Internal.Dom"- = do rate <- mapExceptT (Just . coerce) (tyNatSize m rateTy)- return (nm,rate)-domain _ ty = throwE $ "Can't translate domain: " ++ showDoc ty+ -- ^ Type representing some constructor+ -> ExceptT String (MaybeT m) a+fromType tyNm constrs m ty =+ case tyView (coreView m ty) of+ TyConApp tcNm [] ->+ go constrs (nameOcc tcNm)+ _ ->+ throwE $ "Can't translate " ++ tyNm ++ showPpr ty+ where+ go ((cName,c):cs) tcNm =+ if pack cName == tcNm then+ pure c+ else+ go cs tcNm+ go [] _ =+ throwE $ "Can't translate " ++ tyNm ++ showPpr ty -clockKind- :: HashMap TyConOccName TyCon+domEdge+ :: Monad m+ => TyConMap -> Type- -> ExceptT String Maybe ClockKind-clockKind m (coreView m -> Just ty') = clockKind m ty'-clockKind _ (tyView -> TyConApp tcNm [])- | name2String tcNm == "Clash.Signal.Internal.Source"- = return Source- | name2String tcNm == "Clash.Signal.Internal.Gated"- = return Gated-clockKind _ ty = throwE $ "Can't translate ClockKind" ++ showDoc ty+ -> ExceptT String (MaybeT m) ActiveEdge+domEdge =+ fromType+ (showName ''ActiveEdge)+ [ (showName 'Rising, Rising)+ , (showName 'Falling, Falling) ] -resetKind- :: HashMap TyConOccName TyCon+domResetKind+ :: Monad m+ => TyConMap -> Type- -> ExceptT String Maybe ResetKind-resetKind m (coreView m -> Just ty') = resetKind m ty'-resetKind _ (tyView -> TyConApp tcNm [])- | name2String tcNm == "Clash.Signal.Internal.Synchronous"- = return Synchronous- | name2String tcNm == "Clash.Signal.Internal.Asynchronous"- = return Asynchronous-resetKind _ ty = throwE $ "Can't translate ResetKind" ++ showDoc ty+ -> ExceptT String (MaybeT m) ResetKind+domResetKind =+ fromType+ (showName ''ResetKind)+ [ (showName 'Synchronous, Synchronous)+ , (showName 'Asynchronous, Asynchronous) ]++domInitBehavior+ :: Monad m+ => TyConMap+ -> Type+ -> ExceptT String (MaybeT m) InitBehavior+domInitBehavior =+ fromType+ (showName ''InitBehavior)+ [ (showName 'Defined, Defined)+ , (showName 'Unknown, Unknown) ]++domResetPolarity+ :: Monad m+ => TyConMap+ -> Type+ -> ExceptT String (MaybeT m) ResetPolarity+domResetPolarity =+ fromType+ (showName ''ResetPolarity)+ [ (showName 'ActiveHigh, ActiveHigh)+ , (showName 'ActiveLow, ActiveLow) ]
+ src-ghc/Clash/GHC/Util.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Clash.GHC.Util where++import ErrUtils (mkPlainErrMsg)+import GHC (GhcMonad(..), printException)+import GhcPlugins (DynFlags, SourceError, ($$), blankLine, empty, isGoodSrcSpan, liftIO, noSrcSpan, text, throwOneError)++import Control.Exception (Exception(..), ErrorCall(..))+import GHC.Exception (SomeException)+import System.Exit (ExitCode(ExitFailure), exitWith)++import Clash.Util (ClashException(..))+import Clash.Driver.Types (ClashOpts(..))++handleClashException+ :: GhcMonad m+ => DynFlags+ -> ClashOpts+ -> SomeException+ -> m a+handleClashException df opts e = case fromException e of+ Just (ClashException sp s eM) -> do+ let srcInfo' | isGoodSrcSpan sp = srcInfo+ | otherwise = empty+ throwOneError (mkPlainErrMsg df sp (text s $$ srcInfo' $$ showExtra (opt_errorExtra opts) eM))+ _ -> case fromException e of+ Just (ErrorCall msg) ->+ throwOneError (mkPlainErrMsg df noSrcSpan (text "Clash error call:" $$ text msg))+ _ -> case fromException e of+ Just (e' :: SourceError) -> do+ GHC.printException e'+ liftIO $ exitWith (ExitFailure 1)+ _ -> throwOneError (mkPlainErrMsg df noSrcSpan (text "Other error:" $$ text (displayException e)))+ where+ srcInfo = text "NB: The source location of the error is not exact, only indicative, as it is acquired after optimisations." $$+ text "The actual location of the error can be in a function that is inlined." $$+ text "To prevent inlining of those functions, annotate them with a NOINLINE pragma."++ showExtra False (Just _) =+ blankLine $$+ text "This error contains additional information, rerun with '-fclash-error-extra' to show this information."+ showExtra True (Just msg) =+ blankLine $$+ text "Additional information:" $$ blankLine $$+ text msg+ showExtra _ _ = empty
src-ghc/Interactive.hs view
@@ -13,4 +13,4 @@ import Clash.Main ( defaultMain ) main :: IO ()-main = getArgs >>= defaultMain . ("--interactive":)+main = getArgs >>= defaultMain . (["--interactive","-fobject-code"]++)