@@ -44,7 +44,7 @@ import qualified Data.Text.Encoding.Error as TE
44
44
import qualified Data.Text.Encoding as T
45
45
import qualified Data.Text as T
46
46
import Control.Arrow (second )
47
- import Control.Monad ((>=>) , foldM , when )
47
+ import Control.Monad ((>=>) , foldM , when , forM )
48
48
import qualified Text.PrettyPrint.HughesPJ as PJ
49
49
import Language.Fixpoint.Types hiding (L , panic , Loc (.. ), SrcSpan , Constant , SESearch (.. ))
50
50
import qualified Language.Fixpoint.Types as F
@@ -899,36 +899,18 @@ withWiredIn :: TcM a -> TcM a
899
899
withWiredIn m = discardConstraints $ do
900
900
-- undef <- lookupUndef
901
901
wiredIns <- mkWiredIns
902
- -- snd <$> tcValBinds Ghc.NotTopLevel (binds undef wiredIns) (sigs wiredIns) m
903
902
(_, _, a) <- tcValBinds Ghc. NotTopLevel [] (sigs wiredIns) m
904
903
return a
905
904
906
905
where
907
- -- lookupUndef = do
908
- -- lookupOrig gHC_ERR (Ghc.mkVarOcc "undefined")
909
- -- -- tcLookupGlobal undefName
910
-
911
- -- binds :: Name -> [TcWiredIn] -> [(Ghc.RecFlag, LHsBinds GhcRn)]
912
- -- binds undef wiredIns = map (\w ->
913
- -- let ext = Ghc.unitNameSet undef in -- $ varName $ tyThingId undef in
914
- -- let co_fn = idHsWrapper in
915
- -- let matches =
916
- -- let ctxt = LambdaExpr in
917
- -- let grhss = GRHSs Ghc.noExtField [Ghc.L locSpan (GRHS Ghc.noExtField [] (Ghc.L locSpan (HsVar Ghc.noExtField (Ghc.L locSpan undef))))] (Ghc.L locSpan emptyLocalBinds) in
918
- -- MG Ghc.noExtField (Ghc.L locSpan [Ghc.L locSpan (Match Ghc.noExtField ctxt [] grhss)]) Ghc.Generated
919
- -- in
920
- -- let b = FunBind ext (Ghc.L locSpan $ tcWiredInName w) matches co_fn [] in
921
- -- (Ghc.NonRecursive, unitBag (Ghc.L locSpan b))
922
- -- ) wiredIns
923
-
924
- sigs wiredIns = concatMap (\ w ->
925
- let inf = maybeToList $ (\ (fPrec, fDir) -> Ghc. L locSpanAnn $ Ghc. FixSig Ghc. noAnn $ Ghc. FixitySig Ghc. NoNamespaceSpecifier [Ghc. L locSpanAnn (tcWiredInName w)] $ Ghc. Fixity Ghc. NoSourceText fPrec fDir) <$> tcWiredInFixity w in
926
- let t =
927
- let ext' = [] in
928
- [Ghc. L locSpanAnn $ TypeSig Ghc. noAnn [Ghc. L locSpanAnn (tcWiredInName w)] $ HsWC ext' $ Ghc. L locSpanAnn $ HsSig Ghc. noExtField (HsOuterImplicit ext') $ tcWiredInType w]
929
- in
930
- inf <> t
931
- ) wiredIns
906
+ sig w = typeSig : maybeToList fixSig
907
+ where
908
+ fixSig = forM (tcWiredInFixity w) $ \ (fPrec, fDir) ->
909
+ toLoc $ Ghc. FixSig Ghc. noAnn $ Ghc. FixitySig Ghc. NoNamespaceSpecifier [Ghc. L locSpanAnn (tcWiredInName w)] $ Ghc. Fixity Ghc. NoSourceText fPrec fDir
910
+
911
+ typeSig = toLoc $ TypeSig Ghc. noAnn [toLoc $ tcWiredInName w] $ HsWC [] $ toLoc $ HsSig Ghc. noExtField (HsOuterImplicit [] ) $ tcWiredInType w
912
+
913
+ sigs wiredIns = concatMap sig wiredIns
932
914
933
915
locSpan = UnhelpfulSpan (UnhelpfulOther " Liquid.GHC.Misc: WiredIn" )
934
916
locSpanAnn = noAnnSrcSpan locSpan
@@ -945,10 +927,7 @@ withWiredIn m = discardConstraints $ do
945
927
toLoc = Ghc. L locSpanAnn
946
928
nameToTy = Ghc. L locSpanAnn . HsTyVar Ghc. noAnn Ghc. NotPromoted
947
929
948
- boolTy' :: LHsType GhcRn
949
930
boolTy' = nameToTy $ toLoc boolTyConName
950
- -- boolName <- lookupOrig (Module (stringToUnitId "Data.Bool") (mkModuleName "Data.Bool")) (Ghc.mkVarOcc "Bool")
951
- -- return $ Ghc.L locSpan $ HsTyVar Ghc.noExtField Ghc.NotPromoted $ Ghc.L locSpan boolName
952
931
intTy' = nameToTy $ toLoc intTyConName
953
932
listTy lt = toLoc $ HsAppTy Ghc. noExtField (nameToTy $ toLoc listTyConName) lt
954
933
0 commit comments